PDL-2.018/0000755060175006010010000000000013110402051010357 5ustar chmNonePDL-2.018/Basic/0000755060175006010010000000000013110402046011404 5ustar chmNonePDL-2.018/Basic/AutoLoader.pm0000644060175006010010000002072313036512174014020 0ustar chmNone =head1 NAME PDL::AutoLoader - MatLab style AutoLoader for PDL =head1 SYNOPSIS use PDL::AutoLoader; $a = func1(...); # Load file func1.pdl $b = func2(...); # Load file func2.pdl $PDL::AutoLoader::Rescan = 1; # Enable re-scanning =head1 DESCRIPTION This module implements a MatLab style AutoLoader for PDL. If an unknown function C is called, PDL looks for a file called C. If it finds one, it compiles the file and calls the function C. The list of directories to search in is given by the shell environment variable C. This is a colon-separated list of directories. On MSWindows systems, is it a I -separated list of directories. For example, in csh: setenv PDLLIB "/home/joe/pdllib:/local/pdllib" B: This variable is unrelated to Perl's C. If you add a leading '+' on a directory name, PDL will search the entire directory tree below that point. Internally, PDL stores the directory list in the variable C<@PDLLIB>, which can be modified at run time. For example, in csh: setenv PDLLIB "+/home/joe/PDL" will search /home/joe/PDL and all its subdirectories for .pdl files. =head2 AUTO-SCANNING The variable C<$PDL::AutoLoader::Rescan> controls whether files are automatically re-scanned for changes at the C or C command line. If C<$PDL::AutoLoader::Rescan == 1> and the file is changed then the new definition is reloaded auto-matically before executing the C or C command line. Which means in practice you can edit files, save changes and have C or C see the changes automatically. The default is '0' - i.e. to have this feature disabled. As this feature is only pertinent to the PDL shell it imposes no overhead on PDL scripts. Yes Bob you can have your cake and eat it too! Note: files are only re-evaled if they are determined to have been changed according to their date/time stamp. No doubt this interface could be improved upon some more. :-) =head2 Sample file: sub foo { # file 'foo.pdl' - define the 'foo' function my $x=shift; return sqrt($x**2 + $x**3 + 2); } 1; # File returns true (i.e. loaded successfully) =head1 AUTHOR Copyright(C) 1997 Karl Glazebrook (kgb@aaoepp.aao.gov.au); several extensions by Craig DeForest (deforest@boulder.swri.edu) All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =head1 BUGS No doubt this interface could be improved upon some more. :-) Will probably be quite slow if C<$PDL::AutoLoader::Rescan == 1> and thousands of functions have been autoloaded. There could be a race condition in which the file changes while the internal autoloader code is being executed but it should be harmless. Probably has not been tested enough! =head1 SEE ALSO For an alternative approach to managing a personal collaction of modules and functions, see L. =cut BEGIN{ if (defined $ENV{"PDLLIB"}) { if ( $^O eq 'MSWin32' ) { # win32 flavors @PDLLIB = (".",split(';',$ENV{"PDLLIB"})); s/"//g for @PDLLIB; } else { # unixen systems @PDLLIB = (".",split(':',$ENV{"PDLLIB"})); } @PDLLIB = grep length, @PDLLIB; } $PDL::AutoLoader::Rescan=0; %PDL::AutoLoader::FileInfo = (); } # Code to reload stuff if changed sub PDL::AutoLoader::reloader { return unless $PDL::AutoLoader::Rescan; # Now check functions and reload if changed my ($file, $old_t); for my $func (keys %PDL::AutoLoader::FileInfo) { ($file, $old_t) = @{ $PDL::AutoLoader::FileInfo{$func} }; if ( (stat($file))[9]>$old_t ) { # Reload print "Reloading $file as file changed...\n" if $PDL::verbose; &PDL::AutoLoader::autoloader_do($file); $PDL::AutoLoader::FileInfo{$func} = [ $file, (stat($file))[9] ]; } } } # Used for Beta, and should probably be used generall in this mod #use File::Spec; sub PDL::AutoLoader::import { # Beta folder support # foreach (@INC) { # $Beta_dir = File::Spec->catfile($_, 'PDL', 'Beta'); # push @PDLLIB, "+$Beta_dir" if -d $Beta_dir; # } my $pkg = (caller())[0]; my $toeval = "package $pkg;\n"; # Make sure that the eval gets NiceSlice if we have it in this level # (it's a drag that preprocessors aren't transitive...) $toeval .= "use PDL::NiceSlice;\n" if(defined $PDL::NiceSlice::VERSION); $toeval .= <<'EOD'; $PDLLIB_CT = 0; push @PERLDL::AUTO, \&PDL::AutoLoader::reloader; sub AUTOLOAD { local @INC = @INC; my @args = @_; $AUTOLOAD =~ /::([^:]*)$/; my $func = $1; # Trap spurious calls from 'use UnknownModule' goto &$AUTOLOAD if ord($func)==0; # Check if the PDLLIB needs to be expanded and, if so, expand it. # This only updates when PDLLIB changes size, which should be OK # for most things but doesn't catch new directories in expanded # directory trees. It seems like an OK compromise between never # catching anything and always thrashing through the directories. if($PDLLIB_CT != scalar(@PDLLIB)) { @PDLLIB_EXPANDED = PDL::AutoLoader::expand_path(@PDLLIB); $PDLLIB_CT = scalar(@PDLLIB); } print "Loading $func.pdl ..." if $PDL::verbose; my $file; my $s = "PDL AutoLoader: Undefined subroutine $func() cannot be autoloaded.\n"; for my $dir (@PDLLIB_EXPANDED) { $file = $dir . "/" . "$func.pdl"; if (-e $file) { print "found $file\n" if $PDL::verbose; &PDL::AutoLoader::autoloader_do($file); # Remember autoloaded functions and do some reasonably # smart cacheing of file/directory change times if ($PDL::AutoLoader::Rescan) { $PDL::AutoLoader::FileInfo{$func} = [ $file, (stat($file))[9] ]; } # Now go to the autoload function ##goto &$AUTOLOAD(@args) unless ($@ || !defined(&{$AUTOLOAD})); return &$AUTOLOAD(@args) unless ($@ || !defined(&{$AUTOLOAD})); die $s."\tWhile parsing file `$file':\n$@\n" if($@); die $s."\tFile `$file' doesn't \n\tdefine ${AUTOLOAD}().\n" } } die $s."\tNo file `$func.pdl' was found in your \@PDLLIB path.\n"; } EOD eval $toeval; } # Simple 'do' doesn't work with preprocessing -- this replaces # "do file" and sticks NiceSlice in manually if it's needed (yuck). sub PDL::AutoLoader::autoloader_do { my ($file) = shift; if(defined($PDL::NiceSlice::VERSION)) { print "AutoLoader: NiceSlice enabled...\n" if($PDL::debug); if(open(AUTOLOAD_FILE,"<$file")) { my($script) = &PDL::NiceSlice::perldlpp("PDL::NiceSlice", join("",)); eval $script; } } else { print "AutoLoader: no NiceSlice...\n" if($PDL::debug); do $file; } } # Expand directories recursively... sub PDL::AutoLoader::expand_dir { local $d; local @list; local @subdirs; local $dir = shift; if(! -d $dir) { return undef; } push(@list,$dir); opendir(FOO,$dir); @subdirs = grep((!m/^\./ && ($_="$dir/$_") && (-d $_)), readdir(FOO)); closedir FOO; while(defined ($d = shift @subdirs)) { push(@list,&PDL::AutoLoader::expand_dir($d)); } return @list; } =head2 PDL::AutoLoader::expand_path =for ref Expand a compactified path into a dir list You supply a pathlist and leading '+' and '~' characters get expanded into full directories. Normally you don't want to use this -- it's internal to the autoloader -- but some utilities, like the online documentation searcher, need to be able to use it. =cut sub PDL::AutoLoader::expand_path { my @PDLLIB = @_; my @PDLLIB_EXPANDED; print "AutoLoader: Expanding directories from ".join(':',@PDLLIB)."...\n" if($PDL::debug); local $_; foreach $_(@PDLLIB) { # Expand ~{name} and ~ conventions. if(s/^(\+?)\~(\+||[a-zA-Z0-9]*)//) { if($2 eq '+') { # Expand shell '+' to CWD. $_= $1 . ($ENV{'PWD'} || '.'); } elsif(!$2) { # No name mentioned -- use current user. # Ideally would use File::HomeDir->my_home() here $_ = $1 . ( $ENV{'HOME'} || (( getpwnam( getlogin || getpwuid($<) ))[7]) ) . $_; } else { # Name mentioned - try to get that user's home directory. $_ = $1 . ( (getpwnam($2))[7] ) . $_; } } # If there's a leading '+', include all subdirs too. push(@PDLLIB_EXPANDED, s/^\+// ? &PDL::AutoLoader::expand_dir($_) : $_ ); } print "AutoLoader: returning ",join(",",@PDLLIB_EXPANDED),"\n" if($PDL::debug); @PDLLIB_EXPANDED; } ;# Exit with OK status 1; PDL-2.018/Basic/Bad/0000755060175006010010000000000013110402045012071 5ustar chmNonePDL-2.018/Basic/Bad/bad.pd0000644060175006010010000010270513036512174013165 0ustar chmNone' # Needed for CPAN indexing? package PDL::Bad; '; =pod =head1 bad.pd The PDL definition for bad value handling. What you are reading is the pod documentation as extracted directly from the .pd file, which is not what you will see reported on your own machine. (I'm guessing you're reading this from CPAN.) What you see on your own machine depends on your PDL's configuration, as discussed near the bottom of this document. =head1 DESCRIPTION The contents of Bad.pm depend on whether we have bad-value support in PDL. If we do not have bad support then the module just contains a set of methods which essentially do nothing (they may return 0 or undef or a copy of the input piddle [thankfully PDL::copy handles inplace ops]) =cut use strict; # check for bad value support use PDL::Config; use PDL::Core::Dev; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; my $usenan = $PDL::Config{BADVAL_USENAN} || 0; my $bvalPerPdl = $PDL::Config{BADVAL_PER_PDL} || 0; ######################################################### =head1 Docs for no Bad Value support If you don't have bad value support enabled, your docs for this module will look something like this. =cut # if no bad-value support, this is easy unless ( $bvalflag ) { my $bulk_of_file = <<'!NO!SUBS!'; =head2 NAME PDL::Bad - PDL does not process bad values =head2 DESCRIPTION PDL has been compiled with WITH_BADVAL either 0 or undef, so it does not contain any bad-value support code. Actually, a number of methods are defined, but they are only placeholders to make writing other code, that has to handle WITH_BADVAL being true or false, easier. Implementation details are given in L. =head2 SYNOPSIS use PDL::Bad; print "\nBad value support in PDL is turned " . $PDL::Bad::Status ? "on" : "off" . ".\n"; Bad value support in PDL is turned off. =head2 VARIABLES There are currently three variables that this module defines which may be of use. =over 4 =item $PDL::Bad::Status Set to 0 =item $PDL::Bad::UseNaN Set to 0 =item $PDL::Bad::PerPdl Set to 0 =back =cut # really should be a constant $PDL::Bad::Status = 0; $PDL::Bad::UseNaN = 0; $PDL::Bad::PerPdl = 0; # dummy routines # *badflag = \&PDL::badflag; *badvalue = \&PDL::badvalue; *orig_badvalue = \&PDL::orig_badvalue; sub PDL::badflag { return 0; } # no piddles can contain bad values by design sub PDL::badvalue { return undef; } sub PDL::orig_badvalue { return undef; } *check_badflag = \&PDL::check_badflag; sub PDL::check_badflag { return 0; } # no piddles can contain bad values by design *isbad = \&PDL::isbad; *isgood = \&PDL::isgood; sub PDL::isbad { return 0; } # no piddles can contain bad values by design sub PDL::isgood { return 1; } # no piddles can contain bad values by design *nbadover = \&PDL::nbadover; *ngoodover = \&PDL::ngoodover; *nbad = \&PDL::nbad; *ngood = \&PDL::ngood; # Pars => 'a(n); int+ [o]b();', # collapse the input piddle along it's first dimension and set to 0's # - using sumover to do the projection as I'm too lazy to do it # myself # sub PDL::nbadover { return PDL::sumover( $_[0] * 0 ); } sub PDL::ngoodover { return PDL::sumover( $_[0] * 0 + 1 ); } sub PDL::nbad { return 0; } sub PDL::ngood { return $_[0]->nelem; } *setbadat = \&PDL::setbadat; *setbadif = \&PDL::setbadif; # As these can't be done inplace we try to keep the # same behaviour here # sub PDL::setbadat { $_[0]->set_inplace(0); return $_[0]->copy; } sub PDL::setbadif { $_[0]->set_inplace(0); return $_[0]->copy; } *setvaltobad = \&PDL::setvaltobad; *setbadtoval = \&PDL::setvaltobad; *setnantobad = \&PDL::setnantobad; *setbadtonan = \&PDL::setbadtonan; # this can be done inplace # fortunately PDL::copy handles inplace ops sub PDL::setvaltobad { return $_[0]->copy; } sub PDL::setbadtoval { return $_[0]->copy; } sub PDL::setnantobad { return $_[0]->copy; } sub PDL::setbadtonan { return $_[0]->copy; } *copybad = \&PDL::copybad; sub PDL::copybad { return $_[0]->copy; } # ignore the mask !NO!SUBS! # Replace the head2 with head1 $bulk_of_file =~ s/head2/head1/g; pp_addpm({At=>'Top'},$bulk_of_file); pp_add_exported( '', 'badflag check_badflag badvalue orig_badvalue nbad nbadover ngood ngoodover ' . 'setbadat setbadif setvaltobad setbadtoval setnantobad setbadtonan copybad '. 'isbad isgood ' ); pp_done(); exit; } # unless: $bvalflag ######################################################### # _finite in VC++ if ($^O =~ /MSWin/) { pp_addhdr(' #define finite _finite #include '); } else { #taken from pdlcore.c.PL. Probably overkill here: could we just do '#define finite isfinite' ? my $finite_inc; my $use_isfinite = 0; foreach my $inc ( qw/ math.h ieeefp.h / ) { if ( trylink ('', "#include <$inc>", 'isfinite(3.2);', '' ) ) { $finite_inc = $inc; $use_isfinite = 1; last; } if ( (!defined($finite_inc)) and trylink ("finite: $inc", "#include <$inc>", 'finite(3.2);','') ) { $finite_inc = $inc; } } if ( defined $finite_inc ) { pp_addhdr(" #include <$finite_inc> #define finite(a) (isfinite(a)) "); } else { pp_addhdr(' /* Kludgy finite/isfinite because bad.pd was unable to find one in your math library */ #ifndef finite #ifdef isfinite #define finite isfinite #else #define finite(a) (((a) * 0) == (0)) #endif #endif '); } } pp_add_exported( '', 'badflag check_badflag badvalue orig_badvalue nbad nbadover ngood ngoodover ' . 'setbadat ' ); # If UseNaN == 0, we need to have a variable containing the # value for NaN. This is taken from Basic/Core/Core.xs.PL # if ( $usenan == 0 ) { require PDL::Core::Dev; PDL::Core::Dev->import; pp_addhdr( "\nstatic union { unsigned char __c[4]; float __d; } __pdl_nan = {\n" ); if ( isbigendian() ) { pp_addhdr( "{ 0x7f, 0xc0, 0, 0 } };\n\n" ); } else { pp_addhdr( "{ 0, 0, 0xc0, 0x7f } };\n\n" ); } pp_addhdr( "float _nan_float;\ndouble _nan_double;\n\n" ); pp_add_boot( " _nan_float = __pdl_nan.__d;\n _nan_double = (double) __pdl_nan.__d;\n" ); } # if: $usenan ## Header pp_addpm({At=>'Top'},<<'!NO!SUBS!'); =head1 NAME PDL::Bad - PDL does process bad values =head1 DESCRIPTION PDL has been compiled with WITH_BADVAL set to 1. Therefore, you can enter the wonderful world of bad value support in PDL. This module is loaded when you do C, C or C. Implementation details are given in L. =head1 SYNOPSIS use PDL::Bad; print "\nBad value support in PDL is turned " . $PDL::Bad::Status ? "on" : "off" . ".\n"; Bad value support in PDL is turned on. and some other things =head1 VARIABLES There are currently three variables that this module defines which may be of use. =over 4 =item $PDL::Bad::Status Set to 1 =item $PDL::Bad::UseNaN Set to 1 if PDL was compiled with C set, 0 otherwise. =item $PDL::Bad::PerPdl Set to 1 if PDL was compiled with the I C option set, 0 otherwise. =back =cut !NO!SUBS! pp_addpm(<<"!WITH!SUBS!"); # really should be constants \$PDL::Bad::Status = 1; \$PDL::Bad::UseNaN = $usenan; \$PDL::Bad::PerPdl = $bvalPerPdl; use strict; use PDL::Types; use PDL::Primitive; ############################################################ ############################################################ !WITH!SUBS! # we want the following to be in PDL, not PDL::Bad, hence my $xshdr = "MODULE = PDL::Bad PACKAGE = PDL"; # # we want badflag() to avoid unnecessary calls to PDL->propagate_badflag(), # since it has to recurse through all the children of a piddle # pp_addxs( <<"!WITH!SUBS!"); $xshdr int badflag(x,newval=0) pdl *x int newval CODE: if (items>1) { int oldval = ((x->state & PDL_BADVAL) > 0); if ( !newval && oldval ) { /* asked to unset, present value is set */ x->state &= ~PDL_BADVAL; PDL->propagate_badflag( x, 0 ); } else if ( newval && !oldval ) { /* asked to set, present value is unset */ x->state |= PDL_BADVAL; PDL->propagate_badflag( x, 1 ); } } RETVAL = ((x->state & PDL_BADVAL) > 0); OUTPUT: RETVAL !WITH!SUBS! pp_addpm(<<'!NO!SUBS!'); ############################################################ ############################################################ *badflag = \&PDL::badflag; *badvalue = \&PDL::badvalue; *orig_badvalue = \&PDL::orig_badvalue; ############################################################ ############################################################ =head2 badflag =for ref getter/setter for the bad data flag =for example if ( $a->badflag() ) { print "Data may contain bad values.\n"; } $a->badflag(1); # set bad data flag $a->badflag(0); # unset bad data flag When called as a setter, this modifies the piddle on which it is called. This always returns a Perl scalar with the final value of the bad flag. A return value of 1 does not guarantee the presence of bad data in a piddle; all it does is say that we need to I for the presence of such beasties. To actually find out if there are any bad values present in a piddle, use the L method. =for bad This function works with piddles that have bad values. It always returns a Perl scalar, so it never returns bad values. =head2 badvalue =for ref returns the value used to indicate a missing (or bad) element for the given piddle type. You can give it a piddle, a PDL::Type object, or one of C<$PDL_B>, C<$PDL_S>, etc. =for example $badval = badvalue( float ); $a = ones(ushort,10); print "The bad data value for ushort is: ", $a->badvalue(), "\n"; This can act as a setter (e.g. C<< $a->badvalue(23) >>) if the data type is an integer or C<$PDL::Bad::UseNaN == 0>. Note that this B. That is, if C<$a> already has bad values, they will not be changed to use the given number and if any elements of C<$a> have that value, they will unceremoniously be marked as bad data. See L, L, and L for ways to actually modify the data in piddles If the C<$PDL::Bad::PerPdl> flag is set then it is possible to change the bad value on a per-piddle basis, so $a = sequence (10); $a->badvalue (3); $a->badflag (1); $b = sequence (10); $b->badvalue (4); $b->badflag (1); will set $a to be C<[0 1 2 BAD 4 5 6 7 8 9]> and $b to be C<[0 1 2 3 BAD 5 6 7 8 9]>. If the flag is not set then both $a and $b will be set to C<[0 1 2 3 BAD 5 6 7 8 9]>. Please note that the code to support per-piddle bad values is I in the current release, and it requires that you modify the settings under which PDL is compiled. =for bad This method does not care if you call it on an input piddle that has bad values. It always returns a Perl scalar with the current or new bad value. =head2 orig_badvalue =for ref returns the original value used to represent bad values for a given type. This routine operates the same as L, except you can not change the values. It also has an I name. =for example $orig_badval = orig_badvalue( float ); $a = ones(ushort,10); print "The original bad data value for ushort is: ", $a->orig_badvalue(), "\n"; =for bad This method does not care if you call it on an input piddle that has bad values. It always returns a Perl scalar with the original bad value for the associated type. =head2 check_badflag =for ref Clear the bad-value flag of a piddle if it does not contain any bad values Given a piddle whose bad flag is set, check whether it actually contains any bad values and, if not, clear the flag. It returns the final state of the bad-value flag. =for example print "State of bad flag == ", $pdl->check_badflag; =for bad This method accepts piddles with or without bad values. It returns a Perl scalar with the final bad-value flag, so it never returns bad values itself. =cut *check_badflag = \&PDL::check_badflag; sub PDL::check_badflag { my $pdl = shift; $pdl->badflag(0) if $pdl->badflag and $pdl->nbad == 0; return $pdl->badflag; } # sub: check_badflag() !NO!SUBS! pp_addhdr <<'EOHDR'; static pdl* new_pdlscalar(int datatype) { pdl *p = PDL->pdlnew(); PDL->setdims (p, NULL, 0); /* set dims */ p->datatype = datatype; /* and data type */ PDL->allocdata (p); /* allocate the data chunk */ return p; } EOHDR use PDL::Types; my $ntypes = $#PDL::Types::names; my $str; foreach my $i ( 0 .. $ntypes ) { my $type = PDL::Type->new( $i ); my $ctype = $type->ctype; my $realctype = $type->realctype; my $typesym = $type->symbol; my $cname = $type->ctype; $cname =~ s/^PDL_//; my $storage = "PDL->bvals.$cname"; my $init_code = << "EOC"; pdl* p; $ctype *data; p = new_pdlscalar($typesym); data = ($ctype *) p->data; EOC my $set_code = "if ( val.type != -1 ) { ANYVAL_TO_CTYPE($storage, $ctype, val); }"; # if UseNaN is true, then we can not change the value used to # represent bad elements since it's a NaN. At least, not for # for floating point types # - is there a better way of checking for the condition since # the current one needs to be changed whenever the types are changed # $set_code = "" if $usenan and ($type->ppsym eq "F" or $type->ppsym eq "D"); $str .= " pdl * _badvalue_int${i}(val) PDL_Anyval val CODE: { $init_code $set_code *data = ($ctype) $storage; RETVAL = p; } OUTPUT: RETVAL pdl * _badvalue_per_pdl_int${i}(pdl_val, val) pdl* pdl_val PDL_Anyval val CODE: { $init_code if ( val.type != -1) { pdl_val->badvalue = val; pdl_val->has_badvalue = 1; PDL->propagate_badvalue( pdl_val ); } if (pdl_val->has_badvalue == 0) { *data = ($ctype) $storage; } else { ANYVAL_TO_CTYPE(*data, $ctype, pdl_val->badvalue); } RETVAL = p; } OUTPUT: RETVAL pdl * _default_badvalue_int${i}() CODE: $init_code *data = ($ctype) PDL->bvals.default_$cname; RETVAL = p; OUTPUT: RETVAL "; } # foreach: $i = 0 .. $ntypes pp_addxs( "\n$xshdr\n\n$str\n" ); pp_addpm(<<'!NO!SUBS!'); # note: # if sent a piddle, we have to change it's bad values # (but only if it contains bad values) # - there's a slight overhead in that the badflag is # cleared and then set (hence propagating to all # children) but we'll ignore that) # - we can ignore this for float/double types # since we can't change the bad value # sub PDL::badvalue { no strict 'refs'; my ( $self, $val ) = @_; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; if ( $num < $PDL_F && defined($val) && $self->badflag ) { $self->inplace->setbadtoval( $val ); $self->badflag(1); } if ($PDL::Config{BADVAL_PER_PDL}) { my $name = "PDL::_badvalue_per_pdl_int$num"; if ( defined $val ) { return &{$name}($self, $val )->sclr; } else { return &{$name}($self, undef)->sclr; } } } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } my $name = "PDL::_badvalue_int$num"; if ( defined $val ) { return &{$name}( $val )->sclr; } else { return &{$name}( undef )->sclr; } } # sub: badvalue() sub PDL::orig_badvalue { no strict 'refs'; my $self = shift; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } my $name = "PDL::_default_badvalue_int$num"; return &${name}(); } # sub: orig_badvalue() ############################################################ ############################################################ !NO!SUBS! pp_def('isbad' . <<'=cut', =head2 isbad =for sig Signature: (a(); int [o]b()) =for ref Returns a binary mask indicating which values of the input are bad values Returns a 1 if the value is bad, 0 otherwise. Similar to L. =for example $a = pdl(1,2,3); $a->badflag(1); set($a,1,$a->badvalue); $b = isbad($a); print $b, "\n"; [0 1 0] =for bad This method works with input piddles that are bad. The output piddle will never contain bad values, but its bad value flag will be the same as the input piddle's flag. =cut HandleBad => 1, Code => '$b() = 0;', BadCode => '$b() = $ISBAD(a());', CopyBadStatusCode => '', ); pp_def('isgood' . <<'=cut', =head2 isgood =for sig Signature: (a(); int [o]b()) =for ref Is a value good? Returns a 1 if the value is good, 0 otherwise. Also see L. =for example $a = pdl(1,2,3); $a->badflag(1); set($a,1,$a->badvalue); $b = isgood($a); print $b, "\n"; [1 0 1] =for bad This method works with input piddles that are bad. The output piddle will never contain bad values, but its bad value flag will be the same as the input piddle's flag. =cut HandleBad => 1, Code => '$b() = 1;', BadCode => '$b() = $ISGOOD(a());', CopyBadStatusCode => '', ); # perhaps these should have pm code which returns the # answer if the bad flag is not set pp_def('nbadover' . <<'=cut', =head2 nbadover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of bad elements along the 1st dimension. This function reduces the dimensionality of a piddle by one by finding the number of bad elements along the 1st dimension. In this sense it shares much in common with the functions defined in L. In particular, by using L and similar dimension rearranging methods, it is possible to perform this calculation over I dimension. =for usage $a = nbadover($b); =for example $spectrum = nbadover $image->xchg(0,1) =for bad nbadover processes input values that are bad. The output piddle will not have any bad values, but the bad flag will be set if the input piddle had its bad flag set. =cut HandleBad => 1, Code => '$b() = 0;', BadCode => q{ PDL_Indx cnt = 0; loop(n) %{ if ( $ISBAD(a()) ) { cnt++; } %} $b() = cnt; }, ); pp_def('ngoodover' . <<'=cut', =head2 ngoodover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of good elements along the 1st dimension. This function reduces the dimensionality of a piddle by one by finding the number of good elements along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $a = ngoodover($b); =for example $spectrum = ngoodover $image->xchg(0,1) =for bad ngoodover processes input values that are bad. The output piddle will not have any bad values, but the bad flag will be set if the input piddle had its bad flag set. =cut HandleBad => 1, Code => '$b() = (PDL_Indx) $SIZE(n);', BadCode => 'PDL_Indx cnt = 0; loop(n) %{ if ( $ISGOOD(a()) ) { cnt++; } %} $b() = cnt;', ); # Generate small ops functions to do entire array foreach my $op ( ['nbad','nbadover'], ['ngood','ngoodover'], ) { pp_addpm(<<"EOD"); *$op->[0] = \\&PDL::$op->[0]; sub PDL::$op->[0] { my(\$x) = \@_; my \$tmp; \$x->clump(-1)->$op->[1](\$tmp=PDL->nullcreate(\$x) ); return \$tmp->at(); } EOD } # for $op pp_addpm(<<'!NO!SUBS!'); =head2 nbad =for ref Returns the number of bad values in a piddle =for usage $x = nbad($data); =for bad Accepts good and bad input piddles; output is a Perl scalar and therefore is always good. =head2 ngood =for ref Returns the number of good values in a piddle =for usage $x = ngood($data); =for bad Accepts good and bad input piddles; output is a Perl scalar and therefore is always good. =head2 setbadat =for ref Set the value to bad at a given position. =for usage setbadat $piddle, @position C<@position> is a coordinate list, of size equal to the number of dimensions in the piddle. This is a wrapper around L and is probably mainly useful in test scripts! =for example pdl> $x = sequence 3,4 pdl> $x->setbadat 2,1 pdl> p $x [ [ 0 1 2] [ 3 4 BAD] [ 6 7 8] [ 9 10 11] ] =for bad This method can be called on piddles that have bad values. The remainder of the arguments should be Perl scalars indicating the position to set as bad. The output piddle will have bad values and will have its badflag turned on. =cut *setbadat = \&PDL::setbadat; sub PDL::setbadat { barf 'Usage: setbadat($pdl, $x, $y, ...)' if $#_<1; my $self = shift; PDL::Core::set_c ($self, [@_], $self->badvalue); $self->badflag(1); return $self; } !NO!SUBS! # NOTE: the Code section uses SETBAD # # have removed inplace stuff because: # $a->inplace->setbadif( $a % 2 ) # actually sets the badflag in a for ($a % 2) - this is # done inplace, and the flag cleared. Hence the setbadif() # call is NOT done inplace. # # Don't want to play around with inplace-type code to # try and fix this (doubt will be easy) # my %setbadif_extra = ( ); if ( 0 ) { ## ie if fix inplace issues $setbadif_extra{Inplace} = [ 'a' ]; $setbadif_extra{CopyBadStatusCode} = 'if ( a == b && $ISPDLSTATEGOOD(a) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ $SETPDLSTATEBAD(b); /* always make sure the output is "bad" */ '; } else { # always make sure the output is "bad" $setbadif_extra{CopyBadStatusCode} = '$SETPDLSTATEBAD(b);'; } # note: have made the mask be an integer pp_def('setbadif' . <<'=cut', =head2 setbadif =for sig Signature: (a(); int mask(); [o]b()) =for ref Set elements bad based on the supplied mask, otherwise copy across the data. =for example pdl> $a = sequence(5,5) pdl> $a = $a->setbadif( $a % 2 ) pdl> p "a badflag: ", $a->badflag, "\n" a badflag: 1 pdl> p "a is\n$a" [ [ 0 BAD 2 BAD 4] [BAD 6 BAD 8 BAD] [ 10 BAD 12 BAD 14] [BAD 16 BAD 18 BAD] [ 20 BAD 22 BAD 24] ] Unfortunately, this routine can I be run inplace, since the current implementation can not handle the same piddle used as C and C (eg C<< $a->inplace->setbadif($a%2) >> fails). Even more unfortunate: we can't catch this error and tell you. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). The input piddle can have bad values: any bad values in the input piddles are copied across to the output piddle. Also see L and L. =cut HandleBad => 1, %setbadif_extra, Code => 'if ( $mask() ) { $SETBAD(b()); } else { $b() = $a(); }', BadCode => '/* if the bad value == 0 then all points are going to be selected ... */ if ( $ISBAD(mask()) || $mask() ) { $SETBAD(b()); } else { $b() = $a(); }', ); # pp_def: setbadif # this is useful because $a->setbadif( $a == 23 ) # is common and that can't be done inplace # # this doesn't need a BadCode section if ($^O =~ /MSWin/) { pp_addhdr(' #if defined _MSC_VER && _MSC_VER < 1400 #pragma optimize("", off) #endif '); } pp_def('setvaltobad' . <<'=cut', =head2 setvaltobad =for sig Signature: (a(); [o]b(); double value) =for ref Set bad all those elements which equal the supplied value. =for example $a = sequence(10) % 3; $a->inplace->setvaltobad( 0 ); print "$a\n"; [BAD 1 2 BAD 1 2 BAD 1 2 BAD] This is a simpler version of L, but this function can be done inplace. See L if you want to convert NaN/Inf to the bad value. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). Any bad values in the input piddles are copied across to the output piddle. =cut HandleBad => 1, Inplace => 1, CopyBadStatusCode => q{ if ( a == b && $ISPDLSTATEGOOD(a) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ $SETPDLSTATEBAD(b); /* always make sure the output is "bad" */ }, Code => q[ #if defined _MSC_VER && _MSC_VER < 1400 $GENERIC(a) dummy1 = ($GENERIC(a)) $COMP(value); if ( $a() == dummy1 ) { #else if ( $a() == ($GENERIC(a)) $COMP(value) ) { #endif $SETBAD(b()); } else { $b() = $a(); } ], ); # pp_def: setvaltobad if ($^O =~ /MSWin/) { pp_addhdr(' #if defined _MSC_VER && _MSC_VER < 1400 #pragma optimize("", on) #endif '); } =head2 setnantobad, setbadtonan when using NaN for bad The behavior of these functions depend on whether C is set to a true value. For PDL as currently distributed, this is typically not the case. That documentation is show first: =cut # setnantobad \ are straight copies if $PDL::Bad::UseNaN == 1 # setbadtonan / # if ( $usenan ) { pp_add_exported( '', 'setnantobad setbadtonan' ); my $stuff_to_add_to_the_pm = <<'!NO!SUBS!'; =head2 setnantobad =for ref Sets NaN/Inf values in the input piddle bad (only relevant for floating-point piddles). Can be done inplace. As C<$PDL::Bad::UseNan == 1>, this is just a copy with a call to L thrown in. =for usage $b = $a->setnantobad; $a->inplace->setnantobad; =for bad Supports bad values. =cut *setnantobad = \&PDL::setnantobad; sub PDL::setnantobad{ my $a = shift; my $b; if ( $a->is_inplace ) { $a->set_inplace(0); $b = $a; } elsif ( $#_ > -1 ) { $b = $_[0] = $a->copy; # is this correct? } else { $b = $a->copy; } # make sure bad flag is set, otherwise check_badflag() is a nop $b->badflag(1); $b->check_badflag(); return $b; } =head2 setbadtonan =for ref Sets Bad values to NaN (only relevant for floating-point piddles). Can be done inplace. As C<$PDL::Bad::UseNan == 1>, this is just a copy, with the bad flag being cleared. =for usage $b = $a->setbadtonan; $a->inplace->setbadtonan; =for bad Supports bad values. =cut *setbadtonan = \&PDL::setbadtonan; sub PDL::setbadtonan{ my $a = shift; my $b; if ( $a->is_inplace ) { $a->set_inplace(0); $b = $a; } elsif ( $#_ > -1 ) { $b = $_[0] = $a->copy; # is this correct? } else { $b = $a->copy; } $b->badflag(0); return $b; } !NO!SUBS! # Replace the head3 directives with head2, since that's what # they should be in their final result. $stuff_to_add_to_the_pm =~ s/head3/head2/g; pp_addpm($stuff_to_add_to_the_pm); } else { =pod On the other hand, if usenan is not true, then any number can be used to designate a bad value, and this must be handled with greater care. This is the usual case, and the documentation in that case is this: =cut # usenan is not true, so we need to do something pp_def('setnantobad' . <<'=cut', =head2 setnantobad =for sig Signature: (a(); [o]b()) =for ref Sets NaN/Inf values in the input piddle bad (only relevant for floating-point piddles). Can be done inplace. =for usage $b = $a->setnantobad; $a->inplace->setnantobad; =for bad This method can process piddles with bad values: those bad values are propagated into the output piddle. Any value that is not finite is also set to bad in the output piddle. If all values from the input piddle are good and finite, the output piddle will B have its bad flag set. One more caveat: if done inplace, and if the input piddle's bad flag is set, it will no =cut HandleBad => 1, GenericTypes => [ 'F', 'D' ], Inplace => 1, CopyBadStatusCode => q{ /* note: not quite the normal check since set b bad within Code */ /* we propagate the bad flag even if a was originally bad since */ /* there is no easy way to pass this information around */ if ( a == b && $ISPDLSTATEBAD(b) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ }, Code => q{ int flag = 0; threadloop %{ if ( ! finite($a()) ) { $SETBAD(b()); flag = 1; } else { $b() = $a(); } %} if ( flag ) $PDLSTATESETBAD(b); }, ); # pp_def: setnantobad pp_def('setbadtonan' . <<'=cut', =head2 setbadtonan =for sig Signature: (a(); [o] b();) =for ref Sets Bad values to NaN This is only relevant for floating-point piddles. The input piddle can be of any type, but if done inplace, the input must be floating point. =for usage $b = $a->setbadtonan; $a->inplace->setbadtonan; =for bad This method processes input piddles with bad values. The output piddles will not contain bad values (insofar as NaN is not Bad as far as PDL is concerned) and the output piddle does not have its bad flag set. As an inplace operation, it clears the bad flag. =cut HandleBad => 1, GenericTypes => [ 'F', 'D' ], Inplace => 1, CopyBadStatusCode => q{ /* propagate cleared badflag if inplace */ if ( a == b ) PDL->propagate_badflag( b, 0 ); /* always make sure the output is "good" */ $SETPDLSTATEGOOD(b); }, Code => q{ if ( $ISBAD(a()) ) { /* _nan_xxx set up at top of file */ $b() = $TFD(_nan_float,_nan_double); } else { $b() = $a(); } }, ); # pp_def: setbadtonan } # if: $usenan # renamed replacebad by setbadtoval pp_def('setbadtoval' . <<'=cut', =head2 setbadtoval =for sig Signature: (a(); [o]b(); double newval) =for ref Replace any bad values by a (non-bad) value. Can be done inplace. Also see L. =for example $a->inplace->setbadtoval(23); print "a badflag: ", $a->badflag, "\n"; a badflag: 0 =for bad The output always has its bad flag cleared. If the input piddle does not have its bad flag set, then values are copied with no replacement. =cut HandleBad => 1, Inplace => 1, Code => '$b() = $a();', BadCode => q{ $GENERIC(b) replace = ($GENERIC(b)) $COMP(newval); $GENERIC(b) a_val; threadloop %{ a_val = $a(); if ( $ISBADVAR(a_val,a) ) { $b() = replace; } else { $b() = a_val; } %} }, CopyBadStatusCode => q{ /* propagate badflag if inplace AND its changed */ if ( a == b && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( b, 0 ); /* always make sure the output is "good" */ $SETPDLSTATEGOOD(b); }, ); # pp_def: setbadtoval pp_def('copybad'.<<'=cut', =head2 copybad =for sig Signature: (a(); mask(); [o]b()) =for ref Copies values from one piddle to another, setting them bad if they are bad in the supplied mask. Can be done inplace. =for example $a = byte( [0,1,3] ); $mask = byte( [0,0,0] ); set($mask,1,$mask->badvalue); $a->inplace->copybad( $mask ); p $a; [0 BAD 3] It is equivalent to: $c = $a + $mask * 0 =for bad This handles input piddles that are bad. If either C<$a> or C<$mask> have bad values, those values will be marked as bad in the output piddle and the output piddle will have its bad value flag set to true. =cut HandleBad => 1, Inplace => [ 'a' ], Code => '$b() = $a();', BadCode => q{ if ( $ISBAD(mask()) ) { $SETBAD(b()); } else { $b() = $a(); } }, CopyBadStatusCode => q{ if ( $BADFLAGCACHE() ) { if ( a == b && $ISPDLSTATEGOOD(a) ) { /* have inplace op AND badflag has changed */ PDL->propagate_badflag( b, 1 ); } $SETPDLSTATEBAD(b); } }, ); # pp_def: copybad ######################################################### pp_addpm({At=>'Bot'},<<'!WITHOUT!SUBS!'); =head1 CHANGES The I C configuration option, which - when set - allows per-piddle bad values, was added after the 2.4.2 release of PDL. The C<$PDL::Bad::PerPdl> variable can be inspected to see if this feature is available. =head1 CONFIGURATION The way the PDL handles the various bad value settings depends on your compile-time configuration settings, as held in C. =over =item C<$PDL::Config{WITH_BADVAL}> Set this configuration option to a true value if you want bad value support. The default setting is for this to be true. =item C<$PDL::Config{BADVAL_USENAN}> Set this configuration option to a true value if you want floating-pont numbers to use NaN to represent the bad value. If set to false, you can use any number to represent a bad value, which is generally more flexible. In the default configuration, this is set to a false value. =item C<$PDL::Config{BADVAL_PER_PDL}> Set this configuration option to a true value if you want each of your piddles to keep track of their own bad values. This means that for one piddle you can set the bad value to zero, while in another piddle you can set the bad value to NaN (or any other useful number). This is usually set to false. =back =head1 AUTHOR Doug Burke (djburke@cpan.org), 2000, 2001, 2003, 2006. The per-piddle bad value support is by Heiko Klein (2006). CPAN documentation fixes by David Mertens (2010, 2013). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut !WITHOUT!SUBS! ## End pp_done(); PDL-2.018/Basic/Bad/Makefile.PL0000644060175006010010000000174312562522363014070 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; # we create a Bad.pm whatever the value of # PDL_CONFIG - it's just the contents that will be # different... my $bvalflag = $PDL::Config{WITH_BADVAL}; my $usenan = $PDL::Config{BADVAL_USENAN}; my $bvalPerPdl = $PDL::Config{BADVAL_PER_PDL}; # print a banner to the screen if ( $bvalflag ) { print "Congratulations - building PDL with bad value support (WITH_BADVAL=1)\n\t"; if ( $usenan ) { print "+ using NaN for floating-point bad value"; } else { print "+ using -FLT_MAX/-DBL_MAX for floating-point bad values"; } print "+ with per-piddle bad values (EXPERIMENTAL FEATURE)" if $bvalPerPdl; } else { print "building PDL without bad value support (WITH_BADVAL!=1)"; } print "\n"; my @pack = (["bad.pd",qw(Bad PDL::Bad)]); my %hash = pdlpp_stdargs_int(@pack); #$hash{LIBS} = ['-lm']; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Basic/Complex/0000755060175006010010000000000013110402045013012 5ustar chmNonePDL-2.018/Basic/Complex/complex.pd0000644060175006010010000010573513036512174015035 0ustar chmNone$VERSION = 0.7; # pp_setversion $VERSION; # haven't worked out why it breaks my system (CS) pp_beginwrap; # required for overload to work # pp_def functions go into the PDL::Complex namespace # to avoid clashing with PDL::FFTW funcs of the same name that go # into the PDL namespace # it should be of no effect to the user of the module but you # never know.... pp_bless('PDL::Complex'); pp_addpm {At => Top}, <<'EOD'; our $VERSION = '2.009'; use PDL::Slices; use PDL::Types; use PDL::Bad; use vars qw($sep $sep2); EOD pp_addpm {At => Top}, <<'EOD'; =encoding iso-8859-1 =head1 NAME PDL::Complex - handle complex numbers =head1 SYNOPSIS use PDL; use PDL::Complex; =head1 DESCRIPTION This module features a growing number of functions manipulating complex numbers. These are usually represented as a pair C<[ real imag ]> or C<[ angle phase ]>. If not explicitly mentioned, the functions can work inplace (not yet implemented!!!) and require rectangular form. While there is a procedural interface available (C<< $a/$b*$c <=> Cmul (Cdiv $a, $b), $c) >>), you can also opt to cast your pdl's into the C datatype, which works just like your normal piddles, but with all the normal perl operators overloaded. The latter means that C will be evaluated using the normal rules of complex numbers, while other pdl functions (like C) just treat the piddle as a real-valued piddle with a lowest dimension of size 2, so C will return the maximum of all real and imaginary parts, not the "highest" (for some definition) =head1 TIPS, TRICKS & CAVEATS =over 4 =item * C is a constant exported by this module, which represents C<-1**0.5>, i.e. the imaginary unit. it can be used to quickly and conveniently write complex constants like this: C<4+3*i>. =item * Use C to convert from real to complex, as in C<$r = Cpow $cplx, r2C 2>. The overloaded operators automatically do that for you, all the other functions, do not. So C will return all the fifths roots of 1+1*i (due to threading). =item * use C to cast from normal piddles into the complex datatype. Use C to cast back. This requires a copy, though. =item * This module has received some testing by Vanuxem Grégory (g.vanuxem at wanadoo dot fr). Please report any other errors you come across! =back =head1 EXAMPLE WALK-THROUGH The complex constant five is equal to C: pdl> p $x = r2C 5 5 +0i Now calculate the three cubic roots of of five: pdl> p $r = Croots $x, 3 [1.70998 +0i -0.854988 +1.48088i -0.854988 -1.48088i] Check that these really are the roots: pdl> p $r ** 3 [5 +0i 5 -1.22465e-15i 5 -7.65714e-15i] Duh! Could be better. Now try by multiplying C<$r> three times with itself: pdl> p $r*$r*$r [5 +0i 5 -4.72647e-15i 5 -7.53694e-15i] Well... maybe C (which is used by the C<**> operator) isn't as bad as I thought. Now multiply by C and negate, which is just a very expensive way of swapping real and imaginary parts. pdl> p -($r*i) [0 -1.70998i 1.48088 +0.854988i -1.48088 +0.854988i] Now plot the magnitude of (part of) the complex sine. First generate the coefficients: pdl> $sin = i * zeroes(50)->xlinvals(2,4) + zeroes(50)->xlinvals(0,7) Now plot the imaginary part, the real part and the magnitude of the sine into the same diagram: pdl> use PDL::Graphics::Gnuplot pdl> gplot( with => 'lines', PDL::cat(im ( sin $sin ), re ( sin $sin ), abs( sin $sin ) )) An ASCII version of this plot looks like this: 30 ++-----+------+------+------+------+------+------+------+------+-----++ + + + + + + + + + + + | $$| | $ | 25 ++ $$ ++ | *** | | ** *** | | $$* *| 20 ++ $** ++ | $$$* #| | $$$ * # | | $$ * # | 15 ++ $$$ * # ++ | $$$ ** # | | $$$$ * # | | $$$$ * # | 10 ++ $$$$$ * # ++ | $$$$$ * # | | $$$$$$$ * # | 5 ++ $$$############ * # ++ |*****$$$### ### * # | * #***** # * # | | ### *** ### ** # | 0 ## *** # * # ++ | * # * # | | *** # ** # | | * # * # | -5 ++ ** # * # ++ | *** ## ** # | | * #* # | | **** ***## # | -10 ++ **** # # ++ | # # | | ## ## | + + + + + + + ### + ### + + + -15 ++-----+------+------+------+------+------+-----###-----+------+-----++ 0 5 10 15 20 25 30 35 40 45 50 =cut my $i; BEGIN { $i = bless pdl 0,1 } sub i () { $i->copy }; EOD for (qw(Ctan Catan re im i cplx real)) { pp_add_exported '', $_; } pp_addhdr <<'EOH'; #include #ifndef M_PI # define M_PI 3.1415926535897932384626433832795029 #endif #ifndef M_2PI # define M_2PI (2. * M_PI) #endif #if __GLIBC__ > 1 && (defined __USE_MISC || defined __USE_XOPEN || defined __USE_ISOC9X) # define CABS(r,i) hypot (r, i) #else static double CABS (double r, double i) { double t; if (r < 0) r = - r; if (i < 0) i = - i; if (i > r) { t = r; r = i; i = t; } if (r + i == r) return r; t = i / r; return r * sqrt (1 + t*t); } #endif #if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 1 && defined __USE_GNU # define SINCOS(x,s,c) sincos ((x), &(s), &(c)) #else # define SINCOS(x,s,c) \ (s) = sin (x); \ (c) = cos (x); #endif #define CSQRT(type,ar,ai,cr,ci) \ type mag = CABS ((ar), (ai)); \ type t; \ \ if (mag == 0) \ (cr) = (ci) = 0; \ else if ((ar) > 0) \ { \ t = sqrt (0.5 * (mag + (ar))); \ (cr) = t; \ (ci) = 0.5 * (ai) / t; \ } \ else \ { \ t = sqrt (0.5 * (mag - (ar))); \ \ if ((ai) < 0) \ t = -t; \ \ (cr) = 0.5 * (ai) / t; \ (ci) = t; \ } #define CLOG(ar,ai,cr,ci) \ (cr) = log (CABS ((ar), (ai))); \ (ci) = atan2 ((ai), (ar)); EOH pp_addpm <<'EOP'; =head2 cplx real-valued-pdl Cast a real-valued piddle to the complex datatype. The first dimension of the piddle must be of size 2. After this the usual (complex) arithmetic operators are applied to this pdl, rather than the normal elementwise pdl operators. Dataflow to the complex parent works. Use C on the result if you don't want this. =head2 complex real-valued-pdl Cast a real-valued piddle to the complex datatype I dataflow and I. Achieved by merely reblessing a piddle. The first dimension of the piddle must be of size 2. =head2 real cplx-valued-pdl Cast a complex valued pdl back to the "normal" pdl datatype. Afterwards the normal elementwise pdl operators are used in operations. Dataflow to the real parent works. Use C on the result if you don't want this. =cut use Carp; sub cplx($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP if just piddle croak "first dimsize must be 2" unless $_[0]->dims > 0 && $_[0]->dim(0) == 2; bless $_[0]->slice(''); } sub complex($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP if just piddle croak "first dimsize must be 2" unless $_[0]->dims > 0 && $_[0]->dim(0) == 2; bless $_[0]; } *PDL::cplx = \&cplx; *PDL::complex = \&complex; sub real($) { return $_[0] unless UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP unless complex bless $_[0]->slice(''), 'PDL'; } EOP pp_def 'r2C', Pars => 'r(); [o]c(m=2)', Doc => 'convert real to complex, assuming an imaginary part of zero', PMCode => << 'EOPM', *PDL::r2C = \&PDL::Complex::r2C; sub PDL::Complex::r2C($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); my $r = __PACKAGE__->initialize; &PDL::Complex::_r2C_int($_[0], $r); $r } EOPM Code => q! $c(m=>0) = $r(); $c(m=>1) = 0; ! ; pp_def 'i2C', Pars => 'r(); [o]c(m=2)', Doc => 'convert imaginary to complex, assuming a real part of zero', PMCode => '*PDL::i2C = \&PDL::Complex::i2C; sub PDL::Complex::i2C($) { my $r = __PACKAGE__->initialize; &PDL::Complex::_i2C_int($_[0], $r); $r }', Code => q! $c(m=>0) = 0; $c(m=>1) = $r(); ! ; pp_def 'Cr2p', Pars => 'r(m=2); float+ [o]p(m=2)', Inplace => 1, Doc => 'convert complex numbers in rectangular form to polar (mod,arg) form. Works inplace', Code => q! $GENERIC() x = $r(m=>0); $GENERIC() y = $r(m=>1); $p(m=>0) = CABS (x, y); $p(m=>1) = atan2 (y, x); ! ; pp_def 'Cp2r', Pars => 'r(m=2); [o]p(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'convert complex numbers in polar (mod,arg) form to rectangular form. Works inplace', Code => q! $GENERIC() m = $r(m=>0); $GENERIC() a = $r(m=>1); double s, c; SINCOS (a, s, c); $p(m=>0) = c * m; $p(m=>1) = s * m; ! ; pp_def 'Cadd', # this is here for a) completeness and b) not having to mess with PDL::Ops Pars => 'a(m=2); b(m=2); [o]c(m=2)', Doc => undef, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); $c(m=>0) = ar + br; $c(m=>1) = ai + bi; ^ ; pp_def 'Csub', # this is here for a) completeness and b) not having to mess with PDL::Ops Pars => 'a(m=2); b(m=2); [o]c(m=2)', Doc => undef, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); $c(m=>0) = ar - br; $c(m=>1) = ai - bi; ^ ; pp_def 'Cmul', Pars => 'a(m=2); b(m=2); [o]c(m=2)', Doc => 'complex multiplication', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); $c(m=>0) = ar*br - ai*bi; $c(m=>1) = ar*bi + ai*br; ^ ; pp_def 'Cprodover', Pars => 'a(m=2,n); [o]c(m=2)', Doc => 'Project via product to N-1 dimension', Code => q^ PDL_Long iter; $GENERIC() br, bi, cr, ci,tmp; cr = $a(m=>0,n=>0); ci = $a(m=>1,n=>0); for (iter=1; iter < $SIZE(n);iter++) { br = $a(m=>0,n=>iter); bi = $a(m=>1,n=>iter); tmp = cr*bi + ci*br; cr = cr*br - ci*bi; ci = tmp; } $c(m=>0) = cr; $c(m=>1) = ci; ^ ; pp_def 'Cscale', Pars => 'a(m=2); b(); [o]c(m=2)', Doc => 'mixed complex/real multiplication', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $c(m=>0) = ar * $b(); $c(m=>1) = ai * $b(); ^ ; pp_def 'Cdiv', Pars => 'a(m=2); b(m=2); [o]c(m=2)', GenericTypes => [F,D], Doc => 'complex division', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); if (fabs (br) > fabs (bi)) { $GENERIC() tt = bi / br; $GENERIC() dn = br + tt * bi; $c(m=>0) = (ar + tt * ai) / dn; $c(m=>1) = (ai - tt * ar) / dn; } else { $GENERIC() tt = br / bi; $GENERIC() dn = br * tt + bi; $c(m=>0) = (ar * tt + ai) / dn; $c(m=>1) = (ai * tt - ar) / dn; } ^ ; pp_def 'Ccmp', Pars => 'a(m=2); b(m=2); [o]c()', GenericTypes => [F,D], Doc => 'Complex comparison oeprator (spaceship). It orders by real first, then by imaginary. Hm, but it is mathematical nonsense! Complex numbers cannot be ordered.', Code => q^ $GENERIC() a, b; a = $a(m=>0), b = $b(m=>0); if (a != b) $c() = (a > b) * 2 - 1; else { a = $a(m=>1), b = $b(m=>1); $c() = a == b ? 0 : (a > b) * 2 - 1; } ^ ; pp_def 'Cconj', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, Doc => 'complex conjugation. Works inplace', Code => q^ $c(m=>0) = $a(m=>0); $c(m=>1) = -$a(m=>1); ^ ; pp_def 'Cabs', Pars => 'a(m=2); [o]c()', GenericTypes => [F,D], Doc => 'complex C (also known as I)', PMCode => q^sub PDL::Complex::Cabs($) { my $pdl= shift; my $abs = PDL->null; &PDL::Complex::_Cabs_int($pdl, $abs); $abs; }^, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $c() = CABS (ar, ai); ^ ; pp_def 'Cabs2', Pars => 'a(m=2); [o]c()', Doc => 'complex squared C (also known I)', PMCode => q^sub PDL::Complex::Cabs2($) { my $pdl= shift; my $abs2 = PDL->null; &PDL::Complex::_Cabs2_int($pdl, $abs2); $abs2; }^, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $c() = ar*ar + ai*ai; ^ ; pp_def 'Carg', Pars => 'a(m=2); [o]c()', GenericTypes => [F,D], Doc => 'complex argument function ("angle")', PMCode => q^sub PDL::Complex::Carg($) { my $pdl= shift; my $arg = PDL->null; &PDL::Complex::_Carg_int($pdl, $arg); $arg; }^, Code => q^ $c() = atan2 ($a(m=>1), $a(m=>0)); ^ ; pp_def 'Csin', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => ' sin (a) = 1/(2*i) * (exp (a*i) - exp (-a*i)). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ar, s, c); $c(m=>0) = s * cosh (ai); $c(m=>1) = c * sinh (ai); ^ ; pp_def 'Ccos', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => ' cos (a) = 1/2 * (exp (a*i) + exp (-a*i)). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ar, s, c); $c(m=>0) = c * cosh (ai); $c(m=>1) = - s * sinh (ai); ^ ; pp_addpm <<'EOD'; =head2 Ctan a [not inplace] tan (a) = -i * (exp (a*i) - exp (-a*i)) / (exp (a*i) + exp (-a*i)) =cut sub Ctan($) { Csin($_[0]) / Ccos($_[0]) } EOD pp_def 'Cexp', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'exp (a) = exp (real (a)) * (cos (imag (a)) + i * sin (imag (a))). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() ex = exp (ar); double s, c; SINCOS (ai, s, c); $c(m=>0) = ex * c; $c(m=>1) = ex * s; ^ ; pp_def 'Clog', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'log (a) = log (cabs (a)) + i * carg (a). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); CLOG (ar, ai, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Cpow', Pars => 'a(m=2); b(m=2); [o]c(m=2)', Inplace => ['a'], GenericTypes => [F,D], Doc => 'complex C (C<**>-operator)', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); double logr, logi, x, y; double s, c; if(ar == 0 && ai == 0){ if(br == 0 && bi == 0) { $c(m=>0) = 1; $c(m=>1) = 0; } else { $c(m=>0) = 0; $c(m=>1) = 0; } } else { CLOG (ar, ai, logr, logi); x = exp (logr*br - logi*bi); y = logr*bi + logi*br; SINCOS (y, s, c); $c(m=>0) = x * c; if(ai == 0 && bi == 0) $c(m=>1) = 0; else $c(m=>1) = x * s; } ^ ; pp_def 'Csqrt', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); CSQRT ($GENERIC(), ar, ai, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Casin', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() t1 = sqrt ((ar+1)*(ar+1) + ai*ai); $GENERIC() t2 = sqrt ((ar-1)*(ar-1) + ai*ai); $GENERIC() alpha = (t1+t2)*0.5; $GENERIC() beta = (t1-t2)*0.5; if (alpha < 1) alpha = 1; if (beta > 1) beta = 1; else if (beta < -1) beta = -1; $c(m=>0) = atan2 (beta, sqrt (1-beta*beta)); $c(m=>1) = - log (alpha + sqrt (alpha*alpha-1)); if (ai > 0 || (ai == 0 && ar < -1)) $c(m=>1) = - $c(m=>1); ^ ; pp_def 'Cacos', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() t1 = sqrt ((ar+1)*(ar+1) + ai*ai); $GENERIC() t2 = sqrt ((ar-1)*(ar-1) + ai*ai); $GENERIC() alpha = (t1+t2)*0.5; $GENERIC() beta = (t1-t2)*0.5; if (alpha < 1) alpha = 1; if (beta > 1) beta = 1; else if (beta < -1) beta = -1; $c(m=>0) = atan2 (sqrt (1-beta*beta), beta); $c(m=>1) = log (alpha + sqrt (alpha*alpha-1)); if (ai > 0 || (ai == 0 && ar < -1)) $c(m=>1) = - $c(m=>1); ^ ; pp_addpm <<'EOD'; =head2 Catan cplx [not inplace] Return the complex C. =cut sub Catan($) { my $z = shift; Cmul Clog(Cdiv (PDL::Complex::i+$z, PDL::Complex::i-$z)), pdl(0, 0.5); } EOD pp_def 'Csinh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => ' sinh (a) = (exp (a) - exp (-a)) / 2. Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ai, s, c); $c(m=>0) = sinh (ar) * c; $c(m=>1) = cosh (ar) * s; ^ ; pp_def 'Ccosh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => ' cosh (a) = (exp (a) + exp (-a)) / 2. Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ai, s, c); $c(m=>0) = cosh (ar) * c; $c(m=>1) = sinh (ar) * s; ^ ; pp_def 'Ctanh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double den; double s, c; SINCOS (2*ai, s, c); den = cosh (2*ar) + c; $c(m=>0) = sinh (2*ar) / den; $c(m=>1) = s / den; ^ ; pp_def 'Casinh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() yr = (ar-ai) * (ar+ai) + 1; $GENERIC() yi = 2*ar*ai; CSQRT ($GENERIC(), yr, yi, yr, yi) yr += ar; yi += ai; CLOG (yr, yi, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Cacosh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() yr = (ar-ai) * (ar+ai) - 1; $GENERIC() yi = 2*ar*ai; CSQRT ($GENERIC(), yr, yi, yr, yi) yr += ar; yi += ai; CLOG (yr, yi, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Catanh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double i2 = ai*ai; double num = i2 + (1+ar) * (1+ar); double den = i2 + (1-ar) * (1-ar); $c(m=>0) = 0.25 * (log(num) - log(den)); $c(m=>1) = 0.5 * atan2 (2*ai, 1 - ar*ar - i2); ^ ; pp_def 'Cproj', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => [F,D], Doc => 'compute the projection of a complex number to the riemann sphere. Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double den = ar*ar + ai*ai + 1; $c(m=>0) = 2*ar / den; $c(m=>1) = 2*ai / den; ^ ; pp_def 'Croots', Pars => 'a(m=2); [o]c(m=2,n)', OtherPars => 'int n => n', GenericTypes => [F,D], Doc => 'Compute the C roots of C. C must be a positive integer. The result will always be a complex type!', PMCode => q^sub PDL::Complex::Croots($$) { my ($pdl, $n) = @_; my $r = PDL->null; &PDL::Complex::_Croots_int($pdl, $r, $n); bless $r; }^, Code => q^ double s, c; double ar = $a(m=>0), ai = $a(m=>1), n1 = 1 / (double)$COMP(n), rr = pow (CABS (ar, ai), n1), /* do not optimize the sqrt out of this expr! */ at = atan2 (ai, ar) * n1, ti = M_2PI * n1; loop(n) %{ SINCOS (at, s, c); $c(m=>0) = rr * c; $c(m=>1) = rr * s; at += ti; %} ^ ; pp_addpm <<'EOD'; =head2 re cplx, im cplx Return the real or imaginary part of the complex number(s) given. These are slicing operators, so data flow works. The real and imaginary parts are returned as piddles (ref eq PDL). =cut sub re($) { bless $_[0]->slice("(0)"), 'PDL'; } sub im($) { bless $_[0]->slice("(1)"), 'PDL'; } *PDL::Complex::re = \&re; *PDL::Complex::im = \&im; EOD pp_def 'rCpolynomial', Pars => 'coeffs(n); x(c=2,m); [o]out(c=2,m)', Doc => 'evaluate the polynomial with (real) coefficients C at the (complex) position(s) C. C is the constant term.', GenericTypes => [F,D], Code => q! loop(m) %{ double xr = 1; double xi = 0; double or = 0; double oi = 0; double Xr; loop(n) %{ or += $coeffs() * xr; oi += $coeffs() * xi; Xr = xr; xr = Xr * $x(c=>0) - xi * $x(c=>1); xi = xi * $x(c=>0) + Xr * $x(c=>1); %} $out(c=>0) = or; $out(c=>1) = oi; %} ! ; pp_add_isa 'PDL'; pp_addpm {At => Bot}, <<'EOD'; # overload must be here, so that all the functions can be seen # undocumented compatibility functions sub Catan2($$) { Catan Cdiv $_[1], $_[0] } sub atan2($$) { Catan Cdiv $_[1], $_[0] } sub _gen_biop { local $_ = shift; my $sub; if (/(\S+)\+(\w+)/) { $sub = eval 'sub { '.$2.' $_[0], ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1] }'; } elsif (/(\S+)\-(\w+)/) { $sub = eval 'sub { my $b = ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1]; $_[2] ? '.$2.' $b, $_[0] : '.$2.' $_[0], $b }'; } else { die; } if($1 eq "atan2" || $1 eq "<=>") { return ($1, $sub) } ($1, $sub, "$1=", $sub); } sub _gen_unop { my ($op, $func) = ($_[0] =~ /(.+)@(\w+)/); *$op = \&$func if $op =~ /\w+/; # create an alias ($op, eval 'sub { '.$func.' $_[0] }'); } sub _gen_cpop { ($_[0], eval 'sub { my $b = ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1]; ($_[2] ? $b <=> $_[0] : $_[0] <=> $b) '.$_[0].' 0 }'); } sub initialize { # Bless a null PDL into the supplied 1st arg package # If 1st arg is a ref, get the package from it bless PDL->null, ref($_[0]) ? ref($_[0]) : $_[0]; } use overload (map _gen_biop($_), qw(++Cadd --Csub *+Cmul /-Cdiv **-Cpow atan2-Catan2 <=>-Ccmp)), (map _gen_unop($_), qw(sin@Csin cos@Ccos exp@Cexp abs@Cabs log@Clog sqrt@Csqrt abs@Cabs)), (map _gen_cpop($_), qw(< <= == != >= >)), '++' => sub { $_[0] += 1 }, '--' => sub { $_[0] -= 1 }, '""' => \&PDL::Complex::string ; # overwrite PDL's overloading to honour subclass methods in + - * / { package PDL; my $warningFlag; # This strange usage of BEGINs is to ensure the # warning messages get disabled and enabled in the # proper order. Without the BEGIN's the 'use overload' # would be called first. BEGIN {$warningFlag = $^W; # Temporarily disable warnings caused by $^W = 0; # redefining PDL's subs } sub cp(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'+'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::plus (@_)} } sub cm(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'*'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::mult (@_)} } sub cmi(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'-'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::minus (@_)} } sub cd(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'/'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::divide (@_)} } # Used in overriding standard PDL +, -, *, / ops in the complex subclass. use overload ( '+' => \&cp, '*' => \&cm, '-' => \&cmi, '/' => \&cd, ); BEGIN{ $^W = $warningFlag;} # Put Back Warnings }; { our $floatformat = "%4.4g"; # Default print format for long numbers our $doubleformat = "%6.6g"; $PDL::Complex::_STRINGIZING = 0; sub PDL::Complex::string { my($self,$format1,$format2)=@_; my @dims = $self->dims; return PDL::string($self) if ($dims[0] != 2); if($PDL::Complex::_STRINGIZING) { return "ALREADY_STRINGIZING_NO_LOOPS"; } local $PDL::Complex::_STRINGIZING = 1; my $ndims = $self->getndims; if($self->nelem > $PDL::toolongtoprint) { return "TOO LONG TO PRINT"; } if ($ndims==0){ PDL::Core::string($self,$format1); } return "Null" if $self->isnull; return "Empty" if $self->isempty; # Empty piddle local $sep = $PDL::use_commas ? ", " : " "; local $sep2 = $PDL::use_commas ? ", " : ""; if ($ndims < 3) { return str1D($self,$format1,$format2); } else{ return strND($self,$format1,$format2,0); } } sub sum { my($x) = @_; my $tmp = $x->mv(0,1)->clump(0,2)->mv(1,0)->sumover; return $tmp->squeeze; } sub sumover{ my $m = shift; PDL::Ufunc::sumover($m->xchg(0,1)); } sub strND { my($self,$format1,$format2,$level)=@_; my @dims = $self->dims; if ($#dims==2) { return str2D($self,$format1,$format2,$level); } else { my $secbas = join '',map {":,"} @dims[0..$#dims-1]; my $ret="\n"." "x$level ."["; my $j; for ($j=0; $j<$dims[$#dims]; $j++) { my $sec = $secbas . "($j)"; $ret .= strND($self->slice($sec),$format1,$format2, $level+1); chop $ret; $ret .= $sep2; } chop $ret if $PDL::use_commas; $ret .= "\n" ." "x$level ."]\n"; return $ret; } } # String 1D array in nice format # sub str1D { my($self,$format1,$format2)=@_; barf "Not 1D" if $self->getndims() > 2; my $x = PDL::Core::listref_c($self); my ($ret,$dformat,$t, $i); my $dtype = $self->get_datatype(); $dformat = $PDL::Complex::floatformat if $dtype == $PDL_F; $dformat = $PDL::Complex::doubleformat if $dtype == $PDL_D; $ret = "[" if $self->getndims() > 1; my $badflag = $self->badflag(); for($i=0; $i<=$#$x; $i++){ $t = $$x[$i]; if ( $badflag and $t eq "BAD" ) { # do nothing } elsif ($format1) { $t = sprintf $format1,$t; } else{ # Default if ($dformat && length($t)>7) { # Try smaller $t = sprintf $dformat,$t; } } $ret .= $i % 2 ? $i<$#$x ? $t."i$sep" : $t."i" : substr($$x[$i+1],0,1) eq "-" ? "$t " : $t." +"; } $ret.="]" if $self->getndims() > 1; return $ret; } sub str2D { my($self,$format1,$format2,$level)=@_; my @dims = $self->dims(); barf "Not 2D" if scalar(@dims)!=3; my $x = PDL::Core::listref_c($self); my ($i, $f, $t, $len1, $len2, $ret); my $dtype = $self->get_datatype(); my $badflag = $self->badflag(); my $findmax = 0; if (!defined $format1 || !defined $format2 || $format1 eq '' || $format2 eq '') { $len1= $len2 = 0; if ( $badflag ) { for ($i=0; $i<=$#$x; $i++) { if ( $$x[$i] eq "BAD" ) { $f = 3; } else { $f = length($$x[$i]); } if ($i % 2) { $len2 = $f if $f > $len2; } else { $len1 = $f if $f > $len1; } } } else { for ($i=0; $i<=$#$x; $i++) { $f = length($$x[$i]); if ($i % 2){ $len2 = $f if $f > $len2; } else{ $len1 = $f if $f > $len1; } } } $format1 = '%'.$len1.'s'; $format2 = '%'.$len2.'s'; if ($len1 > 5){ if ($dtype == $PDL_F) { $format1 = $PDL::Complex::floatformat; $findmax = 1; } elsif ($dtype == $PDL_D) { $format1 = $PDL::Complex::doubleformat; $findmax = 1; } else { $findmax = 0; } } if($len2 > 5){ if ($dtype == $PDL_F) { $format2 = $PDL::Complex::floatformat; $findmax = 1; } elsif ($dtype == $PDL_D) { $format2 = $PDL::Complex::doubleformat; $findmax = 1; } else { $findmax = 0 unless $findmax; } } } if($findmax) { $len1 = $len2=0; if ( $badflag ) { for($i=0; $i<=$#$x; $i++){ $findmax = $i % 2; if ( $$x[$i] eq 'BAD' ){ $f = 3; } else{ $f = $findmax ? length(sprintf $format2,$$x[$i]) : length(sprintf $format1,$$x[$i]); } if ($findmax){ $len2 = $f if $f > $len2; } else{ $len1 = $f if $f > $len1; } } } else { for ($i=0; $i<=$#$x; $i++) { if ($i % 2){ $f = length(sprintf $format2,$$x[$i]); $len2 = $f if $f > $len2; } else{ $f = length(sprintf $format1,$$x[$i]); $len1 = $f if $f > $len1; } } } } # if: $findmax $ret = "\n" . ' 'x$level . "[\n"; { my $level = $level+1; $ret .= ' 'x$level .'['; $len2 += 2; for ($i=0; $i<=$#$x; $i++) { $findmax = $i % 2; if ($findmax){ if ( $badflag and $$x[$i] eq 'BAD' ){ #|| #($findmax && $$x[$i - 1 ] eq 'BAD') || #(!$findmax && $$x[$i +1 ] eq 'BAD')){ $f = "BAD"; } else{ $f = sprintf $format2, $$x[$i]; if (substr($$x[$i],0,1) eq '-'){ $f.='i'; } else{ $f =~ s/(\s*)(.*)/+$2i/; } } $t = $len2-length($f); } else{ if ( $badflag and $$x[$i] eq 'BAD' ){ $f = "BAD"; } else{ $f = sprintf $format1, $$x[$i]; $t = $len1-length($f); } } $f = ' 'x$t.$f if $t>0; $ret .= $f; if (($i+1)%($dims[1]*2)) { $ret.=$sep if $findmax; } else{ # End of output line $ret.=']'; if ($i==$#$x) { # very last number $ret.="\n"; } else{ $ret.= $sep2."\n" . ' 'x$level .'['; } } } } $ret .= ' 'x$level."]\n"; return $ret; } } =head1 AUTHOR Copyright (C) 2000 Marc Lehmann . All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. =head1 SEE ALSO perl(1), L. =cut EOD pp_done; PDL-2.018/Basic/Complex/Makefile.PL0000644060175006010010000000043612562522363015007 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["complex.pd", qw(Complex PDL::Complex)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS} = ['-lm']; undef &MY::postamble; # suppress warning *MY::postamble = sub{ pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Basic/Constants.pm0000644060175006010010000000273112562522363013740 0ustar chmNone=head1 NAME PDL::Constants -- basic compile time constants for PDL =head1 DESCRIPTION This module is used to define compile time constant values for PDL. It uses the constant module for simplicity and availability. We'll need to sort out exactly which constants make sense but PI and E seem to be fundamental. =head1 SYNOPSIS use PDL::Constants qw(PI E); print 'PI is ' . PI . "\n"; print 'E is ' . E . "\n"; =cut package PDL::Constants; our $VERSION = "0.02"; $VERSION = eval $VERSION; require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(PI E I J); # symbols to export use PDL::Lite; use PDL::Complex qw(i); =head2 PI The ratio of a circle's circumference to its diameter =cut use constant PI => 4 * atan2(1, 1); =head2 DEGRAD The The number of degrees of arc per radian (180/PI) =cut use constant DEGRAD => 180/PI; =head2 E The base of the natural logarithms or Euler's number =cut use constant E => exp(1); =head2 I The imaginary unit, C< I*I == -1 > =cut use constant I => i; =head2 J The imaginary unit for engineers, C< J*J == -1 > =cut use constant J => i; =head1 COPYRIGHT & LICENSE Copyright 2010 Chris Marshall (chm at cpan dot org). This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; PDL-2.018/Basic/Core/0000755060175006010010000000000013110402046012274 5ustar chmNonePDL-2.018/Basic/Core/Basic.pm0000644060175006010010000004342713036512174013700 0ustar chmNone =head1 NAME PDL::Basic -- Basic utility functions for PDL =head1 DESCRIPTION This module contains basic utility functions for creating and manipulating piddles. Most of these functions are simplified interfaces to the more flexible functions in the modules L and L. =head1 SYNOPSIS use PDL::Basic; =head1 FUNCTIONS =cut package PDL::Basic; use PDL::Core ''; use PDL::Types; use PDL::Exporter; use PDL::Options; @ISA=qw/PDL::Exporter/; @EXPORT_OK = qw/ ndcoords rvals axisvals allaxisvals xvals yvals zvals sec ins hist whist similar_assign transpose sequence xlinvals ylinvals zlinvals axislinvals/; %EXPORT_TAGS = (Func=>[@EXPORT_OK]); # Exportable functions *axisvals = \&PDL::axisvals; *allaxisvals = \&PDL::allaxisvals; *sec = \&PDL::sec; *ins = \&PDL::ins; *hist = \&PDL::hist; *whist = \&PDL::whist; *similar_assign = \&PDL::similar_assign; *transpose = \&PDL::transpose; *xlinvals = \&PDL::xlinvals; *ylinvals = \&PDL::ylinvals; *zlinvals = \&PDL::zlinvals; =head2 xvals =for ref Fills a piddle with X index values. Uses similar specifications to L and L. CAVEAT: If you use the single argument piddle form (top row in the usage table) the output will have the same type as the input; this may give surprising results if, e.g., you have a byte array with a dimension of size greater than 256. To force a type, use the third form. =for usage $x = xvals($somearray); $x = xvals([OPTIONAL TYPE],$nx,$ny,$nz...); $x = xvals([OPTIONAL TYPE], $somarray->dims); etc. see L. =for example pdl> print xvals zeroes(5,10) [ [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] ] =head2 yvals =for ref Fills a piddle with Y index values. See the CAVEAT for L. =for usage $x = yvals($somearray); yvals(inplace($somearray)); $x = yvals([OPTIONAL TYPE],$nx,$ny,$nz...); etc. see L. =for example pdl> print yvals zeroes(5,10) [ [0 0 0 0 0] [1 1 1 1 1] [2 2 2 2 2] [3 3 3 3 3] [4 4 4 4 4] [5 5 5 5 5] [6 6 6 6 6] [7 7 7 7 7] [8 8 8 8 8] [9 9 9 9 9] ] =head2 zvals =for ref Fills a piddle with Z index values. See the CAVEAT for L. =for usage $x = zvals($somearray); zvals(inplace($somearray)); $x = zvals([OPTIONAL TYPE],$nx,$ny,$nz...); etc. see L. =for example pdl> print zvals zeroes(3,4,2) [ [ [0 0 0] [0 0 0] [0 0 0] [0 0 0] ] [ [1 1 1] [1 1 1] [1 1 1] [1 1 1] ] ] =head2 xlinvals =for ref X axis values between endpoints (see L). =for usage $a = zeroes(100,100); $x = $a->xlinvals(0.5,1.5); $y = $a->ylinvals(-2,-1); # calculate Z for X between 0.5 and 1.5 and # Y between -2 and -1. $z = f($x,$y); C, C and C return a piddle with the same shape as their first argument and linearly scaled values between the two other arguments along the given axis. =head2 ylinvals =for ref Y axis values between endpoints (see L). See L for more information. =head2 zlinvals =for ref Z axis values between endpoints (see L). See L for more information. =head2 xlogvals =for ref X axis values logarithmically spaced between endpoints (see L). =for usage $a = zeroes(100,100); $x = $a->xlogvals(1e-6,1e-3); $y = $a->ylinvals(1e-4,1e3); # calculate Z for X between 1e-6 and 1e-3 and # Y between 1e-4 and 1e3. $z = f($x,$y); C, C and C return a piddle with the same shape as their first argument and logarithmically scaled values between the two other arguments along the given axis. =head2 ylogvals =for ref Y axis values logarithmically spaced between endpoints (see L). See L for more information. =head2 zlogvals =for ref Z axis values logarithmically spaced between endpoints (see L). See L for more information. =cut # Conveniently named interfaces to axisvals() sub xvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->xvals : PDL->xvals(@_) } sub yvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->yvals : PDL->yvals(@_) } sub zvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->zvals : PDL->zvals(@_) } sub PDL::xvals { my $class = shift; my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; axisvals2($pdl,0); return $pdl; } sub PDL::yvals { my $class = shift; my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; axisvals2($pdl,1); return $pdl; } sub PDL::zvals { my $class = shift; my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; axisvals2($pdl,2); return $pdl; } sub PDL::xlinvals { my $dim = $_[0]->getdim(0); barf "Must have at least two elements in dimension for xlinvals" if $dim <= 1; return $_[0]->xvals * (($_[2] - $_[1]) / ($dim-1)) + $_[1]; } sub PDL::ylinvals { my $dim = $_[0]->getdim(1); barf "Must have at least two elements in dimension for ylinvals" if $dim <= 1; return $_[0]->yvals * (($_[2] - $_[1]) / ($dim-1)) + $_[1]; } sub PDL::zlinvals { my $dim = $_[0]->getdim(2); barf "Must have at least two elements in dimension for zlinvals" if $dim <= 1; return $_[0]->zvals * (($_[2] - $_[1]) / ($dim-1)) + $_[1]; } sub PDL::xlogvals { my $dim = $_[0]->getdim(0); barf "Must have at least two elements in dimension for xlogvals" if $dim <= 1; my ($xmin,$xmax) = @_[1,2]; barf "xmin and xmax must be positive" if $xmin <= 0 || $xmax <= 0; my ($lxmin,$lxmax) = (log($xmin), log($xmax)); return exp($_[0]->xvals * (($lxmax - $lxmin) / ($dim-1)) + $lxmin); } sub PDL::ylogvals { my $dim = $_[0]->getdim(1); barf "Must have at least two elements in dimension for xlogvals" if $dim <= 1; my ($xmin,$xmax) = @_[1,2]; barf "xmin and xmax must be positive" if $xmin <= 0 || $xmax <= 0; my ($lxmin,$lxmax) = (log($xmin), log($xmax)); return exp($_[0]->yvals * (($lxmax - $lxmin) / ($dim-1)) + $lxmin); } sub PDL::zlogvals { my $dim = $_[0]->getdim(2); barf "Must have at least two elements in dimension for xlogvals" if $dim <= 1; my ($xmin,$xmax) = @_[1,2]; barf "xmin and xmax must be positive" if $xmin <= 0 || $xmax <= 0; my ($lxmin,$lxmax) = (log($xmin), log($xmax)); return exp($_[0]->zvals * (($lxmax - $lxmin) / ($dim-1)) + $lxmin); } =head2 allaxisvals =for ref Synonym for L - enumerates all coordinates in a PDL or dim list, adding an extra dim on the front to accommodate the vector coordinate index (the form expected by L, L, and L). See L for more detail. =for usage $indices = allaxisvals($pdl); $indices = allaxisvals(@dimlist); $indices = allaxisvals($type,@dimlist); =cut =head2 ndcoords =for ref Enumerate pixel coordinates for an N-D piddle Returns an enumerated list of coordinates suitable for use in L or L: you feed in a dimension list and get out a piddle whose 0th dimension runs over dimension index and whose 1st through Nth dimensions are the dimensions given in the input. If you feed in a piddle instead of a perl list, then the dimension list is used, as in L etc. Unlike L etc., if you supply a piddle input, you get out a piddle of the default piddle type: double. This causes less surprises than the previous default of keeping the data type of the input piddle since that rarely made sense in most usages. =for usage $indices = ndcoords($pdl); $indices = ndcoords(@dimlist); $indices = ndcoords($type,@dimlist); =for example pdl> print ndcoords(2,3) [ [ [0 0] [1 0] ] [ [0 1] [1 1] ] [ [0 2] [1 2] ] ] pdl> $a = zeroes(byte,2,3); # $a is a 2x3 byte piddle pdl> $b = ndcoords($a); # $b inherits $a's type pdl> $c = ndcoords(long,$a->dims); # $c is a long piddle, same dims as $b pdl> help $b; This variable is Byte D [2,2,3] P 0.01Kb pdl> help $c; This variable is Long D [2,2,3] P 0.05Kb =cut sub PDL::ndcoords { my $type; if(ref $_[0] eq 'PDL::Type') { $type = shift; } my @dims = (ref $_[0]) ? (shift)->dims : @_; my @d = @dims; unshift(@d,scalar(@dims)); unshift(@d,$type) if defined($type); $out = PDL->zeroes(@d); for my $d(0..$#dims) { my $a = $out->index($d)->mv($d,0); $a .= xvals($a); } $out; } *ndcoords = \&PDL::ndcoords; *allaxisvals = \&PDL::ndcoords; *PDL::allaxisvals = \&PDL::ndcoords; =head2 hist =for ref Create histogram of a piddle =for usage $hist = hist($data); ($xvals,$hist) = hist($data); or $hist = hist($data,$min,$max,$step); ($xvals,$hist) = hist($data,[$min,$max,$step]); If C is run in list context, C<$xvals> gives the computed bin centres as double values. A nice idiom (with L) is bin hist $data; # Plot histogram =for example pdl> p $y [13 10 13 10 9 13 9 12 11 10 10 13 7 6 8 10 11 7 12 9 11 11 12 6 12 7] pdl> $h = hist $y,0,20,1; # hist with step 1, min 0 and 20 bins pdl> p $h [0 0 0 0 0 0 2 3 1 3 5 4 4 4 0 0 0 0 0 0] =cut sub PDL::hist { my $usage = "\n" . ' Usage: $hist = hist($data)' . "\n" . ' $hist = hist($data,$min,$max,$step)' . "\n" . ' ($xvals,$hist) = hist($data)' . "\n" . ' ($xvals,$hist) = hist($data,$min,$max,$step)' . "\n" ; barf($usage) if $#_<0; my($pdl,$min,$max,$step)=@_; my $xvals; ($step, $min, $bins, $xvals) = _hist_bin_calc($pdl, $min, $max, $step, wantarray()); PDL::Primitive::histogram($pdl->clump(-1),(my $hist = null), $step,$min,$bins); return wantarray() ? ($xvals,$hist) : $hist; } =head2 whist =for ref Create a weighted histogram of a piddle =for usage $hist = whist($data, $wt, [$min,$max,$step]); ($xvals,$hist) = whist($data, $wt, [$min,$max,$step]); If requested, C<$xvals> gives the computed bin centres as type double values. C<$data> and C<$wt> should have the same dimensionality and extents. A nice idiom (with L) is bin whist $data, $wt; # Plot histogram =for example pdl> p $y [13 10 13 10 9 13 9 12 11 10 10 13 7 6 8 10 11 7 12 9 11 11 12 6 12 7] pdl> $wt = grandom($y->nelem) pdl> $h = whist $y, $wt, 0, 20, 1 # hist with step 1, min 0 and 20 bins pdl> p $h [0 0 0 0 0 0 -0.49552342 1.7987439 0.39450696 4.0073722 -2.6255299 -2.5084501 2.6458365 4.1671676 0 0 0 0 0 0] =cut sub PDL::whist { barf('Usage: ([$xvals],$hist) = whist($data,$wt,[$min,$max,$step])') if @_ < 2; my($pdl,$wt,$min,$max,$step)=@_; my $xvals; ($step, $min, $bins, $xvals) = _hist_bin_calc($pdl, $min, $max, $step, wantarray()); PDL::Primitive::whistogram($pdl->clump(-1),$wt->clump(-1), (my $hist = null), $step, $min, $bins); return wantarray() ? ($xvals,$hist) : $hist; } sub _hist_bin_calc { my($pdl,$min,$max,$step,$wantarray)=@_; $min = $pdl->min() unless defined $min; $max = $pdl->max() unless defined $max; my $nelem = $pdl->nelem; barf "empty piddle, no values to work with" if $nelem == 0; $step = ($max-$min)/(($nelem>10_000) ? 100 : sqrt($nelem)) unless defined $step; barf "step is zero (or all data equal to one value)" if $step == 0; my $bins = int(($max-$min)/$step+0.5); print "hist with step $step, min $min and $bins bins\n" if $PDL::debug; # Need to use double for $xvals here my $xvals = $min + $step/2 + sequence(PDL::Core::double,$bins)*$step if $wantarray; return ( $step, $min, $bins, $xvals ); } =head2 sequence =for ref Create array filled with a sequence of values =for usage $a = sequence($b); $a = sequence [OPTIONAL TYPE], @dims; etc. see L. =for example pdl> p sequence(10) [0 1 2 3 4 5 6 7 8 9] pdl> p sequence(3,4) [ [ 0 1 2] [ 3 4 5] [ 6 7 8] [ 9 10 11] ] =cut sub sequence { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->sequence : PDL->sequence(@_) } sub PDL::sequence { my $class = shift; my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; my $bar = $pdl->clump(-1)->inplace; my $foo = $bar->xvals; return $pdl; } =head2 rvals =for ref Fills a piddle with radial distance values from some centre. =for usage $r = rvals $piddle,{OPTIONS}; $r = rvals [OPTIONAL TYPE],$nx,$ny,...{OPTIONS}; =for options Options: Centre => [$x,$y,$z...] # Specify centre Center => [$x,$y.$z...] # synonym. Squared => 1 # return distance squared (i.e., don't take the square root) =for example pdl> print rvals long,7,7,{Centre=>[2,2]} [ [2 2 2 2 2 3 4] [2 1 1 1 2 3 4] [2 1 0 1 2 3 4] [2 1 1 1 2 3 4] [2 2 2 2 2 3 4] [3 3 3 3 3 4 5] [4 4 4 4 4 5 5] ] If C
is not specified, the midpoint for a given dimension of size C is given by C< int(N/2) > so that the midpoint always falls on an exact pixel point in the data. For dimensions of even size, that means the midpoint is shifted by 1/2 pixel from the true center of that dimension. Also note that the calculation for C for integer values does not promote the datatype so you will have wraparound when the value calculated for C< r**2 > is greater than the datatype can hold. If you need exact values, be sure to use large integer or floating point datatypes. For a more general metric, one can define, e.g., sub distance { my ($a,$centre,$f) = @_; my ($r) = $a->allaxisvals-$centre; $f->($r); } sub l1 { sumover(abs($_[0])); } sub euclid { use PDL::Math 'pow'; pow(sumover(pow($_[0],2)),0.5); } sub linfty { maximum(abs($_[0])); } so now distance($a, $centre, \&euclid); will emulate rvals, while C<\&l1> and C<\&linfty> will generate other well-known norms. =cut sub rvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->rvals(@_[1..$#_]) : PDL->rvals(@_) } sub PDL::rvals { # Return radial distance from given point and offset my $class = shift; my $opt = pop @_ if ref($_[$#_]) eq "HASH"; my %opt = defined $opt ? iparse( { CENTRE => undef, # needed, otherwise centre/center handling painful Squared => 0, }, $opt ) : (); my $r = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; my @pos; @pos = @{$opt{CENTRE}} if defined $opt{CENTRE}; my $offset; $r .= 0.0; my $tmp = $r->copy; my $i; for ($i=0; $i<$r->getndims; $i++) { $offset = (defined $pos[$i] ? $pos[$i] : int($r->getdim($i)/2)); # Note careful coding for speed and min memory footprint PDL::Primitive::axisvalues($tmp->xchg(0,$i)); $tmp -= $offset; $tmp *= $tmp; $r += $tmp; } return $opt{Squared} ? $r : $r->inplace->sqrt; } =head2 axisvals =for ref Fills a piddle with index values on Nth dimension =for usage $z = axisvals ($piddle, $nth); This is the routine, for which L, L etc are mere shorthands. C can be used to fill along any dimension, using a parameter. See also L, which generates all axis values simultaneously in a form useful for L, L, L, etc. Note the 'from specification' style (see L) is not available here, for obvious reasons. =cut sub PDL::axisvals { my($this,$nth) = @_; my $dummy = $this->new_or_inplace; if($dummy->getndims() <= $nth) { # This is 'kind of' consistency... $dummy .= 0; return $dummy; # barf("Too few dimensions given to axisvals $nth\n"); } my $bar = $dummy->xchg(0,$nth); PDL::Primitive::axisvalues($bar); return $dummy; } # We need this version for xvals etc to work in place sub axisvals2 { my($this,$nth) = @_; my $dummy = shift; if($dummy->getndims() <= $nth) { # This is 'kind of' consistency... $dummy .= 0; return $dummy; # barf("Too few dimensions given to axisvals $nth\n"); } my $bar = $dummy->xchg(0,$nth); PDL::Primitive::axisvalues($bar); return $dummy; } sub PDL::sec { my($this,@coords) = @_; my $i; my @maps; while($#coords > -1) { $i = int(shift @coords) ; push @maps, "$i:".int(shift @coords); } my $tmp = PDL->null; $tmp .= $this->slice(join ',',@maps); return $tmp; } sub PDL::ins { my($this,$what,@coords) = @_; my $w = PDL::Core::alltopdl($PDL::name,$what); my $tmp; if($this->is_inplace) { $this->set_inplace(0); } else { $this = $this->copy; } ($tmp = $this->slice( (join ',',map {int($coords[$_]).":". ((int($coords[$_])+$w->getdim($_)-1)<$this->getdim($_) ? (int($coords[$_])+$w->getdim($_)-1):$this->getdim($_)) } 0..$#coords))) .= $w; return $this; } sub PDL::similar_assign { my($from,$to) = @_; if((join ',',@{$from->dims}) ne (join ',',@{$to->dims})) { barf "Similar_assign: dimensions [". (join ',',@{$from->dims})."] and [". (join ',',@{$to->dims})."] do not match!\n"; } $to .= $from; } =head2 transpose =for ref transpose rows and columns. =for usage $b = transpose($a); =for example pdl> $a = sequence(3,2) pdl> p $a [ [0 1 2] [3 4 5] ] pdl> p transpose( $a ) [ [0 3] [1 4] [2 5] ] =cut sub PDL::transpose { my($this) = @_; if($this->getndims <= 1) { if($this->getndims==0) { return pdl $this->dummy(0)->dummy(0); } else { return pdl $this->dummy(0); } } return $this->xchg(0,1); } 1; PDL-2.018/Basic/Core/Char.pm0000644060175006010010000002011012562522363013520 0ustar chmNonepackage PDL::Char; @ISA = qw (PDL); use overload ("\"\"" => \&PDL::Char::string); use strict; use vars ('$level', '@dims'); # Global Vars used =head1 NAME PDL::Char -- PDL subclass which allows reading and writing of fixed-length character strings as byte PDLs =head1 SYNOPSIS use PDL; use PDL::Char; my $pchar = PDL::Char->new( [['abc', 'def', 'ghi'],['jkl', 'mno', 'pqr']] ); $pchar->setstr(1,0,'foo'); print $pchar; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'foo' 'ghi'] # ['jkl' 'mno' 'pqr'] # ] print $pchar->atstr(2,0); # Prints: # ghi =head1 DESCRIPTION This subclass of PDL allows one to manipulate PDLs of 'byte' type as if they were made of fixed length strings, not just numbers. This type of behavior is useful when you want to work with charactar grids. The indexing is done on a string level and not a character level for the 'setstr' and 'atstr' commands. This module is in particular useful for writing NetCDF files that include character data using the PDL::NetCDF module. =head1 FUNCTIONS =head2 new =for ref Function to create a byte PDL from a string, list of strings, list of list of strings, etc. =for usage # create a new PDL::Char from a perl array of strings $strpdl = PDL::Char->new( ['abc', 'def', 'ghij'] ); # Convert a PDL of type 'byte' to a PDL::Char $strpdl1 = PDL::Char->new (sequence (byte, 4, 5)+99); =for example $pdlchar3d = PDL::Char->new([['abc','def','ghi'],['jkl', 'mno', 'pqr']]); =cut sub new { my $type = shift; my $value = (scalar(@_)>1 ? [@_] : shift); # ref thyself # re-bless byte PDLs as PDL::Char if (ref($value) =~ /PDL/) { PDL::Core::barf('Cannot convert a non-byte PDL to PDL::Char') if ($value->get_datatype != $PDL::Types::PDL_B); return bless $value, $type; } my $ptype = $PDL::Types::PDL_B; my $self = PDL->initialize(); $self->set_datatype($ptype); $value = 0 if !defined($value); $level = 0; @dims = (); # package vars my $maxlength; # max length seen for all character strings my $samelen = 1; # Flag = 1 if all character strings are the same length # 1st Pass thru the perl array structure, assume all strings the same length my $str = _rcharpack($value,\$maxlength,\$samelen); unless( $samelen){ # Strings weren't the same length, go thru again and null pad to # the max length. $str = _rcharpack2($value,$maxlength); } $self->setdims([reverse @dims]); ${$self->get_dataref} = $str; $self->upd_data(); return bless $self, $type; } # Take an N-D perl array of strings and pack it into a single string, # updating the $level and @dims package vars on the way. # Used by the 'char' constructor # # References supplied so $maxlength and $samelen are updated along the way as well. # # # This version (_rcharpack) is for the 1st pass thru the N-d string array. # It assumes that all strings are the same length, but also checks to see if they aren't sub _rcharpack { my $a = shift; # Input string my ($maxlenref, $samelenref) = @_; # reference to $maxlength, $samelen my ($ret,$type); $ret = ""; if (ref($a) eq "ARRAY") { PDL::Core::barf('Array is not rectangular') if (defined($dims[$level]) and $dims[$level] != scalar(@$a)); $dims[$level] = scalar (@$a); $level++; $type = ref($$a[0]); for(@$a) { PDL::Core::barf('Array is not rectangular') unless $type eq ref($_); # Equal types $ret .= _rcharpack($_,$maxlenref, $samelenref); } $level--; }elsif (ref(\$a) eq "SCALAR") { my $len = length($a); # Check for this length being different then the others: $$samelenref = 0 if( defined($$maxlenref) && ($len != $$maxlenref) ); # Save the max length: $$maxlenref = $len if( !defined($$maxlenref) || $len > $$maxlenref); # see if this is the max length seen so far $dims[$level] = $len; $ret = $a; }else{ PDL::Core::barf("Don't know how to make a PDL object from passed argument"); } return $ret; } # # # This version (_rcharpack2) is for the 2nd pass (if required) thru the N-d string array. # If the 1st pass thru (_rcharpack) finds that all strings were not the same length, # this routine will go thru and null-pad all strings to the max length seen. # Note: For efficiency, the error checking is not repeated here, because any errors will # already be detected in the 1st pass. # sub _rcharpack2 { my $a = shift; # Input string my ($maxlen) = @_; # Length to pad strings to my ($ret,$type); $ret = ""; if (ref($a) eq "ARRAY") { # Checks not needed the second time thru (removed) $dims[$level] = scalar (@$a); $level++; $type = ref($$a[0]); for(@$a) { $ret .= _rcharpack2($_,$maxlen); } $level--; }elsif (ref(\$a) eq "SCALAR") { my $len = length($a); $dims[$level] = $maxlen; $ret = $a.("\00" x ($maxlen - $len)); } return $ret; } # # =head2 string =for ref Function to print a character PDL (created by 'char') in a pretty format. =for usage $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] ); print $char; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'def' 'ghi'] # ['jkl' 'mno' 'pqr'] # ] # 'string' is overloaded to the "" operator, so: # print $char; # should have the same effect. =cut sub string { my $self = shift; my $level = shift || 0; my $sep = $PDL::use_commas ? "," : " "; if ($self->dims == 1) { my $str = ${$self->get_dataref}; # get copy of string $str =~ s/\00+$//g; # get rid of any null padding return "\'". $str. "\'". $sep; } else { my @dims = reverse $self->dims; my $ret = ''; $ret .= (" " x $level) . '[' . ((@dims == 2) ? ' ' : "\n"); for (my $i=0;$i<$dims[0];$i++) { my $slicestr = ":," x (scalar(@dims)-1) . "($i)"; my $substr = $self->slice($slicestr); $ret .= $substr->string($level+1); } $ret .= (" " x $level) . ']' . $sep . "\n"; return $ret; } } =head2 setstr =for ref Function to set one string value in a character PDL. The input position is the position of the string, not a character in the string. The first dimension is assumed to be the length of the string. The input string will be null-padded if the string is shorter than the first dimension of the PDL. It will be truncated if it is longer. =for usage $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] ); $char->setstr(0,1, 'foobar'); print $char; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'def' 'ghi'] # ['foo' 'mno' 'pqr'] # ] $char->setstr(2,1, 'f'); print $char; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'def' 'ghi'] # ['foo' 'mno' 'f'] -> note that this 'f' is stored "f\0\0" # ] =cut sub setstr { # Sets a particular single value to a string. PDL::Core::barf('Usage: setstr($pdl, $x, $y,.., $value)') if $#_<2; my $self = shift; my $val = pop; my @dims = $self->dims; my $n = $dims[0]; for (my $i=0;$i<$n;$i++) { my $chr = ($i >= length($val)) ? 0 : unpack ("C", substr ($val, $i, 1)); PDL::Core::set_c ($self, [$i, @_], $chr); } } =head2 atstr =for ref Function to fetch one string value from a PDL::Char type PDL, given a position within the PDL. The input position of the string, not a character in the string. The length of the input string is the implied first dimension. =for usage $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] ); print $char->atstr(0,1); # Prints: # jkl =cut sub atstr { # Fetchs a string value from a PDL::Char PDL::Core::barf('Usage: atstr($pdl, $x, $y,..,)') if (@_ < 2); my $self = shift; my $str = ':,' . join (',', map {"($_)"} @_); my $a = $self->slice($str); my $val = ${$a->get_dataref}; # get the data $val =~ s/\00+$//g; # get rid of any null padding return $val; } # yuck ;) this is a cool little accessor method # rebless a slice into PDL; originally # Marc's idea used in PDL::Complex sub numeric { my ($seq) = @_; return bless $seq->slice(''), 'PDL'; } 1; PDL-2.018/Basic/Core/Core.pm0000644060175006010010000032327113110400221013523 0ustar chmNonepackage PDL::Core; # Core routines for PDL module use strict; use warnings; use PDL::Exporter; require PDL; # for $VERSION use DynaLoader; our @ISA = qw( PDL::Exporter DynaLoader ); our $VERSION = '2.018'; bootstrap PDL::Core $VERSION; use PDL::Types ':All'; use Config; our @EXPORT = qw( piddle pdl null barf ); # Only stuff always exported! my @convertfuncs = map PDL::Types::typefld($_,'convertfunc'), PDL::Types::typesrtkeys(); my @exports_internal = qw(howbig threadids topdl); my @exports_normal = (@EXPORT, @convertfuncs, qw(nelem dims shape null convert inplace zeroes zeros ones list listindices unpdl set at flows thread_define over reshape dog cat barf type diagonal dummy mslice approx flat sclr squeeze get_autopthread_targ set_autopthread_targ get_autopthread_actual get_autopthread_size set_autopthread_size) ); our @EXPORT_OK = (@exports_internal, @exports_normal); our %EXPORT_TAGS = ( Func => [@exports_normal], Internal => [@exports_internal] ); our ($level, @dims, $sep, $sep2, $match); # Important variables (place in PDL namespace) # (twice to eat "used only once" warning) $PDL::debug = # Debugging info $PDL::debug = 0; $PDL::verbose = # Functions provide chatty information $PDL::verbose = 0; $PDL::use_commas = 0; # Whether to insert commas when printing arrays $PDL::floatformat = "%7g"; # Default print format for long numbers $PDL::doubleformat = "%10.8g"; $PDL::indxformat = "%12d"; # Default print format for PDL_Indx values $PDL::undefval = 0; # Value to use instead of undef when creating PDLs $PDL::toolongtoprint = 10000; # maximum pdl size to stringify for printing ################ Exportable functions of the Core ###################### # log10() is now defined in ops.pd *howbig = \&PDL::howbig; *unpdl = \&PDL::unpdl; *nelem = \&PDL::nelem; *inplace = \&PDL::inplace; *dims = \&PDL::dims; *list = \&PDL::list; *threadids = \&PDL::threadids; *listindices = \&PDL::listindices; *null = \&PDL::null; *set = \&PDL::set; *at = \&PDL::at; *flows = \&PDL::flows; *sclr = \&PDL::sclr; *shape = \&PDL::shape; for (map { [ PDL::Types::typefld($_,'convertfunc'), PDL::Types::typefld($_,'numval') ] } PDL::Types::typesrtkeys()) { my ($conv, $val) = @$_; no strict 'refs'; *$conv = *{"PDL::$conv"} = sub { return bless [$val], "PDL::Type" unless @_; alltopdl('PDL', (scalar(@_)>1 ? [@_] : shift), PDL::Type->new($val)); }; } BEGIN { *thread_define = \&PDL::thread_define; *convert = \&PDL::convert; *over = \&PDL::over; *dog = \&PDL::dog; *cat = \&PDL::cat; *type = \&PDL::type; *approx = \&PDL::approx; *diagonal = \&PDL::diagonal; *dummy = \&PDL::dummy; *mslice = \&PDL::mslice; *isempty = \&PDL::isempty; *string = \&PDL::string; } =head1 NAME PDL::Core - fundamental PDL functionality and vectorization/threading =head1 DESCRIPTION Methods and functions for type conversions, PDL creation, type conversion, threading etc. =head1 SYNOPSIS use PDL::Core; # Normal routines use PDL::Core ':Internal'; # Hairy routines =head1 VECTORIZATION/THREADING: METHOD AND NOMENCLATURE PDL provides vectorized operations via a built-in engine. Vectorization is called "threading" for historical reasons. The threading engine implements simple rules for each operation. Each PDL object has a "shape" that is a generalized N-dimensional rectangle defined by a "dim list" of sizes in an arbitrary set of dimensions. A PDL with shape 2x3 has 6 elements and is said to be two-dimensional, or may be referred to as a 2x3-PDL. The dimensions are indexed numerically starting at 0, so a 2x3-PDL has a dimension 0 (or "dim 0") with size 2 and a 1 dimension (or "dim 1") with size 3. PDL generalizes *all* mathematical operations with the notion of "active dims": each operator has zero or more active dims that are used in carrying out the operation. Simple scalar operations like scalar multiplication ('*') have 0 active dims. More complicated operators can have more active dims. For example, matrix multiplication ('x') has 2 active dims. Additional dims are automatically vectorized across -- e.g. multiplying a 2x5-PDL with a 2x5-PDL requires 10 simple multiplication operations, and yields a 2x5-PDL result. =head2 Threading rules In any PDL expression, the active dims appropriate for each operator are used starting at the 0 dim and working forward through the dim list of each object. All additional dims after the active dims are "thread dims". The thread dims do not have to agree exactly: they are coerced to agree according to simple rules: =over 3 =item * Null PDLs match any dim list (see below). =item * Dims with sizes other than 1 must all agree in size. =item * Dims of size 1 are expanded as necessary. =item * Missing dims are expanded appropriately. =back The "size 1" rule implements "generalized scalar" operation, by analogy to scalar multiplication. The "missing dims" rule acknowledges the ambiguity between a missing dim and a dim of size 1. =head2 Null PDLs PDLs on the left-hand side of assignment can have the special value "Null". A null PDL has no dim list and no set size; its shape is determined by the computed shape of the expression being assigned to it. Null PDLs contain no values and can only be assigned to. When assigned to (e.g. via the C<.=> operator), they cease to be null PDLs. To create a null PDL, use Cnull()>. =head2 Empty PDLs PDLs can represent the empty set using "structured Empty" variables. An empty PDL is not a null PDL. Any dim of a PDL can be set explicitly to size 0. If so, the PDL contains zero values (because the total number of values is the product of all the sizes in the PDL's shape or dimlist). Scalar PDLs are zero-dimensional and have no entries in the dim list, so they cannot be empty. 1-D and higher PDLs can be empty. Empty PDLs are useful for set operations, and are most commonly encountered in the output from selection operators such as L and L. Not all empty PDLs have the same threading properties -- e.g. a 2x0-PDL represents a collection of 2-vectors that happens to contain no elements, while a simple 0-PDL represents a collection of scalar values (that also happens to contain no elements). Note that 0 dims are not adjustable via the threading rules -- a dim with size 0 can only match a corresponding dim of size 0 or 1. =head2 Thread rules and assignments Versions of PDL through 2.4.10 have some irregularity with threading and assignments. Currently the threading engine performs a full expansion of both sides of the computed assignment operator C<.=> (which assigns values to a pre-existing PDL). This leads to counter-intuitive behavior in some cases: =over 3 =item * Generalized scalars and computed assignment If the PDL on the left-hand side of C<.=> has a dim of size 1, it can be treated as a generalized scalar, as in: $a = sequence(2,3); $b = zeroes(1,3); $b .= $a; In this case, C<$b> is automatically treated as a 2x3-PDL during the threading operation, but half of the values from C<$a> silently disappear. The output is, as Kernighan and Ritchie would say, "undefined". Further, if the value on the right of C<.=> is empty, then C<.=> becomes a silent no-op: $a = zeroes(0); $b = zeroes(1); $b .= $a+1; print $b; will print C<[0]>. In this case, "$a+1" is empty, and "$b" is a generalized scalar that is adjusted to be empty, so the assignment is carried out for zero elements (a no-op). Both of these behaviors are considered harmful and should not be relied upon: they may be patched away in a future version of PDL. =item * Empty PDLs and generalized scalars Generalized scalars (PDLs with a dim of size 1) can match any size in the corresponding dim, including 0. Thus, $a = ones(2,0); $b = sequence(2,1); $c = $a * $b; print $c; prints C. This behavior is counterintuitive but desirable, and will be preserved in future versions of PDL. =back =head1 VARIABLES These are important variables of B scope and are placed in the PDL namespace. =head3 C<$PDL::debug> =over 4 When true, PDL debugging information is printed. =back =head3 C<$PDL::verbose> =over 4 When true, PDL functions provide chatty information. =back =head3 C<$PDL::use_commas> =over 4 Whether to insert commas when printing pdls =back =head3 C<$PDL::floatformat>, C<$PDL::doubleformat>, C<$PDL::indxformat> =over 4 The default print format for floats, doubles, and indx values, respectively. The default default values are: $PDL::floatformat = "%7g"; $PDL::doubleformat = "%10.8g"; $PDL::indxformat = "%12d"; =back =head3 C<$PDL::undefval> =over 4 The value to use instead of C when creating pdls. =back =head3 C<$PDL::toolongtoprint> =over 4 The maximal size pdls to print (defaults to 10000 elements) =back =head1 FUNCTIONS =head2 barf =for ref Standard error reporting routine for PDL. C is the routine PDL modules should call to report errors. This is because C will report the error as coming from the correct line in the module user's script rather than in the PDL module. For now, barf just calls Carp::confess() Remember C is your friend. *Use* it! =for example At the perl level: barf("User has too low an IQ!"); In C or XS code: barf("You have made %d errors", count); Note: this is one of the few functions ALWAYS exported by PDL::Core =cut use Carp; sub barf { goto &Carp::confess } sub cluck { goto &Carp::cluck } *PDL::barf = \&barf; *PDL::cluck = \&cluck; ########## Set Auto-PThread Based On Environment Vars ############ PDL::set_autopthread_targ( $ENV{PDL_AUTOPTHREAD_TARG} ) if( defined ( $ENV{PDL_AUTOPTHREAD_TARG} ) ); PDL::set_autopthread_size( $ENV{PDL_AUTOPTHREAD_SIZE} ) if( defined ( $ENV{PDL_AUTOPTHREAD_SIZE} ) ); ################################################################## =head2 pdl =for ref PDL constructor - creates new piddle from perl scalars/arrays, piddles, and strings =for usage $double_pdl = pdl(SCALAR|ARRAY REFERENCE|ARRAY|STRING); # default type $type_pdl = pdl(PDL::Type,SCALAR|ARRAY REFERENCE|ARRAY|STRING); =for example $a = pdl [1..10]; # 1D array $a = pdl ([1..10]); # 1D array $a = pdl (1,2,3,4); # Ditto $b = pdl [[1,2,3],[4,5,6]]; # 2D 3x2 array $b = pdl "[[1,2,3],[4,5,6]]"; # Ditto (slower) $b = pdl "[1 2 3; 4 5 6]"; # Ditto $b = pdl q[1 2 3; 4 5 6]; # Ditto, using the q quote operator $b = pdl "1 2 3; 4 5 6"; # Ditto, less obvious, but still works $b = pdl 42 # 0-dimensional scalar $c = pdl $a; # Make a new copy $u = pdl ushort(), 42 # 0-dimensional ushort scalar $b = pdl(byte(),[[1,2,3],[4,5,6]]); # 2D byte piddle $n = pdl indx(), [1..5]; # 1D array of indx values $n = pdl indx, [1..5]; # ... can leave off parens $n = indx( [1..5] ); # ... still the same! $a = pdl([1,2,3],[4,5,6]); # 2D $a = pdl([1,2,3],[4,5,6]); # 2D Note the last two are equivalent - a list is automatically converted to a list reference for syntactic convenience. i.e. you can omit the outer C<[]> You can mix and match arrays, array refs, and PDLs in your argument list, and C will sort them out. You get back a PDL whose last (slowest running) dim runs across the top level of the list you hand in, and whose first (fastest running) dim runs across the deepest level that you supply. At the moment, you cannot mix and match those arguments with string arguments, though we can't imagine a situation in which you would really want to do that. The string version of pdl also allows you to use the strings C, C, and C, and it will insert the values that you mean (and set the bad flag if you use C). You can mix and match case, though you shouldn't. Here are some examples: $bad = pdl q[1 2 3 bad 5 6]; # Set fourth element to the bad value $bad = pdl q[1 2 3 BAD 5 6]; # ditto $bad = pdl q[1 2 inf bad 5]; # now third element is IEEE infinite value $bad = pdl q[nan 2 inf -inf]; # first value is IEEE nan value The default constructor uses IEEE double-precision floating point numbers. You can use other types, but you will get a warning if you try to use C with integer types (it will be replaced with the C value) and you will get a fatal error if you try to use C. Throwing a PDL into the mix has the same effect as throwing in a list ref: pdl(pdl(1,2),[3,4]) is the same as pdl([1,2],[3,4]). All of the dimensions in the list are "padded-out" with undefval to meet the widest dim in the list, so (e.g.) $a = pdl([[1,2,3],[2]]) gives you the same answer as $a = pdl([[1,2,3],[2,undef,undef]]); If your PDL module has bad values compiled into it (see L), you can pass BAD values into the constructor within pre-existing PDLs. The BAD values are automatically kept BAD and propagated correctly. C is a functional synonym for the 'new' constructor, e.g.: $x = new PDL [1..10]; In order to control how undefs are handled in converting from perl lists to PDLs, one can set the variable C<$PDL::undefval>. For example: $foo = [[1,2,undef],[undef,3,4]]; $PDL::undefval = -999; $f = pdl $foo; print $f [ [ 1 2 -999] [-999 3 4] ] C<$PDL::undefval> defaults to zero. As a final note, if you include an Empty PDL in the list of objects to construct into a PDL, it is kept as a placeholder pane -- so if you feed in (say) 7 objects, you get a size of 7 in the 0th dim of the output PDL. The placeholder panes are completely padded out. But if you feed in only a single Empty PDL, you get back the Empty PDL (no padding). =cut sub pdl {PDL->pdl(@_)} sub piddle {PDL->pdl(@_)} =head2 null =for ref Returns a 'null' piddle. =for usage $x = null; C has a special meaning to L. It is used to flag a special kind of empty piddle, which can grow to appropriate dimensions to store a result (as opposed to storing a result in an existing piddle). =for example pdl> sumover sequence(10,10), $ans=null;p $ans [45 145 245 345 445 545 645 745 845 945] =cut sub PDL::null{ my $class = scalar(@_) ? shift : undef; # if this sub called with no # class ( i.e. like 'null()', instead # of '$obj->null' or 'CLASS->null', setup if( defined($class) ){ $class = ref($class) || $class; # get the class name } else{ $class = 'PDL'; # set class to the current package name if null called # with no arguments } return $class->initialize(); } =head2 nullcreate =for ref Returns a 'null' piddle. =for usage $x = PDL->nullcreate($arg) This is an routine used by many of the threading primitives (i.e. L, L, etc.) to generate a null piddle for the function's output that will behave properly for derived (or subclassed) PDL objects. For the above usage: If C<$arg> is a PDL, or a derived PDL, then C<$arg-Enull> is returned. If C<$arg> is a scalar (i.e. a zero-dimensional PDL) then Cnull> is returned. =for example PDL::Derived->nullcreate(10) returns PDL::Derived->null. PDL->nullcreate($pdlderived) returns $pdlderived->null. =cut sub PDL::nullcreate{ my ($type,$arg) = @_; return ref($arg) ? $arg->null : $type->null ; } =head2 nelem =for ref Return the number of elements in a piddle =for usage $n = nelem($piddle); $n = $piddle->nelem; =for example $mean = sum($data)/nelem($data); =head2 dims =for ref Return piddle dimensions as a perl list =for usage @dims = $piddle->dims; @dims = dims($piddle); =for example pdl> p @tmp = dims zeroes 10,3,22 10 3 22 See also L which returns a piddle instead. =head2 shape =for ref Return piddle dimensions as a piddle =for usage $shape = $piddle->shape; $shape = shape($piddle); =for example pdl> p $shape = shape zeroes 10,3,22 [10 3 22] See also L which returns a perl list. =head2 ndims =for ref Returns the number of dimensions in a piddle. Alias for L. =head2 getndims =for ref Returns the number of dimensions in a piddle =for usage $ndims = $piddle->getndims; =for example pdl> p zeroes(10,3,22)->getndims 3 =head2 dim =for ref Returns the size of the given dimension of a piddle. Alias for L. =head2 getdim =for ref Returns the size of the given dimension. =for usage $dim0 = $piddle->getdim(0); =for example pdl> p zeroes(10,3,22)->getdim(1) 3 Negative indices count from the end of the dims array. Indices beyond the end will return a size of 1. This reflects the idea that any pdl is equivalent to an infinitely dimensional array in which only a finite number of dimensions have a size different from one. For example, in that sense a 3D piddle of shape [3,5,2] is equivalent to a [3,5,2,1,1,1,1,1,....] piddle. Accordingly, print $a->getdim(10000); will print 1 for most practically encountered piddles. =head2 topdl =for ref alternate piddle constructor - ensures arg is a piddle =for usage $a = topdl(SCALAR|ARRAY REFERENCE|ARRAY); The difference between L and C is that the latter will just 'fall through' if the argument is already a piddle. It will return a reference and I a new copy. This is particularly useful if you are writing a function which is doing some fiddling with internals and assumes a piddle argument (e.g. for method calls). Using C will ensure nothing breaks if passed with '2'. Note that C is not exported by default (see example below for usage). =for example use PDL::Core ':Internal'; # use the internal routines of # the Core module $a = topdl 43; # $a is piddle with value '43' $b = topdl $piddle; # fall through $a = topdl (1,2,3,4); # Convert 1D array =head2 get_datatype =for ref Internal: Return the numeric value identifying the piddle datatype =for usage $x = $piddle->get_datatype; Mainly used for internal routines. NOTE: get_datatype returns 'just a number' not any special type object, unlike L. =head2 howbig =for ref Returns the sizeof a piddle datatype in bytes. Note that C is not exported by default (see example below for usage). =for usage use PDL::Core ':Internal'; # use the internal routines of # the Core module $size = howbig($piddle->get_datatype); Mainly used for internal routines. NOTE: NOT a method! This is because get_datatype returns 'just a number' not any special object. =for example pdl> p howbig(ushort([1..10])->get_datatype) 2 =head2 get_dataref =for ref Return the internal data for a piddle, as a perl SCALAR ref. Most piddles hold their internal data in a packed perl string, to take advantage of perl's memory management. This gives you direct access to the string, which is handy when you need to manipulate the binary data directly (e.g. for file I/O). If you modify the string, you'll need to call L afterward, to make sure that the piddle points to the new location of the underlying perl variable. Calling C automatically physicalizes your piddle (see L). You definitely don't want to do anything to the SV to truncate or deallocate the string, unless you correspondingly call L to make the PDL match its new data dimension. You definitely don't want to use get_dataref unless you know what you are doing (or are trying to find out): you can end up scrozzling memory if you shrink or eliminate the string representation of the variable. Here be dragons. =head2 upd_data =for ref Update the data pointer in a piddle to match its perl SV. This is useful if you've been monkeying with the packed string representation of the PDL, which you probably shouldn't be doing anyway. (see L.) =cut sub topdl {PDL->topdl(@_)} ####################### Overloaded operators ####################### # This is to used warn if an operand is non-numeric or non-PDL. sub warn_non_numeric_op_wrapper { my ($cb, $op_name) = @_; return sub { my ($op1, $op2) = @_; unless( Scalar::Util::looks_like_number($op2) || ( Scalar::Util::blessed($op2) && $op2->isa('PDL') ) ) { warn "'$op2' is not numeric nor a PDL in operator $op_name"; }; $cb->(@_); } } { package PDL; # use UNIVERSAL 'isa'; # need that later in info function use Carp; use overload ( "+" => \&PDL::plus, # in1, in2 "*" => \&PDL::mult, # in1, in2 "-" => \&PDL::minus, # in1, in2, swap if true "/" => \&PDL::divide, # in1, in2, swap if true "+=" => sub { PDL::plus ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "*=" => sub { PDL::mult ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "-=" => sub { PDL::minus ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "/=" => sub { PDL::divide ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true ">" => \&PDL::gt, # in1, in2, swap if true "<" => \&PDL::lt, # in1, in2, swap if true "<=" => \&PDL::le, # in1, in2, swap if true ">=" => \&PDL::ge, # in1, in2, swap if true "==" => \&PDL::eq, # in1, in2 "eq" => PDL::Core::warn_non_numeric_op_wrapper(\&PDL::eq, 'eq'), # in1, in2 "!=" => \&PDL::ne, # in1, in2 "<<" => \&PDL::shiftleft, # in1, in2, swap if true ">>" => \&PDL::shiftright, # in1, in2, swap if true "|" => \&PDL::or2, # in1, in2 "&" => \&PDL::and2, # in1, in2 "^" => \&PDL::xor, # in1, in2 "<<=" => sub { PDL::shiftleft ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true ">>=" => sub { PDL::shiftright($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "|=" => sub { PDL::or2 ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "&=" => sub { PDL::and2 ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "^=" => sub { PDL::xor ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "**=" => sub { PDL::power ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "%=" => sub { PDL::modulo ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true "sqrt" => sub { PDL::sqrt ($_[0]); }, "abs" => sub { PDL::abs ($_[0]); }, "sin" => sub { PDL::sin ($_[0]); }, "cos" => sub { PDL::cos ($_[0]); }, "!" => sub { PDL::not ($_[0]); }, "~" => sub { PDL::bitnot ($_[0]); }, "log" => sub { PDL::log ($_[0]); }, "exp" => sub { PDL::exp ($_[0]); }, "**" => \&PDL::power, # in1, in2, swap if true "atan2" => \&PDL::atan2, # in1, in2, swap if true "%" => \&PDL::modulo, # in1, in2, swap if true "<=>" => \&PDL::spaceship, # in1, in2, swap if true "=" => sub {$_[0]}, # Don't deep copy, just copy reference ".=" => sub { my @args = reverse &PDL::Core::rswap; PDL::Ops::assgn(@args); return $args[1]; }, 'x' => sub{my $foo = $_[0]->null(); PDL::Primitive::matmult(@_[0,1],$foo); $foo;}, 'bool' => sub { return 0 if $_[0]->isnull; croak("multielement piddle in conditional expression (see PDL::FAQ questions 6-10 and 6-11)") unless $_[0]->nelem == 1; $_[0]->clump(-1)->at(0); }, "\"\"" => \&PDL::Core::string ); } sub rswap { if($_[2]) { return @_[1,0]; } else { return @_[0,1]; } } ##################### Data type/conversion stuff ######################## # XXX Optimize! sub PDL::dims { # Return dimensions as @list my $pdl = PDL->topdl (shift); my @dims = (); for(0..$pdl->getndims()-1) {push @dims,($pdl->getdim($_))} return @dims; } sub PDL::shape { # Return dimensions as a pdl my $pdl = PDL->topdl (shift); my @dims = (); for(0..$pdl->getndims()-1) {push @dims,($pdl->getdim($_))} return indx(\@dims); } sub PDL::howbig { my $t = shift; if("PDL::Type" eq ref $t) {$t = $t->[0]} PDL::howbig_c($t); } =head2 threadids =for ref Returns the piddle thread IDs as a perl list Note that C is not exported by default (see example below for usage). =for usage use PDL::Core ':Internal'; # use the internal routines of # the Core module @ids = threadids $piddle; =cut sub PDL::threadids { # Return dimensions as @list my $pdl = PDL->topdl (shift); my @dims = (); for(0..$pdl->getnthreadids()) {push @dims,($pdl->getthreadid($_))} return @dims; } ################# Creation/copying functions ####################### sub PDL::pdl { my $x = shift; return $x->new(@_) } =head2 doflow =for ref Turn on/off dataflow =for usage $x->doflow; doflow($x); =cut sub PDL::doflow { my $this = shift; $this->set_dataflow_f(1); $this->set_dataflow_b(1); } =head2 flows =for ref Whether or not a piddle is indulging in dataflow =for usage something if $x->flows; $hmm = flows($x); =cut sub PDL::flows { my $this = shift; return ($this->fflows || $this->bflows); } =head2 new =for ref new piddle constructor method =for usage $x = PDL->new(SCALAR|ARRAY|ARRAY REF|STRING); =for example $x = PDL->new(42); # new from a Perl scalar $x = new PDL 42; # ditto $y = PDL->new(@list_of_vals); # new from Perl list $y = new PDL @list_of_vals; # ditto $z = PDL->new(\@list_of_vals); # new from Perl list reference $w = PDL->new("[1 2 3]"); # new from Perl string, using # Matlab constructor syntax Constructs piddle from perl numbers and lists and strings with Matlab/Octave style constructor syntax. The string input is fairly versatile though not performance optimized. The goal is to make it easy to copy and paste code from PDL output and to offer a familiar Matlab syntax for piddle construction. As of May, 2010, it is a new feature, so feel free to report bugs or suggest new features. See documentation for L for more examples of usage. =cut use Scalar::Util; # for looks_like_number test use Carp 'carp'; # for carping (warnings in caller's context) # This is the code that handles string arguments. It has now gotten quite large, # so here's the basic explanation. I want to allow expressions like 2, 1e3, +4, # bad, nan, inf, and more. Checking this can get tricky. This croaks when it # finds: # 1) strings of e or E that are longer than 1 character long (like eeee) # 2) non-supported characters or strings # 3) expressions that are syntactically erroneous, like '1 2 3 ]', which has an # extra bracket # 4) use of inf when the data type does not support inf (i.e. the integers) sub PDL::Core::new_pdl_from_string { my ($new, $original_value, $this, $type) = @_; my $value = $original_value; # Check for input that would generate empty piddles as output: my @types = PDL::Types::types; return zeroes($types[$type], 1)->where(zeroes(1) < 0) if ($value eq '' or $value eq '[]'); # I check for invalid characters later, but arbitrary strings of e will # pass that check, so I'll check for that here, first. # croak("PDL::Core::new_pdl_from_string: I found consecutive copies of e but\n" # . " I'm not sure what you mean. You gave me $original_value") # if ($value =~ /ee/i); croak("PDL::Core::new_pdl_from_string: found 'e' as part of a larger word in $original_value") if $value =~ /e\p{IsAlpha}/ or $value =~ /\p{IsAlpha}e/; # Only a few characters are allowed in the expression, but we want to allow # expressions like 'inf' and 'bad'. As such, convert those values to internal # representations that will pass the invalid-character check. We'll replace # them with Perl-evalute-able strings in a little bit. Here, I represent # bad => EE # nan => ee # inf => Ee # pi => eE # --( Bad )-- croak("PDL::Core::new_pdl_from_string: found 'bad' as part of a larger word in $original_value") if $value =~ /bad\B/ or $value =~ /\Bbad/; my ($has_bad) = ($value =~ s/\bbad\b/EE/gi); # --( nan )-- my ($has_nan) = 0; croak("PDL::Core::new_pdl_from_string: found 'nan' as part of a larger word in $original_value") if $value =~ /\Bnan/ or $value =~ /nan\B/; $has_nan++ if ($value =~ s/\bnan\b/ee/gi); # Strawberry Perl compatibility: croak("PDL::Core::new_pdl_from_string: found '1.#IND' as part of a larger word in $original_value") if $value =~ /IND\B/i; $has_nan++ if ($value =~ s/1\.\#IND/ee/gi); # --( inf )-- my ($has_inf) = 0; # Strawberry Perl compatibility: croak("PDL::Core::new_pdl_from_string: found '1.#INF' as part of a larger word in $original_value") if $value =~ /INF\B/i; $has_inf++ if ($value =~ s/1\.\#INF/Ee/gi); # Other platforms: croak("PDL::Core::new_pdl_from_string: found 'inf' as part of a larger word in $original_value") if $value =~ /inf\B/ or $value =~ /\Binf/; $has_inf++ if ($value =~ s/\binf\b/Ee/gi); # --( pi )-- croak("PDL::Core::new_pdl_from_string: found 'pi' as part of a larger word in $original_value") if $value =~ /pi\B/ or $value =~ /\Bpi/; $value =~ s/\bpi\b/eE/gi; # Some data types do not support nan and inf, so check for and warn or croak, # as appropriate: if ($has_nan and not $types[$type]->usenan) { carp("PDL::Core::new_pdl_from_string: no nan for type $types[$type]; converting to bad value"); $value =~ s/ee/EE/g; $has_bad += $has_nan; $has_nan = 0; } croak("PDL::Core::new_pdl_from_string: type $types[$type] does not support inf") if ($has_inf and not $types[$type]->usenan); # Make the white-space uniform and see if any not-allowed characters are # present: $value =~ s/\s+/ /g; if (my ($disallowed) = ($value =~ /([^\[\]\+\-0-9;,.eE ]+)/)) { croak("PDL::Core::new_pdl_from_string: found disallowed character(s) '$disallowed' in $original_value"); } # Wrap the string in brackets [], so that the following works: # $a = new PDL q[1 2 3]; # We'll have to check for dimensions of size one after we've parsed # the string and built a PDL from the resulting array. $value = '[' . $value . ']'; # Make sure that each closing bracket followed by an opening bracket # has a comma in between them: $value =~ s/\]\s*\[/],[/g; # Semicolons indicate 'start a new row' and require special handling: if ($value =~ /;/) { $value =~ s/(\[[^\]]+;[^\]]+\])/[$1]/g; $value =~ s/;/],[/g; } # Remove ending decimal points and insert zeroes in front of starting # decimal points. This makes the white-space-to-comma replacement # in the next few lines much simpler. $value =~ s/(\d\.)(z|[^\d])/${1}0$2/g; $value =~ s/(\A|[^\d])\./${1}0./g; # Remove whitspace between signs and the numbers that follow them: $value =~ s/([+\-])\s+/$1/g; # # make unambiguous addition/subtraction (white-space on both sides # # of operator) by removing white-space from both sides # $value =~ s/([\dEe])\s+([+\-])\s+(?=[Ee\d])/$1$2/g; # Replace white-space separators with commas: $value =~ s/([.\deE])\s+(?=[+\-eE\d])/$1,/g; # Remove all other white space: $value =~ s/\s+//g; # Croak on operations with bad values. It might be nice to simply replace # these with bad values, but that is more difficult that I like, so I'm just # going to disallow that here: croak("PDL::Core::new_pdl_from_string: Operations with bad values are not supported") if($value =~ /EE[+\-]/ or $value =~ /[+\-]EE/); # Check for things that will evaluate as functions and croak if found if (my ($disallowed) = ($value =~ /((\D+|\A)[eE]\d+)/)) { croak("PDL::Core::new_pdl_from_string: syntax error, looks like an improper exponentiation: $disallowed\n" . "You originally gave me $original_value\n"); } # Replace the place-holder strings with strings that will evaluate to their # correct numerical values when we run the eval: $value =~ s/\bEE\b/bad/g; my $bad = $types[$type]->badvalue; $value =~ s/\bee\b/nan/g; my $inf = -pdl(0)->log; $value =~ s/\bEe\b/inf/g; my $nnan = $inf - $inf; my $nan= $this->initialize(); $nan->set_datatype($nnan->get_datatype); $nan->setdims([]); # pack("d*", "nan") will work here only on perls that numify the string "nan" to a NaN. # pack( "d*", (-1.0) ** 0.5 ) will hopefully work in more places, though it seems both # pack("d*", "nan") and pack( "d*", (-1.0) ** 0.5 ) fail on *old* MS Compilers (MSVC++ 6.0 and earlier). # sisyphus 4 Jan 2013. ${$nan->get_dataref} = pack( "d*", (-1.0) ** 0.5 ); $nan->upd_data(); $value =~ s/\beE\b/pi/g; my $val = eval { # Install the warnings handler: my $old_warn_handler = $SIG{__WARN__}; local $SIG{__WARN__} = sub { if ($_[0] =~ /(Argument ".*" isn't numeric)/) { # Send the error through die. This is *always* get caught, so keep # it simple. die "Incorrectly formatted input: $1\n"; } elsif ($old_warn_handler) { $old_warn_handler->(@_); } else { warn @_; } }; # Let's see if we can parse it as an array-of-arrays: local $_ = $value; return PDL::Core::parse_basic_string ($inf, $nan, $nnan, $bad); }; # Respect BADVAL_USENAN require PDL::Config; $has_bad += $has_inf + $has_nan if $PDL::Config{BADVAL_USENAN}; if (ref $val eq 'ARRAY') { my $to_return = PDL::Core::pdl_avref($val,$this,$type); if( $to_return->dim(-1) == 1 ) { if( $to_return->dims > 1 ) { # remove potentially spurious last dimension $to_return = $to_return->mv(-1,1)->clump(2)->sever; } elsif( $to_return->dims == 1 ) { # fix scalar values $to_return->setdims([]); } } # Mark bad if appropriate $to_return->badflag($has_bad > 0); return $to_return; } else { my @message = ("PDL::Core::new_pdl_from_string: string input='$original_value', string output='$value'" ); if ($@) { push @message, $@; } else { push @message, "Internal error: unexpected output type ->$val<- is not ARRAY ref"; } croak join("\n ", @message); } } sub PDL::Core::parse_basic_string { # Assumes $_ holds the string of interest, and modifies that value # in-place. use warnings; # Takes a string with proper bracketing, etc, and returns an array-of-arrays # filled with numbers, suitable for use with pdl_avref. It uses recursive # descent to handle the nested nature of the data. The string should have # no whitespace and should be something that would evaluate into a Perl # array-of-arrays (except that strings like 'inf', etc, are allowed). my ($inf, $nan, $nnan, $bad) = @_; # First character should be a bracket: die "Internal error: input string -->$_<-- did not start with an opening bracket\n" unless s/^\[//; my @to_return; # Loop until we run into our closing bracket: my $sign = 1; my $expects_number = 0; SYMBOL: until (s/^\]//) { # If we have a bracket, then go recursive: if (/^\[/) { die "Expected a number but found a bracket at ... ", substr ($_, 0, 10), "...\n" if $expects_number; push @to_return, PDL::Core::parse_basic_string(@_); next SYMBOL; } elsif (s/^\+//) { die "Expected number but found a plus sign at ... ", substr ($_, 0, 10), "...\n" if $expects_number; $expects_number = 1; redo SYMBOL; } elsif (s/^\-//) { die "Expected number but found a minus sign at ... ", substr ($_, 0, 10), "...\n" if $expects_number; $sign = -1; $expects_number = 1; redo SYMBOL; } elsif (s/^bad//i) { push @to_return, $bad; } elsif (s/^inf//i or s/1\.\#INF//i) { push @to_return, $sign * $inf; } elsif (s/^nan//i or s/^1\.\#IND//i) { if ($sign == -1) { push @to_return, $nnan; } else { push @to_return, $nan; } } elsif (s/^pi//i) { push @to_return, $sign * 4 * atan2(1, 1); } elsif (s/^e//i) { push @to_return, $sign * exp(1); } elsif (s/^([\d+\-e.]+)//i) { # Note that improper numbers are handled by the warning signal # handler my $val = $1; my $nval = $val + 0x0; push @to_return, ($sign>0x0) ? $nval : -$nval; } else { die "Incorrectly formatted input at:\n ", substr ($_, 0, 10), "...\n"; } } # Strip off any commas continue { $sign = 1; $expects_number = 0; s/^,//; } return \@to_return; } sub PDL::new { # print "in PDL::new\n"; my $this = shift; return $this->copy if ref($this); my $type = ref($_[0]) eq 'PDL::Type' ? ${shift @_}[0] : $PDL_D; my $value = (@_ >1 ? [@_] : shift); # ref thyself unless(defined $value) { if($PDL::debug && $PDL::undefval) { print STDERR "Warning: PDL::new converted undef to $PDL::undefval ($PDL::undefval)\n"; } $value = $PDL::undefval+0 } return pdl_avref($value,$this,$type) if ref($value) eq "ARRAY"; my $new = $this->initialize(); $new->set_datatype($type); if (ref(\$value) eq "SCALAR") { # The string processing is extremely slow. Benchmarks indicated that it # takes 10x longer to process a scalar number compared with normal Perl # conversion of a string to a number. So, only use the string processing # if the input looks like a real string, i.e. it doesn't look like a plain # number. Note that for our purposes, looks_like_number incorrectly # handles the strings 'inf' and 'nan' on Windows machines. We want to send # those to the string processing, so this checks for them in a way that # short-circuits the looks_like_number check. if (PDL::Core::is_scalar_SvPOK($value) and ($value =~ /inf/i or $value =~ /nan/i or !Scalar::Util::looks_like_number($value))) { # new was passed a string argument that doesn't look like a number # so we can process as a Matlab-style data entry format. return PDL::Core::new_pdl_from_string($new,$value,$this,$type); } elsif ($Config{ivsize} < 8 && $pack[$new->get_datatype] eq 'q*') { # special case when running on a perl without 64bit int support # we have to avoid pack("q", ...) in this case # because it dies with error: "Invalid type 'q' in pack" $new->setdims([]); set_c($new, [0], $value); } else { $new->setdims([]); ${$new->get_dataref} = pack( $pack[$new->get_datatype], $value ); $new->upd_data(); } } elsif (blessed($value)) { # Object $new = $value->copy; } else { barf("Can not interpret argument $value of type ".ref($value) ); } return $new; } =head2 copy =for ref Make a physical copy of a piddle =for usage $new = $old->copy; Since C<$new = $old> just makes a new reference, the C method is provided to allow real independent copies to be made. =cut # Inheritable copy method # # XXX Must be fixed # Inplace is handled by the op currently. sub PDL::copy { my $value = shift; barf("Argument is an ".ref($value)." not an object") unless blessed($value); my $option = shift; $option = "" if !defined $option; if ($value->is_inplace) { # Copy protection $value->set_inplace(0); return $value; } # threadI(-1,[]) is just an identity vafftrans with threadId copying ;) my $new = $value->threadI(-1,[])->sever; return $new; } =head2 hdr_copy =for ref Return an explicit copy of the header of a PDL. hdr_copy is just a wrapper for the internal routine _hdr_copy, which takes the hash ref itself. That is the routine which is used to make copies of the header during normal operations if the hdrcpy() flag of a PDL is set. General-purpose deep copies are expensive in perl, so some simple optimization happens: If the header is a tied array or a blessed hash ref with an associated method called C, then that ->copy method is called. Otherwise, all elements of the hash are explicitly copied. References are recursively deep copied. This routine seems to leak memory. =cut sub PDL::hdr_copy { my $pdl = shift; my $hdr = $pdl->gethdr; return PDL::_hdr_copy($hdr); } # Same as hdr_copy but takes a hash ref instead of a PDL. sub PDL::_hdr_copy { my $hdr = shift; my $tobj; print "called _hdr_copy\n" if($PDL::debug); unless( (ref $hdr)=~m/HASH/ ) { print"returning undef\n" if($PDL::debug); return undef ; } if($tobj = tied %$hdr) { # print "tied..."if($PDL::debug); if(UNIVERSAL::can($tobj,"copy")) { my %rhdr; tie(%rhdr, ref $tobj, $tobj->copy); print "returning\n" if($PDL::debug); return \%rhdr; } # Astro::FITS::Header is special for now -- no copy method yet # but it is recognized. Once it gets a copy method this will become # vestigial: if(UNIVERSAL::isa($tobj,"Astro::FITS::Header")) { print "Astro::FITS::Header..." if($PDL::debug); my @cards = $tobj->cards; my %rhdr; tie(%rhdr,"Astro::FITS::Header", new Astro::FITS::Header(Cards=>\@cards)); print "returning\n" if($PDL::debug); return \%rhdr; } } elsif(UNIVERSAL::can($hdr,"copy")) { print "found a copy method\n" if($PDL::debug); return $hdr->copy; } # We got here if it's an unrecognized tie or if it's a vanilla hash. print "Making a hash copy..." if($PDL::debug); return PDL::_deep_hdr_copy($hdr); } # # Sleazy deep-copier that gets most cases # --CED 14-April-2003 # sub PDL::_deep_hdr_copy { my $val = shift; if(ref $val eq 'HASH') { my (%a,$key); for $key(keys %$val) { my $value = $val->{$key}; $a{$key} = (ref $value) ? PDL::_deep_hdr_copy($value) : $value; } return \%a; } if(ref $val eq 'ARRAY') { my (@a,$z); for $z(@$val) { push(@a,(ref $z) ? PDL::_deep_hdr_copy($z) : $z); } return \@a; } if(ref $val eq 'SCALAR') { my $a = $$val; return \$a; } if(ref $val eq 'REF') { my $a = PDL::_deep_hdr_copy($$val); return \$a; } # Special case for PDLs avoids potential nasty header recursion... if(UNIVERSAL::isa($val,'PDL')) { my $h; $val->hdrcpy(0) if($h = $val->hdrcpy); # assignment my $out = $val->copy; $val->hdrcpy($h) if($h); return $out; } if(UNIVERSAL::can($val,'copy')) { return $val->copy; } $val; } =head2 unwind =for ref Return a piddle which is the same as the argument except that all threadids have been removed. =for usage $y = $x->unwind; =head2 make_physical =for ref Make sure the data portion of a piddle can be accessed from XS code. =for example $a->make_physical; $a->call_my_xs_method; Ensures that a piddle gets its own allocated copy of data. This obviously implies that there are certain piddles which do not have their own data. These are so called I piddles that make use of the I optimisation (see L). They do not have their own copy of data but instead store only access information to some (or all) of another piddle's data. Note: this function should not be used unless absolutely necessary since otherwise memory requirements might be severly increased. Instead of writing your own XS code with the need to call C you might want to consider using the PDL preprocessor (see L) which can be used to transparently access virtual piddles without the need to physicalise them (though there are exceptions). =cut sub PDL::unwind { my $value = shift; my $foo = $value->null(); $foo .= $value->unthread(); return $foo; } =head2 dummy =for ref Insert a 'dummy dimension' of given length (defaults to 1) No relation to the 'Dungeon Dimensions' in Discworld! Negative positions specify relative to last dimension, i.e. C appends one dimension at end, C inserts a dummy dimension in front of the last dim, etc. If you specify a dimension position larger than the existing dimension list of your PDL, the PDL gets automagically padded with extra dummy dimensions so that you get the dim you asked for, in the slot you asked for. This could cause you trouble if, for example, you ask for $a->dummy(5000,1) because $a will get 5,000 dimensions, each of rank 1. Because padding at the beginning of the dimension list moves existing dimensions from slot to slot, it's considered unsafe, so automagic padding doesn't work for large negative indices -- only for large positive indices. =for usage $y = $x->dummy($position[,$dimsize]); =for example pdl> p sequence(3)->dummy(0,3) [ [0 0 0] [1 1 1] [2 2 2] ] pdl> p sequence(3)->dummy(3,2) [ [ [0 1 2] ] [ [0 1 2] ] ] pdl> p sequence(3)->dummy(-3,2) Runtime error: PDL: For safety, < -(dims+1) forbidden in dummy. min=-2, pos=-3 =cut sub PDL::dummy($$;$) { my ($pdl,$dim,$size) = @_; barf("Missing position argument to dummy()") unless defined $dim; # required argument $dim = $pdl->getndims+1+$dim if $dim < 0; $size = defined($size) ? (1 * $size) : 1; # make $size a number (sf feature # 3479009) barf("For safety, < -(dims+1) forbidden in dummy. min=" . -($pdl->getndims+1).", pos=". ($dim-1-$pdl->getndims) ) if($dim<0); # Avoid negative repeat count warning that came with 5.21 and later. my $dim_diff = $dim - $pdl->getndims; my($s) = ',' x ( $dim_diff > 0 ? $pdl->getndims : $dim ); $s .= '*1,' x ( $dim_diff > 0 ? $dim_diff : 0 ); $s .= "*$size"; $pdl->slice($s); } ## Cheesy, slow way # while ($dim>$pdl->getndims){ # print STDERR "."; flush STDERR; # $pdl = $pdl->dummy($pdl->getndims,1); # } # # barf ("too high/low dimension in call to dummy, allowed min/max=0/" # . $_[0]->getndims) # if $dim>$pdl->getndims || $dim < 0; # # $_[2] = 1 if ($#_ < 2); # $pdl->slice((','x$dim)."*$_[2]"); =head2 clump =for ref "clumps" several dimensions into one large dimension If called with one argument C<$n> clumps the first C<$n> dimensions into one. For example, if C<$a> has dimensions C<(5,3,4)> then after =for example $b = $a->clump(2); # Clump 2 first dimensions the variable C<$b> will have dimensions C<(15,4)> and the element C<$b-Eat(7,3)> refers to the element C<$a-Eat(1,2,3)>. Use C to flatten a piddle. The method L is provided as a convenient alias. Clumping with a negative dimension in general leaves that many dimensions behind -- e.g. clump(-2) clumps all of the first few dimensions into a single one, leaving a 2-D piddle. If C is called with an index list with more than one element it is treated as a list of dimensions that should be clumped together into one. The resulting clumped dim is placed at the position of the lowest index in the list. This convention ensures that C does the expected thing in the usual cases. The following example demonstrates typical usage: $a = sequence 2,3,3,3,5; # 5D piddle $c = $a->clump(1..3); # clump all the dims 1 to 3 into one print $c->info; # resulting 3D piddle has clumped dim at pos 1 PDL: Double D [2,27,5] =cut sub PDL::clump { my $ndims = $_[0]->getndims; if ($#_ < 2) { return &PDL::_clump_int(@_); } else { my ($this,@dims) = @_; my $targd = $ndims-1; my @dimmark = (0..$ndims-1); barf "too many dimensions" if @dims > $ndims; for my $dim (@dims) { barf "dimension index $dim larger than greatest dimension" if $dim > $ndims-1 ; $targd = $dim if $targd > $dim; barf "duplicate dimension $dim" if $dimmark[$dim]++ > $dim; } my $clumped = $this->thread(@dims)->unthread(0)->clump(scalar @dims); $clumped = $clumped->mv(0,$targd) if $targd > 0; return $clumped; } } =head2 thread_define =for ref define functions that support threading at the perl level =for example thread_define 'tline(a(n);b(n))', over { line $_[0], $_[1]; # make line compliant with threading }; C provides some support for threading (see L) at the perl level. It allows you to do things for which you normally would have resorted to PDL::PP (see L); however, it is most useful to wrap existing perl functions so that the new routine supports PDL threading. C is used to define new I functions. Its first argument is a symbolic repesentation of the new function to be defined. The string is composed of the name of the new function followed by its signature (see L and L) in parentheses. The second argument is a subroutine that will be called with the slices of the actual runtime arguments as specified by its signature. Correct dimension sizes and minimal number of dimensions for all arguments will be checked (assuming the rules of PDL threading, see L). The actual work is done by the C class which parses the signature string, does runtime dimension checks and the routine C that generates the loop over all appropriate slices of pdl arguments and creates pdls as needed. Similar to C and its C option it is possible to define the new function so that it accepts normal perl args as well as piddles. You do this by using the C parameter in the signature. The number of C specified will be passed unaltered into the subroutine given as the second argument of C. Let's illustrate this with an example: PDL::thread_define 'triangles(inda();indb();indc()), NOtherPars => 2', PDL::over { ${$_[3]} .= $_[4].join(',',map {$_->at} @_[0..2]).",-1,\n"; }; This defines a function C that takes 3 piddles as input plus 2 arguments which are passed into the routine unaltered. This routine is used to collect lists of indices into a perl scalar that is passed by reference. Each line is preceded by a prefix passed as C<$_[4]>. Here is typical usage: $txt = ''; triangles(pdl(1,2,3),pdl(1),pdl(0),\$txt," "x10); print $txt; resulting in the following output 1,1,0,-1, 2,1,0,-1, 3,1,0,-1, which is used in L to generate VRML output. Currently, this is probably not much more than a POP (proof of principle) but is hoped to be useful enough for some real life work. Check L for the format of the signature. Currently, the C<[t]> qualifier and all type qualifiers are ignored. =cut sub PDL::over (&) { $_[0] } sub PDL::thread_define ($$) { require PDL::PP::Signature; my ($str,$sub) = @_; my $others = 0; if ($str =~ s/[,]*\s*NOtherPars\s*=>\s*([0-9]+)\s*[,]*//) {$others = $1} barf "invalid string $str" unless $str =~ /\s*([^(]+)\((.+)\)\s*$/x; my ($name,$sigstr) = ($1,$2); print "defining '$name' with signature '$sigstr' and $others extra args\n" if $PDL::debug; my $sig = new PDL::PP::Signature($sigstr); my $args = @{$sig->names}; # number of piddle arguments barf "no piddle args" if $args == 0; $args--; # TODO: $sig->dimcheck(@_) + proper creating generation my $def = "\@_[0..$args] = map {PDL::Core::topdl(\$_)} \@_[0..$args];\n". '$sig->checkdims(@_); PDL::threadover($others,@_,$sig->realdims,$sig->creating,$sub)'; my $package = caller; local $^W = 0; # supress the 'not shared' warnings print "defining...\nsub $name { $def }\n" if $PDL::debug; eval ("package $package; sub $name { $def }"); barf "error defining $name: $@\n" if $@; } =head2 thread =for ref Use explicit threading over specified dimensions (see also L) =for usage $b = $a->thread($dim,[$dim1,...]) =for example $a = zeroes 3,4,5; $b = $a->thread(2,0); Same as L, i.e. uses thread id 1. =cut sub PDL::thread { my $var = shift; $var->threadI(1,\@_); } =head2 diagonal =for ref Returns the multidimensional diagonal over the specified dimensions. =for usage $d = $x->diagonal(dim1, dim2,...) =for example pdl> $a = zeroes(3,3,3); pdl> ($b = $a->diagonal(0,1))++; pdl> p $a [ [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] ] =cut sub PDL::diagonal { my $var = shift; $var->diagonalI(\@_); } =head2 thread1 =for ref Explicit threading over specified dims using thread id 1. =for usage $xx = $x->thread1(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::thread1 { my $var = shift; $var->threadI(1,\@_); } =head2 thread2 =for ref Explicit threading over specified dims using thread id 2. =for usage $xx = $x->thread2(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::thread2 { my $var = shift; $var->threadI(2,\@_); } =head2 thread3 =for ref Explicit threading over specified dims using thread id 3. =for usage $xx = $x->thread3(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::thread3 { my $var = shift; $var->threadI(3,\@_); } my %info = ( D => { Name => 'Dimension', Sub => \&PDL::Core::dimstr, }, T => { Name => 'Type', Sub => sub { return $_[0]->type->shortctype; }, }, S => { Name => 'State', Sub => sub { my $state = ''; $state .= 'P' if $_[0]->allocated; $state .= 'V' if $_[0]->vaffine && !$_[0]->allocated; # apparently can be both? $state .= '-' if $state eq ''; # lazy eval $state .= 'C' if $_[0]->anychgd; $state .= 'B' if $_[0]->badflag; $state; }, }, F => { Name => 'Flow', Sub => sub { my $flows = ''; $flows = ($_[0]->bflows ? 'b':'') . '~' . ($_[0]->fflows ? 'f':'') if ($_[0]->flows); $flows; }, }, M => { Name => 'Mem', Sub => sub { my ($size,$unit) = ($_[0]->allocated ? $_[0]->nelem* PDL::howbig($_[0]->get_datatype)/1024 : 0, 'KB'); if ($size > 0.01*1024) { $size /= 1024; $unit = 'MB' }; return sprintf "%6.2f%s",$size,$unit; }, }, C => { Name => 'Class', Sub => sub { ref $_[0] } }, A => { Name => 'Address', Sub => sub { use Config; my $ivdformat = $Config{ivdformat}; $ivdformat =~ s/"//g; sprintf "%$ivdformat", $_[0]->address } }, ); my $allowed = join '',keys %info; # print the dimension information about a pdl in some appropriate form sub dimstr { my $this = shift; my @dims = $this->dims; my @ids = $this->threadids; my ($nids,$i) = ($#ids - 1,0); my $dstr = 'D ['. join(',',@dims[0..($ids[0]-1)]) .']'; if ($nids > 0) { for $i (1..$nids) { $dstr .= " T$i [". join(',',@dims[$ids[$i]..$ids[$i+1]-1]) .']'; } } return $dstr; } =head2 sever =for ref sever any links of this piddle to parent piddles In PDL it is possible for a piddle to be just another view into another piddle's data. In that case we call this piddle a I and the original piddle owning the data its parent. In other languages these alternate views sometimes run by names such as I or I. Typical functions that return such piddles are C, C, C, etc. Sometimes, however, you would like to separate the I from its parent's data and just give it a life of its own (so that manipulation of its data doesn't change the parent). This is simply achieved by using C. For example, =for example $a = $pdl->index(pdl(0,3,7))->sever; $a++; # important: $pdl is not modified! In many (but not all) circumstances it acts therefore similar to L. However, in general performance is better with C and secondly, C doesn't lead to futile copying when used on piddles that already have their own data. On the other hand, if you really want to make sure to work on a copy of a piddle use L. $a = zeroes(20); $a->sever; # NOOP since $a is already its own boss! Again note: C I the same as L! For example, $a = zeroes(1); # $a does not have a parent, i.e. it is not a slice etc $b = $a->sever; # $b is now pointing to the same piddle as $a $b++; print $a; [1] but $a = zeroes(1); $b = $a->copy; # $b is now pointing to a new piddle $b++; print $a; [0] =head2 info =for ref Return formatted information about a piddle. =for usage $x->info($format_string); =for example print $x->info("Type: %T Dim: %-15D State: %S"); Returns a string with info about a piddle. Takes an optional argument to specify the format of information a la sprintf. Format specifiers are in the form C<%EwidthEEletterE> where the width is optional and the letter is one of =over 7 =item T Type =item D Formatted Dimensions =item F Dataflow status =item S Some internal flags (P=physical,V=Vaffine,C=changed,B=may contain bad data) =item C Class of this piddle, i.e. C =item A Address of the piddle struct as a unique identifier =item M Calculated memory consumption of this piddle's data area =back =cut sub PDL::info { my ($this,$str) = @_; $str = "%C: %T %D" unless defined $str; return ref($this)."->null" if $this->isnull; my @hash = split /(%[-,0-9]*[.]?[0-9]*\w)/, $str; my @args = (); my $nstr = ''; for my $form (@hash) { if ($form =~ s/^%([-,0-9]*[.]?[0-9]*)(\w)$/%$1s/) { barf "unknown format specifier $2" unless defined $info{$2}; push @args, &{$info{$2}->{Sub}}($this); } $nstr .= $form; } return sprintf $nstr, @args; } =head2 approx =for ref test for approximately equal values (relaxed C<==>) =for example # ok if all corresponding values in # piddles are within 1e-8 of each other print "ok\n" if all approx $a, $b, 1e-8; C is a relaxed form of the C<==> operator and often more appropriate for floating point types (C and C). Usage: =for usage $res = approx $a, $b [, $eps] The optional parameter C<$eps> is remembered across invocations and initially set to 1e-6, e.g. approx $a, $b; # last $eps used (1e-6 initially) approx $a, $b, 1e-10; # 1e-10 approx $a, $b; # also 1e-10 =cut my $approx = 1e-6; # a reasonable init value sub PDL::approx { my ($a,$b,$eps) = @_; $eps = $approx unless defined $eps; # the default eps $approx = $eps; # remember last eps # NOTE: ($a-$b)->abs breaks for non-piddle inputs return abs($a-$b) < $eps; } =head2 mslice =for ref Convenience interface to L, allowing easier inclusion of dimensions in perl code. =for usage $a = $x->mslice(...); =for example # below is the same as $x->slice("5:7,:,3:4:2") $a = $x->mslice([5,7],X,[3,4,2]); =cut # called for colon-less args # preserves parens if present sub intpars { $_[0] =~ /\(.*\)/ ? '('.int($_[0]).')' : int $_[0] } sub PDL::mslice { my($pdl) = shift; return $pdl->slice(join ',',(map { !ref $_ && $_ eq "X" ? ":" : ref $_ eq "ARRAY" ? $#$_ > 1 && @$_[2] == 0 ? "(".int(@$_[0]).")" : join ':', map {int $_} @$_ : !ref $_ ? intpars $_ : die "INVALID SLICE DEF $_" } @_)); } =head2 nslice_if_pdl =for ref If C<$self> is a PDL, then calls C with all but the last argument, otherwise $self->($_[-1]) is called where $_[-1} is the original argument string found during PDL::NiceSlice filtering. DEVELOPER'S NOTE: this routine is found in Core.pm.PL but would be better placed in Slices/slices.pd. It is likely to be moved there and/or changed to "slice_if_pdl" for PDL 3.0. =for usage $a = $x->nslice_if_pdl(...,'(args)'); =cut sub PDL::nslice_if_pdl { my ($pdl) = shift; my ($orig_args) = pop; # warn "PDL::nslice_if_pdl called with (@_) args, originally ($orig_args)\n"; if (ref($pdl) eq 'CODE') { # barf('PDL::nslice_if_pdl tried to process a sub ref, please use &$subref() syntax') @_ = eval $orig_args; goto &$pdl; } unshift @_, $pdl; goto &PDL::slice; } =head2 nslice =for ref c was an internally used interface for L, but is now merely a springboard to L. It is deprecated and likely to disappear in PDL 3.0. =cut sub PDL::nslice { unless($PDL::nslice_warning_issued) { $PDL::nslice_warning_issued = 1; warn "WARNING: deprecated call to PDL::nslice detected. Use PDL::slice instead.\n (Warning will be issued only once per session)\n"; } goto &PDL::slice; } sub blessed { my $ref = ref(shift); return $ref =~ /^(REF|SCALAR|ARRAY|HASH|CODE|GLOB||)$/ ? 0 : 1; } # Convert numbers to PDL if not already sub PDL::topdl { return $_[0]->new(@_[1..$#_]) if($#_ > 1); # PDLify an ARRAY return $_[1] if blessed($_[1]); # Fall through return $_[0]->new($_[1]) if ref(\$_[1]) eq 'SCALAR' or ref($_[1]) eq 'ARRAY'; barf("Can not convert a ".ref($_[1])." to a ".$_[0]); 0;} # Convert everything to PDL if not blessed sub alltopdl { if (ref $_[2] eq 'PDL::Type') { return convert($_[1], $_[2]) if blessed($_[1]); return $_[0]->new($_[2], $_[1]) if $_[0] eq 'PDL'; } return $_[1] if blessed($_[1]); # Fall through return $_[0]->new($_[1]); 0;} =head2 inplace =for ref Flag a piddle so that the next operation is done 'in place' =for usage somefunc($x->inplace); somefunc(inplace $x); In most cases one likes to use the syntax C<$y = f($x)>, however in many case the operation C can be done correctly 'in place', i.e. without making a new copy of the data for output. To make it easy to use this, we write C in such a way that it operates in-place, and use C to hint that a new copy should be disabled. This also makes for clear syntax. Obviously this will not work for all functions, and if in doubt see the function's documentation. However one can assume this is true for all elemental functions (i.e. those which just operate array element by array element like C). =for example pdl> $x = xvals zeroes 10; pdl> log10(inplace $x) pdl> p $x [-inf 0 0.30103 0.47712125 0.60205999 0.69897 0.77815125 0.84509804 0.90308999 0.95424251] =cut # Flag pdl for in-place operations sub PDL::inplace { my $pdl = PDL->topdl(shift); $pdl->set_inplace(1); return $pdl; } # Copy if not inplace =head2 is_inplace =for ref Test the in-place flag on a piddle =for usage $out = ($in->is_inplace) ? $in : zeroes($in); $in->set_inplace(0) Provides access to the L hint flag, within the perl millieu. That way functions you write can be inplace aware... If given an argument the inplace flag will be set or unset depending on the value at the same time. Can be used for shortcut tests that delete the inplace flag while testing: $out = ($in->is_inplace(0)) ? $in : zeroes($in); # test & unset! =head2 set_inplace =for ref Set the in-place flag on a piddle =for usage $out = ($in->is_inplace) ? $in : zeroes($in); $in->set_inplace(0); Provides access to the L hint flag, within the perl millieu. Useful mainly for turning it OFF, as L turns it ON more conveniently. =head2 new_or_inplace =for usage $a = new_or_inplace(shift()); $a = new_or_inplace(shift(),$preferred_type); =for ref Return back either the argument pdl or a copy of it depending on whether it be flagged in-place or no. Handy for building inplace-aware functions. If you specify a preferred type (must be one of the usual PDL type strings, a list ref containing several of them, or a string containing several of them), then the copy is coerced into the first preferred type listed if it is not already one of the preferred types. Note that if the inplace flag is set, no coersion happens even if you specify a preferred type. =cut sub new_or_inplace { my $pdl = shift; my $preferred = shift; my $force = shift; if($pdl->is_inplace) { $pdl->set_inplace(0); return $pdl; } else { unless(defined($preferred)) { return $pdl->copy; } else { $preferred = join(",",@$preferred) if(ref($preferred) eq 'ARRAY'); my $s = "".$pdl->type; if($preferred =~ m/(^|\,)$s(\,|$)/i) { # Got a match - the PDL is one of the preferred types. return $pdl->copy(); } else { # No match - promote it to the first in the list. $preferred =~ s/\,.*//; my $out = PDL::new_from_specification('PDL',new PDL::Type($preferred),$pdl->dims); $out .= $pdl; return $out; } } } barf "PDL::Core::new_or_inplace - This can never happen!"; } *PDL::new_or_inplace = \&new_or_inplace; # Allow specifications like zeroes(10,10) or zeroes($x) # or zeroes(inplace $x) or zeroes(float,4,3) =head2 new_from_specification =for ref Internal method: create piddle by specification This is the argument processing method called by L and some other functions which constructs piddles from argument lists of the form: [type], $nx, $ny, $nz,... For C<$nx>, C<$ny>, etc. 0 and 1D piddles are allowed. Giving those has the same effect as if saying C<$arg-Elist>, e.g. 1, pdl(5,2), 4 is equivalent to 1, 5, 2, 4 Note, however, that in all functions using C calling C will probably not do what you want. So to play safe use (e.g. with zeroes) $pdl = zeroes $dimpdl->list; Calling $pdl = zeroes $dimpdl; will rather be equivalent to $pdl = zeroes $dimpdl->dims; However, $pdl = zeroes ushort, $dimpdl; will again do what you intended since it is interpreted as if you had said $pdl = zeroes ushort, $dimpdl->list; This is unfortunate and confusing but no good solution seems obvious that would not break existing scripts. =cut sub PDL::new_from_specification{ my $class = shift; my $type = ref($_[0]) eq 'PDL::Type' ? ${shift @_}[0] : $PDL_D; my $nelems = 1; my @dims; for (@_) { if (ref $_) { barf "Trying to use non-piddle as dimensions?" unless $_->isa('PDL'); barf "Trying to use multi-dim piddle as dimensions?" if $_->getndims > 1; warn "creating > 10 dim piddle (piddle arg)!" if $_->nelem > 10; for my $dim ($_->list) {$nelems *= $dim; push @dims, $dim} } else { if ($_) { # quiet warnings when $_ is the empty string barf "Dimensions must be non-negative" if $_<0; $nelems *= $_; push @dims, $_ } else { $nelems *= 0; push @dims, 0; } } } my $pdl = $class->initialize(); $pdl->set_datatype($type); $pdl->setdims([@dims]); print "Dims: ",(join ',',@dims)," DLen: ",(length $ {$pdl->get_dataref}),"\n" if $PDL::debug; return $pdl; } =head2 isnull =for ref Test whether a piddle is null =for usage croak("Input piddle mustn't be null!") if $input_piddle->isnull; This function returns 1 if the piddle is null, zero if it is not. The purpose of null piddles is to "tell" any PDL::PP methods to allocate new memory for an output piddle, but only when that PDL::PP method is called in full-arg form. Of course, there's no reason you couldn't commandeer the special value for your own purposes, for which this test function would prove most helpful. But in general, you shouldn't need to test for a piddle's nullness. See L for more information. =head2 isempty =for ref Test whether a piddle is empty =for usage print "The piddle has zero dimension\n" if $pdl->isempty; This function returns 1 if the piddle has zero elements. This is useful in particular when using the indexing function which. In the case of no match to a specified criterion, the returned piddle has zero dimension. pdl> $a=sequence(10) pdl> $i=which($a < -1) pdl> print "I found no matches!\n" if ($i->isempty); I found no matches! Note that having zero elements is rather different from the concept of being a null piddle, see the L and L manpages for discussions of this. =cut sub PDL::isempty { my $pdl=shift; return ($pdl->nelem == 0); } =head2 zeroes =for ref construct a zero filled piddle from dimension list or template piddle. Various forms of usage, (i) by specification or (ii) by template piddle: =for usage # usage type (i): $a = zeroes([type], $nx, $ny, $nz,...); $a = PDL->zeroes([type], $nx, $ny, $nz,...); $a = $pdl->zeroes([type], $nx, $ny, $nz,...); # usage type (ii): $a = zeroes $b; $a = $b->zeroes zeroes inplace $a; # Equivalent to $a .= 0; $a->inplace->zeroes; # "" =for example pdl> $z = zeroes 4,3 pdl> p $z [ [0 0 0 0] [0 0 0 0] [0 0 0 0] ] pdl> $z = zeroes ushort, 3,2 # Create ushort array [ushort() etc. with no arg returns a PDL::Types token] See also L for details on using piddles in the dimensions list. =cut sub zeroes { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? PDL::zeroes($_[0]) : PDL->zeroes(@_) } sub PDL::zeroes { my $class = shift; my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; $pdl.=0; return $pdl; } # Create convenience aliases for zeroes =head2 zeros =for ref construct a zero filled piddle (see zeroes for usage) =cut *zeros = \&zeroes; *PDL::zeros = \&PDL::zeroes; =head2 ones =for ref construct a one filled piddle =for usage $a = ones([type], $nx, $ny, $nz,...); etc. (see 'zeroes') =for example see zeroes() and add one See also L for details on using piddles in the dimensions list. =cut sub ones { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? PDL::ones($_[0]) : PDL->ones(@_) } sub PDL::ones { my $class = shift; my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; $pdl.=1; return $pdl; } =head2 reshape =for ref Change the shape (i.e. dimensions) of a piddle, preserving contents. =for usage $x->reshape(NEWDIMS); reshape($x, NEWDIMS); The data elements are preserved, obviously they will wrap differently and get truncated if the new array is shorter. If the new array is longer it will be zero-padded. ***Potential incompatibility with earlier versions of PDL**** If the list of C is empty C will just drop all dimensions of size 1 (preserving the number of elements): $a = sequence(3,4,5); $b = $a(1,3); $b->reshape(); print $b->info; PDL: Double D [5] Dimensions of size 1 will also be dropped if C is invoked with the argument -1: $b = $a->reshape(-1); As opposed to C without arguments, C preserves dataflow: $a = ones(2,1,2); $b = $a(0)->reshape(-1); $b++; print $a; [ [ [2 1] ] [ [2 1] ] ] Important: Piddles are changed inplace! Note: If C<$x> is connected to any other PDL (e.g. if it is a slice) then the connection is first severed. =for example pdl> $x = sequence(10) pdl> reshape $x,3,4; p $x [ [0 1 2] [3 4 5] [6 7 8] [9 0 0] ] pdl> reshape $x,5; p $x [0 1 2 3 4] =cut *reshape = \&PDL::reshape; sub PDL::reshape{ if (@_ == 2 && $_[1] == -1) { # a slicing reshape that drops 1-dims return $_[0]->slice( map { $_==1 ? [0,0,0] : [] } $_[0]->dims); } my $pdl = topdl($_[0]); $pdl->sever; my $nelem = $pdl->nelem; my @dims = grep defined, @_[1..$#_]; for my $dim(@dims) { barf "reshape: invalid dim size '$dim'" if $dim < 0 } @dims = grep($_ != 1, $pdl->dims) if @dims == 0; # get rid of dims of size 1 $pdl->setdims([@dims]); $pdl->upd_data; if ($pdl->nelem > $nelem) { my $tmp=$pdl->clump(-1)->slice("$nelem:-1"); $tmp .= 0; } $_[0] = $pdl; return $pdl; } =head2 squeeze =for ref eliminate all singleton dimensions (dims of size 1) =for example $b = $a(0,0)->squeeze; Alias for C. Removes all singleton dimensions and preserves dataflow. A more concise interface is provided by L via modifiers: use PDL::NiceSlice; $b = $a(0,0;-); # same as $a(0,0)->squeeze =cut *squeeze = \&PDL::squeeze; sub PDL::squeeze { return $_[0]->reshape(-1) } =head2 flat =for ref flatten a piddle (alias for C<< $pdl->clump(-1) >>) =for example $srt = $pdl->flat->qsort; Useful method to make a 1D piddle from an arbitrarily sized input piddle. Data flows back and forth as usual with slicing routines. Falls through if argument already E= 1D. =cut *flat = \&PDL::flat; sub PDL::flat { # fall through if < 2D return my $dummy = $_[0]->getndims != 1 ? $_[0]->clump(-1) : $_[0]; } =head2 convert =for ref Generic datatype conversion function =for usage $y = convert($x, $newtypenum); =for example $y = convert $x, long $y = convert $x, ushort C<$newtype> is a type B, for convenience they are returned by C etc when called without arguments. =cut # type to type conversion functions (with automatic conversion to pdl vars) sub PDL::convert { # we don't allow inplace conversion at the moment # (not sure what needs to be changed) barf 'Usage: $y = convert($x, $newtypenum)'."\n" if $#_!=1; my ($pdl,$type)= @_; $pdl = pdl($pdl) unless ref $pdl; # Allow normal numbers $type = $type->enum if ref($type) eq 'PDL::Type'; barf 'Usage: $y = convert($x, $newtypenum)'."\n" unless Scalar::Util::looks_like_number($type); return $pdl if $pdl->get_datatype == $type; # make_physical-call: temporary stopgap to work around core bug my $conv = $pdl->flowconvert($type)->make_physical->sever; return $conv; } =head2 Datatype_conversions =for ref byte|short|ushort|long|indx|longlong|float|double (shorthands to convert datatypes) =for usage $y = double $x; $y = ushort [1..10]; # all of the above listed shorthands behave similarly When called with a piddle argument, they convert to the specific datatype. When called with a numeric, list, listref, or string argument they construct a new piddle. This is a convenience to avoid having to be long-winded and say C<$x = long(pdl(42))> Thus one can say: $a = float(1,2,3,4); # 1D $a = float q[1 2 3; 4 5 6]; # 2D $a = float([1,2,3],[4,5,6]); # 2D $a = float([[1,2,3],[4,5,6]]); # 2D Note the last three give identical results, and the last two are exactly equivalent - a list is automatically converted to a list reference for syntactic convenience. i.e. you can omit the outer C<[]> When called with no arguments, these functions return a special type token. This allows syntactical sugar like: $x = ones byte, 1000,1000; This example creates a large piddle directly as byte datatype in order to save memory. In order to control how undefs are handled in converting from perl lists to PDLs, one can set the variable C<$PDL::undefval>; see the function L for more details. =for example pdl> p $x=sqrt float [1..10] [1 1.41421 1.73205 2 2.23607 2.44949 2.64575 2.82843 3 3.16228] pdl> p byte $x [1 1 1 2 2 2 2 2 3 3] =head2 byte Convert to byte datatype =head2 short Convert to short datatype =head2 ushort Convert to ushort datatype =head2 long Convert to long datatype =head2 indx Convert to indx datatype =head2 longlong Convert to longlong datatype =head2 float Convert to float datatype =head2 double Convert to double datatype =head2 type =for ref return the type of a piddle as a blessed type object A convenience function for use with the piddle constructors, e.g. =for example $b = PDL->zeroes($a->type,$a->dims,3); die "must be float" unless $a->type == float; See also the discussion of the C class in L. Note that the C objects have overloaded comparison and stringify operators so that you can compare and print types: $a = $a->float if $a->type < float; $t = $a->type; print "Type is $t\"; =cut sub PDL::type { return PDL::Type->new($_[0]->get_datatype); } ##################### Printing #################### # New string routine $PDL::_STRINGIZING = 0; sub PDL::string { my($self,$format)=@_; my $to_return = eval { if($PDL::_STRINGIZING) { return "ALREADY_STRINGIZING_NO_LOOPS"; } local $PDL::_STRINGIZING = 1; my $ndims = $self->getndims; if($self->nelem > $PDL::toolongtoprint) { return "TOO LONG TO PRINT"; } if ($ndims==0) { if ( $self->badflag() and $self->isbad() ) { return "BAD"; } else { my @x = $self->at(); return ($format ? sprintf($format, $x[0]) : "$x[0]"); } } return "Null" if $self->isnull; return "Empty[".join("x",$self->dims)."]" if $self->isempty; # Empty piddle local $sep = $PDL::use_commas ? "," : " "; local $sep2 = $PDL::use_commas ? "," : ""; if ($ndims==1) { return str1D($self,$format); } else{ return strND($self,$format,0); } }; if ($@) { # Remove reference to this line: $@ =~ s/\s*at .* line \d+\s*\.\n*/./; PDL::Core::barf("Stringizing problem: $@"); } return $to_return; } ############## Section/subsection functions ################### =head2 list =for ref Convert piddle to perl list =for usage @tmp = list $x; Obviously this is grossly inefficient for the large datasets PDL is designed to handle. This was provided as a get out while PDL matured. It should now be mostly superseded by superior constructs, such as PP/threading. However it is still occasionally useful and is provied for backwards compatibility. =for example for (list $x) { # Do something on each value... } If you compile PDL with bad value support (the default), your machine's docs will also say this: =for bad list converts any bad values into the string 'BAD'. =cut # No threading, just the ordinary dims. sub PDL::list{ # pdl -> @list barf 'Usage: list($pdl)' if $#_!=0; my $pdl = PDL->topdl(shift); return () if nelem($pdl)==0; @{listref_c($pdl)}; } =head2 unpdl =for ref Convert piddle to nested Perl array references =for usage $arrayref = unpdl $x; This function returns a reference to a Perl list-of-lists structure equivalent to the input piddle (within the limitation that while values of elements should be preserved, the detailed datatypes will not as perl itself basically has "number" data rather than byte, short, int... E.g., C<< sum($x - pdl( $x->unpdl )) >> should equal 0. Obviously this is grossly inefficient in memory and processing for the large datasets PDL is designed to handle. Sometimes, however, you really want to move your data back to Perl, and with proper dimensionality, unlike C. =for example use JSON; my $json = encode_json unpdl $pdl; If you compile PDL with bad value support (the default), your machine's docs will also say this: =cut =for bad unpdl converts any bad values into the string 'BAD'. =cut sub PDL::unpdl { barf 'Usage: unpdl($pdl)' if $#_ != 0; my $pdl = PDL->topdl(shift); return [] if $pdl->nelem == 0; return _unpdl_int($pdl); } sub _unpdl_int { my $pdl = shift; if ($pdl->ndims > 1) { return [ map { _unpdl_int($_) } dog $pdl ]; } else { return listref_c($pdl); } } =head2 listindices =for ref Convert piddle indices to perl list =for usage @tmp = listindices $x; C<@tmp> now contains the values C<0..nelem($x)>. Obviously this is grossly inefficient for the large datasets PDL is designed to handle. This was provided as a get out while PDL matured. It should now be mostly superseded by superior constructs, such as PP/threading. However it is still occasionally useful and is provied for backwards compatibility. =for example for $i (listindices $x) { # Do something on each value... } =cut sub PDL::listindices{ # Return list of index values for 1D pdl barf 'Usage: list($pdl)' if $#_!=0; my $pdl = shift; return () if nelem($pdl)==0; barf 'Not 1D' if scalar(dims($pdl)) != 1; return (0..nelem($pdl)-1); } =head2 set =for ref Set a single value inside a piddle =for usage set $piddle, @position, $value C<@position> is a coordinate list, of size equal to the number of dimensions in the piddle. Occasionally useful, mainly provided for backwards compatibility as superseded by use of L and assignment operator C<.=>. =for example pdl> $x = sequence 3,4 pdl> set $x, 2,1,99 pdl> p $x [ [ 0 1 2] [ 3 4 99] [ 6 7 8] [ 9 10 11] ] =cut sub PDL::set{ # Sets a particular single value barf 'Usage: set($pdl, $x, $y,.., $value)' if $#_<2; my $self = shift; my $value = pop @_; set_c ($self, [@_], $value); return $self; } =head2 at =for ref Returns a single value inside a piddle as perl scalar. =for usage $z = at($piddle, @position); $z=$piddle->at(@position); C<@position> is a coordinate list, of size equal to the number of dimensions in the piddle. Occasionally useful in a general context, quite useful too inside PDL internals. =for example pdl> $x = sequence 3,4 pdl> p $x->at(1,2) 7 If you compile PDL with bad value support (the default), your machine's docs will also say this: =for bad at converts any bad values into the string 'BAD'. =cut sub PDL::at { # Return value at ($x,$y,$z...) barf 'Usage: at($pdl, $x, $y, ...)' if $#_<0; my $self = shift; at_bad_c ($self, [@_]); } =head2 sclr =for ref return a single value from a piddle as a scalar =for example $val = $a(10)->sclr; $val = sclr inner($a,$b); The C method is useful to turn a piddle into a normal Perl scalar. Its main advantage over using C for this purpose is the fact that you do not need to worry if the piddle is 0D, 1D or higher dimensional. Using C you have to supply the correct number of zeroes, e.g. $a = sequence(10); $b = $a->slice('4'); print $b->sclr; # no problem print $b->at(); # error: needs at least one zero C is generally used when a Perl scalar is required instead of a one-element piddle. If the input is a multielement piddle the first value is returned as a Perl scalar. You can optionally switch on checks to ensure that the input piddle has only one element: PDL->sclr({Check => 'warn'}); # carp if called with multi-el pdls PDL->sclr({Check => 'barf'}); # croak if called with multi-el pdls are the commands to switch on warnings or raise an error if a multielement piddle is passed as input. Note that these options can only be set when C is called as a class method (see example above). Use PDL->sclr({Check=>0}); to switch these checks off again (default setting); When called as a class method the resulting check mode is returned (0: no checking, 1: warn, 2: barf). =cut my $chkmode = 0; # default mode no checks use PDL::Options; sub PDL::sclr { my $this = shift; if (ref $this) { # instance method carp "multielement piddle in 'sclr' call" if ($chkmode == 1 && $this->nelem > 1); croak "multielement piddle in 'sclr' call" if ($chkmode == 2 && $this->nelem > 1); return sclr_c($this); } else { # class method my $check = (iparse({Check=>0},ifhref($_[0])))[1]; if (lc($check) eq 'warn') {$chkmode = 1} elsif (lc($check) eq 'barf') {$chkmode = 2} else {$chkmode = $check != 0 ? 1 : 0} return $chkmode; } } =head2 cat =for ref concatenate piddles to N+1 dimensional piddle Takes a list of N piddles of same shape as argument, returns a single piddle of dimension N+1 =for example pdl> $x = cat ones(3,3),zeroes(3,3),rvals(3,3); p $x [ [ [1 1 1] [1 1 1] [1 1 1] ] [ [0 0 0] [0 0 0] [0 0 0] ] [ [1 1 1] [1 0 1] [1 1 1] ] ] If you compile PDL with bad value support (the default), your machine's docs will also say this: =for bad The output piddle is set bad if any input piddles have their bad flag set. Similar functions include L and L. =cut sub PDL::cat { my $res; my $old_err = $@; $@ = ''; eval { $res = $_[0]->initialize; $res->set_datatype($_[0]->get_datatype); my @resdims = $_[0]->dims; for my $i(0..$#_){ my @d = $_[$i]->dims; for my $j(0..$#d) { $resdims[$j] = $d[$j] if( !defined($resdims[$j]) or $resdims[$j]==1 ); die "mismatched dims\n" if($d[$j] != 1 and $resdims[$j] != $d[$j]); } } $res->setdims( [@resdims,scalar(@_) ]); my ($i,$t); my $s = ":,"x@resdims; for (@_) { $t = $res->slice($s."(".$i++.")"); $t .= $_} # propagate any bad flags for (@_) { if ( $_->badflag() ) { $res->badflag(1); last; } } }; if ($@ eq '') { # Restore the old error and return $@ = $old_err; return $res; } # If we've gotten here, then there's been an error, so check things # and barf out a meaningful message. if ($@ =~ /PDL::Ops::assgn|mismatched/ or $@ =~ /"badflag"/ or $@ =~ /"initialize"/) { my (@mismatched_dims, @not_a_piddle); my $i = 0; # non-piddles and/or dimension mismatch. The first argument is # ok unless we have the "initialize" error: if ($@ =~ /"initialize"/) { # Handle the special case that there are *no* args passed: barf("Called PDL::cat without any arguments") unless @_; while ($i < @_ and not eval{ $_[$i]->isa('PDL')}) { push (@not_a_piddle, $i); $i++; } } # Get the dimensions of the first actual piddle in the argument # list: my $first_piddle_argument = $i; my @dims = $_[$i]->dims if ref($_[$i]) =~ /PDL/; # Figure out all the ways that the caller screwed up: while ($i < @_) { my $arg = $_[$i]; # Check if not a piddle if (not eval{$arg->isa('PDL')}) { push @not_a_piddle, $i; } # Check if different number of dimensions elsif (@dims != $arg->ndims) { push @mismatched_dims, $i; } # Check if size of dimensions agree else { DIMENSION: for (my $j = 0; $j < @dims; $j++) { if ($dims[$j] != $arg->dim($j)) { push @mismatched_dims, $i; last DIMENSION; } } } $i++; } # Construct a message detailing the results my $message = "bad arguments passed to function PDL::cat\n"; if (@mismatched_dims > 1) { # Many dimension mismatches $message .= "The dimensions of arguments " . join(', ', @mismatched_dims[0 .. $#mismatched_dims-1]) . " and $mismatched_dims[-1] do not match the\n" . " dimensions of the first piddle argument (argument $first_piddle_argument).\n"; } elsif (@mismatched_dims) { # One dimension mismatch $message .= "The dimensions of argument $mismatched_dims[0] do not match the\n" . " dimensions of the first piddle argument (argument $first_piddle_argument).\n"; } if (@not_a_piddle > 1) { # many non-piddles $message .= "Arguments " . join(', ', @not_a_piddle[0 .. $#not_a_piddle-1]) . " and $not_a_piddle[-1] are not piddles.\n"; } elsif (@not_a_piddle) { # one non-piddle $message .= "Argument $not_a_piddle[0] is not a piddle.\n"; } # Handle the edge case that something else happened: if (@not_a_piddle == 0 and @mismatched_dims == 0) { barf("cat: unknown error from the internals:\n$@"); } $message .= "(Argument counting starts from zero.)"; croak($message); } else { croak("cat: unknown error from the internals:\n$@"); } } =head2 dog =for ref Opposite of 'cat' :). Split N dim piddle to list of N-1 dim piddles Takes a single N-dimensional piddle and splits it into a list of N-1 dimensional piddles. The breakup is done along the last dimension. Note the dataflown connection is still preserved by default, e.g.: =for example pdl> $p = ones 3,3,3 pdl> ($a,$b,$c) = dog $p pdl> $b++; p $p [ [ [1 1 1] [1 1 1] [1 1 1] ] [ [2 2 2] [2 2 2] [2 2 2] ] [ [1 1 1] [1 1 1] [1 1 1] ] ] =for options Break => 1 Break dataflow connection (new copy) If you compile PDL with bad value support (the default), your machine's docs will also say this: =for bad The output piddles are set bad if the original piddle has its bad flag set. =cut sub PDL::dog { my $opt = pop @_ if ref($_[-1]) eq 'HASH'; my $p = shift; my @res; my $s = ":,"x($p->getndims-1); for my $i (0..$p->getdim($p->getndims-1)-1) { $res[$i] = $p->slice($s."(".$i.")"); $res[$i] = $res[$i]->copy if $$opt{Break}; $i++; } return @res; } ###################### Misc internal routines #################### # Recursively pack an N-D array ref in format [[1,1,2],[2,2,3],[2,2,2]] etc # package vars $level and @dims must be initialised first. sub rpack { my ($ptype,$a) = @_; my ($ret,$type); $ret = ""; if (ref($a) eq "ARRAY") { if (defined($dims[$level])) { barf 'Array is not rectangular' unless $dims[$level] == scalar(@$a); }else{ $dims[$level] = scalar(@$a); } $type = ref($$a[0]); if ($type) { $level++; for(@$a) { barf 'Array is not rectangular' unless $type eq ref($_); # Equal types $ret .= rpack($ptype,$_); } $level--; } else { # These are leaf nodes $ret = pack $ptype, map {defined($_) ? $_ : $PDL::undefval} @$a; } } elsif (ref($a) eq "PDL") { barf 'Cannot make a new piddle from two or more piddles, try "cat"'; } else { barf "Don't know how to make a PDL object from passed argument"; } return $ret; } sub rcopyitem { # Return a deep copy of an item - recursively my $x = shift; my ($y, $key, $value); if (ref(\$x) eq "SCALAR") { return $x; }elsif (ref($x) eq "SCALAR") { $y = $$x; return \$y; }elsif (ref($x) eq "ARRAY") { $y = []; for (@$x) { push @$y, rcopyitem($_); } return $y; }elsif (ref($x) eq "HASH") { $y={}; while (($key,$value) = each %$x) { $$y{$key} = rcopyitem($value); } return $y; }elsif (blessed($x)) { return $x->copy; }else{ barf ('Deep copy of object failed - unknown component with type '.ref($x)); } 0;} # N-D array stringifier sub strND { my($self,$format,$level)=@_; # $self->make_physical(); my @dims = $self->dims; # print "STRND, $#dims\n"; if ($#dims==1) { # Return 2D string return str2D($self,$format,$level); } else { # Return list of (N-1)D strings my $secbas = join '',map {":,"} @dims[0..$#dims-1]; my $ret="\n"." "x$level ."["; my $j; for ($j=0; $j<$dims[$#dims]; $j++) { my $sec = $secbas . "($j)"; # print "SLICE: $sec\n"; $ret .= strND($self->slice($sec),$format, $level+1); chop $ret; $ret .= $sep2; } chop $ret if $PDL::use_commas; $ret .= "\n" ." "x$level ."]\n"; return $ret; } } # String 1D array in nice format sub str1D { my($self,$format)=@_; barf "Not 1D" if $self->getndims()!=1; my $x = listref_c($self); my ($ret,$dformat,$t); $ret = "["; my $dtype = $self->get_datatype(); $dformat = $PDL::floatformat if $dtype == $PDL_F; $dformat = $PDL::doubleformat if $dtype == $PDL_D; $dformat = $PDL::indxformat if $dtype == $PDL_IND; my $badflag = $self->badflag(); for $t (@$x) { if ( $badflag and $t eq "BAD" ) { # do nothing } elsif ($format) { $t = sprintf $format,$t; } else{ # Default if ($dformat && length($t)>7) { # Try smaller $t = sprintf $dformat,$t; } } $ret .= $t.$sep; } chop $ret; $ret.="]"; return $ret; } # String 2D array in nice uniform format sub str2D{ my($self,$format,$level)=@_; # print "STR2D:\n"; $self->printdims(); my @dims = $self->dims(); barf "Not 2D" if scalar(@dims)!=2; my $x = listref_c($self); my ($i, $f, $t, $len, $ret); my $dtype = $self->get_datatype(); my $badflag = $self->badflag(); my $findmax = 1; if (!defined $format || $format eq "") { # Format not given? - find max length of default $len=0; if ( $badflag ) { for (@$x) { if ( $_ eq "BAD" ) { $i = 3; } else { $i = length($_); } $len = $i>$len ? $i : $len; } } else { for (@$x) {$i = length($_); $len = $i>$len ? $i : $len }; } $format = "%".$len."s"; if ($len>7) { # Too long? - perhaps try smaller format if ($dtype == $PDL_F) { $format = $PDL::floatformat; } elsif ($dtype == $PDL_D) { $format = $PDL::doubleformat; } elsif ($dtype == $PDL_IND) { $format = $PDL::indxformat; } else { # Stick with default $findmax = 0; } } else { # Default ok $findmax = 0; } } if($findmax) { # Find max length of strings in final format $len=0; if ( $badflag ) { for (@$x) { if ( $_ eq "BAD" ) { $i = 3; } else { $i = length(sprintf $format,$_); } $len = $i>$len ? $i : $len; } } else { for (@$x) { $i = length(sprintf $format,$_); $len = $i>$len ? $i : $len; } } } # if: $findmax $ret = "\n" . " "x$level . "[\n"; { my $level = $level+1; $ret .= " "x$level ."["; for ($i=0; $i<=$#$x; $i++) { if ( $badflag and $$x[$i] eq "BAD" ) { $f = "BAD"; } else { $f = sprintf $format,$$x[$i]; } $t = $len-length($f); $f = " "x$t .$f if $t>0; $ret .= $f; if (($i+1)%$dims[0]) { $ret.=$sep; } else{ # End of output line $ret.="]"; if ($i==$#$x) { # very last number $ret.="\n"; } else{ $ret.= $sep2."\n" . " "x$level ."["; } } } } $ret .= " "x$level."]\n"; return $ret; } # # Sleazy hcpy saves me time typing # sub PDL::hcpy { $_[0]->hdrcpy($_[1]); $_[0]; } ########## Docs for functions in Core.xs ################## # Pod docs for functions that are imported from Core.xs and are # not documented elsewhere. Currently this is not a complete # list. There are others. =head2 gethdr =for ref Retrieve header information from a piddle =for example $pdl=rfits('file.fits'); $h=$pdl->gethdr; print "Number of pixels in the X-direction=$$h{NAXIS1}\n"; The C function retrieves whatever header information is contained within a piddle. The header can be set with L and is always a hash reference or undef. C returns undef if the piddle has not yet had a header defined; compare with C and C, which are guaranteed to return a defined value. Note that gethdr() works by B: you can modify the header in-place once it has been retrieved: $a = rfits($filename); $ah = $a->gethdr(); $ah->{FILENAME} = $filename; It is also important to realise that in most cases the header is not automatically copied when you copy the piddle. See L to enable automatic header copying. Here's another example: a wrapper around rcols that allows your piddle to remember the file it was read from and the columns could be easily written (here assuming that no regexp is needed, extensions are left as an exercise for the reader) sub ext_rcols { my ($file, @columns)=@_; my $header={}; $$header{File}=$file; $$header{Columns}=\@columns; @piddles=rcols $file, @columns; foreach (@piddles) { $_->sethdr($header); } return @piddles; } =head2 hdr =for ref Retrieve or set header information from a piddle =for example $pdl->hdr->{CDELT1} = 1; The C function allows convenient access to the header of a piddle. Unlike C it is guaranteed to return a defined value, so you can use it in a hash dereference as in the example. If the header does not yet exist, it gets autogenerated as an empty hash. Note that this is usually -- but not always -- What You Want. If you want to use a tied L hash, for example, you should either construct it yourself and use C to put it into the piddle, or use L instead. (Note that you should be able to write out the FITS file successfully regardless of whether your PDL has a tied FITS header object or a vanilla hash). =head2 fhdr =for ref Retrieve or set FITS header information from a piddle =for example $pdl->fhdr->{CDELT1} = 1; The C function allows convenient access to the header of a piddle. Unlike C it is guaranteed to return a defined value, so you can use it in a hash dereference as in the example. If the header does not yet exist, it gets autogenerated as a tied L hash. Astro::FITS::Header tied hashes are better at matching the behavior of FITS headers than are regular hashes. In particular, the hash keys are CAsE INsEnSItiVE, unlike normal hash keys. See L for details. If you do not have Astro::FITS::Header installed, you get back a normal hash instead of a tied object. =head2 sethdr =for ref Set header information of a piddle =for example $pdl = zeroes(100,100); $h = {NAXIS=>2, NAXIS1=>100, NAXIS=>100, COMMENT=>"Sample FITS-style header"}; # add a FILENAME field to the header $$h{FILENAME} = 'file.fits'; $pdl->sethdr( $h ); The C function sets the header information for a piddle. You must feed in a hash ref or undef, and the header field of the PDL is set to be a new ref to the same hash (or undefined). The hash ref requirement is a speed bump put in place since the normal use of headers is to store fits header information and the like. Of course, if you want you can hang whatever ugly old data structure you want off of the header, but that makes life more complex. Remember that the hash is not copied -- the header is made into a ref that points to the same underlying data. To get a real copy without making any assumptions about the underlying data structure, you can use one of the following: use PDL::IO::Dumper; $pdl->sethdr( deep_copy($h) ); (which is slow but general), or $pdl->sethdr( PDL::_hdr_copy($h) ) (which uses the built-in sleazy deep copier), or (if you know that all the elements happen to be scalars): { my %a = %$h; $pdl->sethdr(\%a); } which is considerably faster but just copies the top level. The C function must be given a hash reference or undef. For further information on the header, see L, L, L and L. =head2 hdrcpy =for ref switch on/off/examine automatic header copying =for example print "hdrs will be copied" if $a->hdrcpy; $a->hdrcpy(1); # switch on automatic header copying $b = $a->sumover; # and $b will inherit $a's hdr $a->hdrcpy(0); # and now make $a non-infectious again C without an argument just returns the current setting of the flag. See also "hcpy" which returns its PDL argument (and so is useful in method-call pipelines). Normally, the optional header of a piddle is not copied automatically in pdl operations. Switching on the hdrcpy flag using the C method will enable automatic hdr copying. Note that an actual deep copy gets made, which is rather processor-inefficient -- so avoid using header copying in tight loops! Most PDLs have the C flag cleared by default; however, some routines (notably L) set it by default where that makes more sense. The C flag is viral: if you set it for a PDL, then derived PDLs will get copies of the header and will also have their C flags set. For example: $a = xvals(50,50); $a->hdrcpy(1); $a->hdr->{FOO} = "bar"; $b = $a++; $c = $b++; print $b->hdr->{FOO}, " - ", $c->hdr->{FOO}, "\n"; $b->hdr->{FOO} = "baz"; print $a->hdr->{FOO}, " - ", $b->hdr->{FOO}, " - ", $c->hdr->{FOO}, "\n"; will print: bar - bar bar - baz - bar Performing an operation in which more than one PDL has its hdrcpy flag causes the resulting PDL to take the header of the first PDL: ($a,$b) = sequence(5,2)->dog; $a->hdrcpy(1); $b->hdrcpy(1); $a->hdr->{foo} = 'a'; $b->hdr->{foo} = 'b'; print (($a+$b)->hdr->{foo} , ($b+$a)->hdr->{foo}); will print: a b =head2 hcpy =for ref Switch on/off automatic header copying, with PDL pass-through =for example $a = rfits('foo.fits')->hcpy(0); $a = rfits('foo.fits')->hcpy(1); C sets or clears the hdrcpy flag of a PDL, and returns the PDL itself. That makes it convenient for inline use in expressions. =head2 set_autopthread_targ =for ref Set the target number of processor threads (pthreads) for multi-threaded processing. =for usage set_autopthread_targ($num_pthreads); C<$num_pthreads> is the target number of pthreads the auto-pthread process will try to achieve. See L for an overview of the auto-pthread process. =for example # Example turning on auto-pthreading for a target of 2 pthreads and for functions involving # PDLs with greater than 1M elements set_autopthread_targ(2); set_autopthread_size(1); # Execute a pdl function, processing will split into two pthreads as long as # one of the pdl-threaded dimensions is divisible by 2. $a = minimum($b); # Get the actual number of pthreads that were run. $actual_pthread = get_autopthread_actual(); =cut *set_autopthread_targ = \&PDL::set_autopthread_targ; =head2 get_autopthread_targ =for ref Get the current target number of processor threads (pthreads) for multi-threaded processing. =for usage $num_pthreads = get_autopthread_targ(); C<$num_pthreads> is the target number of pthreads the auto-pthread process will try to achieve. See L for an overview of the auto-pthread process. =cut *get_autopthread_targ = \&PDL::get_autopthread_targ; =head2 get_autopthread_actual =for ref Get the actual number of pthreads executed for the last pdl processing function. =for usage $autopthread_actual = get_autopthread_actual(); C<$autopthread_actual> is the actual number of pthreads executed for the last pdl processing function. See L for an overview of the auto-pthread process. =cut *get_autopthread_actual = \&PDL::get_autopthread_actual; =head2 set_autopthread_size =for ref Set the minimum size (in M-elements or 2^20 elements) of the largest PDL involved in a function where auto-pthreading will be performed. For small PDLs, it probably isn't worth starting multiple pthreads, so this function is used to define a minimum threshold where auto-pthreading won't be attempted. =for usage set_autopthread_size($size); C<$size> is the mimumum size, in M-elements or 2^20 elements (approx 1e6 elements) for the largest PDL involved in a function. See L for an overview of the auto-pthread process. =for example # Example turning on auto-pthreading for a target of 2 pthreads and for functions involving # PDLs with greater than 1M elements set_autopthread_targ(2); set_autopthread_size(1); # Execute a pdl function, processing will split into two pthreads as long as # one of the pdl-threaded dimensions is divisible by 2. $a = minimum($b); # Get the actual number of pthreads that were run. $actual_pthread = get_autopthread_actual(); =cut *set_autopthread_size = \&PDL::set_autopthread_size; =head2 get_autopthread_size =for ref Get the current autopthread_size setting. =for usage $autopthread_size = get_autopthread_size(); C<$autopthread_size> is the mimumum size limit for auto_pthreading to occur, in M-elements or 2^20 elements (approx 1e6 elements) for the largest PDL involved in a function See L for an overview of the auto-pthread process. =cut *get_autopthread_size = \&PDL::get_autopthread_size; =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu) and Christian Soeller (c.soeller@auckland.ac.nz) 1997. Modified, Craig DeForest (deforest@boulder.swri.edu) 2002. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # # Easier to implement in perl than in XS... # -- CED # sub PDL::fhdr { my $pdl = shift; return $pdl->hdr if( (defined $pdl->gethdr) || !defined $Astro::FITS::Header::VERSION ); # Avoid bug in 1.15 and earlier Astro::FITS::Header my @hdr = ("SIMPLE = T"); my $hdr = new Astro::FITS::Header(Cards=>\@hdr); tie my %hdr, "Astro::FITS::Header", $hdr; $pdl->sethdr(\%hdr); return \%hdr; } use Fcntl; BEGIN { eval 'use File::Map 0.47 qw(:all)'; if ($@) { carp "No File::Map found, using legacy mmap (if available)\n" if $PDL::verbose; sub sys_map; sub PROT_READ(); sub PROT_WRITE(); sub MAP_SHARED(); sub MAP_PRIVATE(); } } # Implement File::Map::sys_map bug fix. Also, might be possible # to implement without so many external (non-Core perl) modules. # # sub pdl_do_sys_map { # my (undef, $length, $protection, $flags, $fh, $offset) = @_; # my $utf8 = File::Map::_check_layers($fh); # my $fd = ($flags & MAP_ANONYMOUS) ? (-1) : fileno($fh); # $offset ||= 0; # File::Map::_mmap_impl($_[0], $length, $protection, $flags, $fd, $offset, $utf8); # return; # } sub PDL::set_data_by_file_map { my ($pdl,$name,$len,$shared,$writable,$creat,$mode,$trunc) = @_; my $pdl_dataref = $pdl->get_dataref(); # Assume we have no data to free for now # pdl_freedata($pdl); sysopen(my $fh, $name, ($writable && $shared ? O_RDWR : O_RDONLY) | ($creat ? O_CREAT : 0), $mode) or die "Error opening file '$name'\n"; binmode $fh; if ($trunc) { truncate($fh,0) or die "set_data_by_mmap: truncate('$name',0) failed, $!"; truncate($fh,$len) or die "set_data_by_mmap: truncate('$name',$len) failed, $!"; } if ($len) { #eval { # pdl_do_sys_map( # will croak if the mapping fails if ($PDL::debug) { printf STDERR "set_data_by_file_map: calling sys_map(%s,%d,%d,%d,%s,%d)\n", $pdl_dataref, $len, PROT_READ | ($writable ? PROT_WRITE : 0), ($shared ? MAP_SHARED : MAP_PRIVATE), $fh, 0; } sys_map( # will croak if the mapping fails ${$pdl_dataref}, $len, PROT_READ | ($writable ? PROT_WRITE : 0), ($shared ? MAP_SHARED : MAP_PRIVATE), $fh, 0 ); #}; #if ($@) { #die("Error mmapping!, '$@'\n"); #} $pdl->upd_data; if ($PDL::debug) { printf STDERR "set_data_by_file_map: length \${\$pdl_dataref} is %d.\n", length ${$pdl_dataref}; } $pdl->set_state_and_add_deletedata_magic( length ${$pdl_dataref} ); } else { # Special case: zero-length file $_[0] = undef; } # PDLDEBUG_f(printf("PDL::MMap: mapped to %p\n",$pdl->data)); close $fh ; } 1; PDL-2.018/Basic/Core/Core.xs0000644060175006010010000010411313101130663013543 0ustar chmNone#ifndef WIN32 #include #include #include #define USE_MMAP #endif #include "EXTERN.h" /* std perl include */ #include "perl.h" /* std perl include */ #include "XSUB.h" /* XSUB include */ #if defined(CONTEXT) #undef CONTEXT #endif #define PDL_CORE /* For certain ifdefs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ #if BADVAL # if !BADVAL_USENAN #include # endif #include #endif /* Return a integer or numeric scalar as approroate */ #define setflag(reg,flagval,val) (val?(reg |= flagval):(reg &= ~flagval)) Core PDL; /* Struct holding pointers to shared C routines */ #ifdef FOO Core *pdl__Core_get_Core() /* INTERNAL TO CORE! DONT CALL FROM OUTSIDE */ { return PDL; } #endif int pdl_debugging=0; int pdl_autopthread_targ = 0; /* No auto-pthreading unless set using the set_autopthread_targ */ int pdl_autopthread_actual = 0; int pdl_autopthread_size = 1; #define CHECKP(p) if ((p) == NULL) croak("Out of memory") static PDL_Indx* pdl_packint( SV* sv, int *ndims ) { SV* bar; AV* array; int i; PDL_Indx *dims; if (!(SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)) /* Test */ return NULL; array = (AV *) SvRV(sv); /* dereference */ *ndims = (int) av_len(array) + 1; /* Number of dimensions */ /* Array space */ dims = (PDL_Indx *) pdl_malloc( (*ndims) * sizeof(*dims) ); CHECKP(dims); for(i=0; i<(*ndims); i++) { bar = *(av_fetch( array, i, 0 )); /* Fetch */ dims[i] = (PDL_Indx) SvIV(bar); } return dims; } static SV* pdl_unpackint ( PDL_Indx *dims, int ndims ) { AV* array; int i; array = newAV(); for(i=0; i ok */ av_store( array, i, newSViv( (IV)dims[i] ) ); return (SV*) array; } /* * Free the data if possible; used by mmapper * Moved from pdlhash.c July 10 2006 DJB */ static void pdl_freedata (pdl *a) { if(a->datasv) { SvREFCNT_dec(a->datasv); a->datasv=0; a->data=0; } else if(a->data) { die("Trying to free data of untouchable (mmapped?) pdl"); } } #if BADVAL #ifdef FOOFOO_PROPAGATE_BADFLAG /* * this seems to cause an infinite loop in between tests 42 & 43 of * t/bad.t - ie * * $a = sequence( byte, 2, 3 ); * $b = $a->slice("(1),:"); * my $mask = sequence( byte, 2, 3 ); * $mask = $mask->setbadif( ($mask % 3) == 2 ); * print "a,b == ", $a->badflag, ",", $b->badflag, "\n"; * $a->inplace->copybad( $mask ); <-- think this is the call * print "a,b == ", $a->badflag, ",", $b->badflag, "\n"; * print "$a $b\n"; * ok( $b->badflag, 1 ); * */ /* used by propagate_badflag() */ void propagate_badflag_children( pdl *it, int newval ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) { pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); int i; for( i = trans->vtable->nparents; i < trans->vtable->npdls; i++ ) { pdl *child = trans->pdls[i]; if ( newval ) child->state |= PDL_BADVAL; else child->state &= ~PDL_BADVAL; /* make sure we propagate to grandchildren, etc */ propagate_badflag_children( child, newval ); } /* for: i */ } PDL_END_CHILDLOOP(it) } /* propagate_badflag_children */ /* used by propagate_badflag() */ void propagate_badflag_parents( pdl *it ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) { pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); int i; for( i = 0; i < trans->vtable->nparents; i++ ) { pdl *parent = trans->pdls[i]; /* only sets allowed here */ parent->state |= PDL_BADVAL; /* make sure we propagate to grandparents, etc */ propagate_badflag_parents( parent ); } /* for: i */ } PDL_END_CHILDLOOP(it) } /* propagate_badflag_parents */ /* * we want to change the bad flag of the children * (newval = 1 means set flag, 0 means clear it). * If newval == 1, then we also loop through the * parents, setting their bad flag * * thanks to Christian Soeller for this */ void propagate_badflag( pdl *it, int newval ) { /* only do anything if the flag has changed - do we need this check ? */ if ( newval ) { if ( (it->state & PDL_BADVAL) == 0 ) { propagate_badflag_parents( it ); propagate_badflag_children( it, newval ); } } else { if ( (it->state & PDL_BADVAL) > 0 ) { propagate_badflag_children( it, newval ); } } } /* propagate_badflag */ #else /* FOOFOO_PROPAGATE_BADFLAG */ /* newval = 1 means set flag, 0 means clear it */ /* thanks to Christian Soeller for this */ void propagate_badflag( pdl *it, int newval ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) { pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); int i; for( i = trans->vtable->nparents; i < trans->vtable->npdls; i++ ) { pdl *child = trans->pdls[i]; if ( newval ) child->state |= PDL_BADVAL; else child->state &= ~PDL_BADVAL; /* make sure we propagate to grandchildren, etc */ propagate_badflag( child, newval ); } /* for: i */ } PDL_END_CHILDLOOP(it) } /* propagate_badflag */ #endif /* FOOFOO_PROPAGATE_BADFLAG */ void propagate_badvalue( pdl *it ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) { pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); int i; for( i = trans->vtable->nparents; i < trans->vtable->npdls; i++ ) { pdl *child = trans->pdls[i]; child->has_badvalue = 1; child->badvalue = it->badvalue; /* make sure we propagate to grandchildren, etc */ propagate_badvalue( child ); } /* for: i */ } PDL_END_CHILDLOOP(it) } /* propagate_badvalue */ /* this is horrible - the routines from bad should perhaps be here instead ? */ PDL_Anyval pdl_get_badvalue( int datatype ) { PDL_Anyval retval = { -1, 0 }; switch ( datatype ) { #include "pdldataswitch.c" default: croak("Unknown type sent to pdl_get_badvalue\n"); } return retval; } /* pdl_get_badvalue() */ PDL_Anyval pdl_get_pdl_badvalue( pdl *it ) { PDL_Anyval retval = { -1, 0 }; int datatype; #if BADVAL_PER_PDL if (it->has_badvalue) { retval = it->badvalue; } else { datatype = it->datatype; retval = pdl_get_badvalue( datatype ); } #else datatype = it->datatype; retval = pdl_get_badvalue( datatype ); #endif return retval; } /* pdl_get_pdl_badvalue() */ #endif MODULE = PDL::Core PACKAGE = PDL # Destroy a PDL - note if a hash do nothing, the $$x{PDL} component # will be destroyed anyway on a separate call void DESTROY(sv) SV * sv; PREINIT: pdl *self; CODE: if ( !( (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV) ) ) { self = SvPDLV(sv); PDLDEBUG_f(printf("DESTROYING %p\n",(void*)self);) if (self != NULL) pdl_destroy(self); } # Return the transformation object or an undef otherwise. SV * get_trans(self) pdl *self; CODE: ST(0) = sv_newmortal(); if(self->trans) { sv_setref_pv(ST(0), "PDL::Trans", (void*)(self->trans)); } else { ST(0) = &PL_sv_undef; } MODULE = PDL::Core PACKAGE = PDL int iscontig(x) pdl* x CODE: RETVAL = 1; pdl_make_physvaffine( x ); if PDL_VAFFOK(x) { int i; PDL_Indx inc=1; PDLDEBUG_f(printf("vaff check...\n");) for (i=0;indims;i++) { if (PDL_REPRINC(x,i) != inc) { RETVAL = 0; break; } inc *= x->dims[i]; } } OUTPUT: RETVAL # using "perl" not $^X because that doesn't work on "perl in space" # TODO: switching back to $^X since using "perl" is not a viable fix INCLUDE_COMMAND: $^X -e "require q{./Dev.pm}; PDL::Core::Dev::generate_core_flags()" #if 0 =begin windows_mmap I found this at http://mollyrocket.com/forums/viewtopic.php?p=2529&sid=973b8e0a1e639e3008d7ef05f686c6fa and thougt we might consider using it to make windows mmapping possible. -David Mertens /* This code was placed in the public domain by the author, Sean Barrett, in November 2007. Do with it as you will. (Seee the page for stb_vorbis or the mollyrocket source page for a longer description of the public domain non-license). */ #define WIN32_LEAN_AND_MEAN #include typedef struct { HANDLE f; HANDLE m; void *p; } SIMPLE_UNMMAP; // map 'filename' and return a pointer to it. fill out *length and *un if not-NULL void *simple_mmap(const char *filename, int *length, SIMPLE_UNMMAP *un) { HANDLE f = CreateFile(filename, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); HANDLE m; void *p; if (!f) return NULL; m = CreateFileMapping(f, NULL, PAGE_READONLY, 0,0, NULL); if (!m) { CloseHandle(f); return NULL; } p = MapViewOfFile(m, FILE_MAP_READ, 0,0,0); if (!p) { CloseHandle(m); CloseHandle(f); return NULL; } if (n) *n = GetFileSize(f, NULL); if (un) { un->f = f; un->m = m; un->p = p; } return p; } void simple_unmmap(SIMPLE_UNMMAP *un) { UnmapViewOfFile(un->p); CloseHandle(un->m); CloseHandle(un->f); } =end windows_mmap =cut #endif /* 0 - commented out */ void set_inplace(self,val) pdl *self; int val; CODE: setflag(self->state,PDL_INPLACE,val); IV address(self) pdl *self; CODE: RETVAL = PTR2IV(self); OUTPUT: RETVAL pdl * pdl_hard_copy(src) pdl *src; pdl * sever(src) pdl *src; CODE: if(src->trans) { pdl_make_physvaffine(src); pdl_destroytransform(src->trans,1); } RETVAL=src; OUTPUT: RETVAL int set_data_by_mmap(it,fname,len,shared,writable,creat,mode,trunc) pdl *it char *fname STRLEN len int writable int shared int creat int mode int trunc CODE: #ifdef USE_MMAP int fd; pdl_freedata(it); fd = open(fname,(writable && shared ? O_RDWR : O_RDONLY)| (creat ? O_CREAT : 0),mode); if(fd < 0) { croak("Error opening file"); } if(trunc) { int error = ftruncate(fd,0); /* Clear all previous data */ if(error) { fprintf(stderr,"Failed to set length of '%s' to %d. errno=%d",fname,(int)len,(int)error); croak("set_data_by_mmap: first ftruncate failed"); } error = ftruncate(fd,len); /* And make it long enough */ if(error) { fprintf(stderr,"Failed to set length of '%s' to %d. errno=%d",fname,(int)len,(int)error); croak("set_data_by_mmap: second ftruncate failed"); } } if(len) { it->data = mmap(0,len,PROT_READ | (writable ? PROT_WRITE : 0), (shared ? MAP_SHARED : MAP_PRIVATE), fd,0); if(!it->data) croak("Error mmapping!"); } else { /* Special case: zero-length file */ it->data = NULL; } PDLDEBUG_f(printf("PDL::MMap: mapped to %p\n",it->data);) it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; pdl_add_deletedata_magic(it, pdl_delete_mmapped_data, len); close(fd); #else croak("mmap not supported on this architecture"); #endif RETVAL = 1; OUTPUT: RETVAL int set_state_and_add_deletedata_magic(it,len) pdl *it STRLEN len CODE: it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; pdl_add_deletedata_magic(it, pdl_delete_mmapped_data, len); RETVAL = 1; OUTPUT: RETVAL int set_data_by_offset(it,orig,offset) pdl *it pdl *orig STRLEN offset CODE: pdl_freedata(it); it->data = ((char *) orig->data) + offset; it->datasv = orig->sv; (void)SvREFCNT_inc(it->datasv); it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; RETVAL = 1; OUTPUT: RETVAL PDL_Indx nelem(x) pdl *x CODE: pdl_make_physdims(x); RETVAL = x->nvals; OUTPUT: RETVAL # Convert PDL to new datatype (called by float(), int() etc.) # SV * # convert(a,datatype) # pdl* a # int datatype # CODE: # pdl* b; # pdl_make_physical(a); # RETVAL = pdl_copy(a,""); /* Init value to return */ # b = SvPDLV(RETVAL); /* Map */ # pdl_converttype( &b, datatype, PDL_PERM ); # PDLDEBUG_f(printf("converted %d, %d, %d, %d\n",a, b, a->datatype, b->datatype)); # OUTPUT: # RETVAL # Call my howbig function int howbig_c(datatype) int datatype CODE: RETVAL = pdl_howbig(datatype); OUTPUT: RETVAL int set_autopthread_targ(i) int i; CODE: RETVAL = i; pdl_autopthread_targ = i; OUTPUT: RETVAL int get_autopthread_targ() CODE: RETVAL = pdl_autopthread_targ; OUTPUT: RETVAL int set_autopthread_size(i) int i; CODE: RETVAL = i; pdl_autopthread_size = i; OUTPUT: RETVAL int get_autopthread_size() CODE: RETVAL = pdl_autopthread_size; OUTPUT: RETVAL int get_autopthread_actual() CODE: RETVAL = pdl_autopthread_actual; OUTPUT: RETVAL MODULE = PDL::Core PACKAGE = PDL::Core unsigned int is_scalar_SvPOK(arg) SV* arg; CODE: RETVAL = SvPOK(arg); OUTPUT: RETVAL int set_debugging(i) int i; CODE: RETVAL = pdl_debugging; pdl_debugging = i; OUTPUT: RETVAL SV * sclr_c(it) pdl* it PREINIT: PDL_Indx nullp = 0; PDL_Indx dummyd = 1; PDL_Indx dummyi = 1; PDL_Anyval result = { -1, 0 }; CODE: /* get the first element of a piddle and return as * Perl scalar (autodetect suitable type IV or NV) */ pdl_make_physvaffine( it ); if (it->nvals < 1) croak("piddle must have at least one element"); /* offs = PDL_REPROFFS(it); */ /* result = pdl_get_offs(PDL_REPRP(it),offs); */ result=pdl_at(PDL_REPRP(it), it->datatype, &nullp, &dummyd, &dummyi, PDL_REPROFFS(it),1); ANYVAL_TO_SV(RETVAL, result); OUTPUT: RETVAL SV * at_c(x,position) pdl* x SV* position PREINIT: PDL_Indx * pos; int npos; int ipos; PDL_Anyval result = { -1, 0 }; CODE: pdl_make_physvaffine( x ); pos = pdl_packdims( position, &npos); if (pos == NULL || npos < x->ndims) croak("Invalid position"); /* allow additional trailing indices * which must be all zero, i.e. a * [3,1,5] piddle is treated as an [3,1,5,1,1,1,....] * infinite dim piddle */ for (ipos=x->ndims; iposdatatype, pos, x->dims, (PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs), PDL_REPROFFS(x), x->ndims); ANYVAL_TO_SV(RETVAL, result); OUTPUT: RETVAL SV * at_bad_c(x,position) pdl* x SV * position PREINIT: PDL_Indx * pos; int npos; int ipos; int badflag; PDL_Anyval result = { -1, 0 }; CODE: pdl_make_physvaffine( x ); pos = pdl_packdims( position, &npos); if (pos == NULL || npos < x->ndims) croak("Invalid position"); /* allow additional trailing indices * which must be all zero, i.e. a * [3,1,5] piddle is treated as an [3,1,5,1,1,1,....] * infinite dim piddle */ for (ipos=x->ndims; iposdatatype, pos, x->dims, (PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs), PDL_REPROFFS(x), x->ndims); #if BADVAL badflag = (x->state & PDL_BADVAL) > 0; # if BADVAL_USENAN /* do we have to bother about NaN's? */ if ( badflag && ( ( x->datatype < PDL_F && ANYVAL_EQ_ANYVAL(result, pdl_get_badvalue(x->datatype)) ) || ( x->datatype == PDL_F && finite(result.value.F) == 0 ) || ( x->datatype == PDL_D && finite(result.value.D) == 0 ) ) ) { RETVAL = newSVpvn( "BAD", 3 ); } else # else if ( badflag && ANYVAL_EQ_ANYVAL( result, pdl_get_badvalue( x->datatype ) ) ) { RETVAL = newSVpvn( "BAD", 3 ); } else # endif #endif ANYVAL_TO_SV(RETVAL, result); OUTPUT: RETVAL void list_c(x) pdl *x PREINIT: PDL_Indx *inds; PDL_Indx *incs; PDL_Indx offs; void *data; int ind; int stop = 0; SV *sv; PPCODE: pdl_make_physvaffine( x ); inds = pdl_malloc(sizeof(PDL_Indx) * x->ndims); /* GCC -> on stack :( */ data = PDL_REPRP(x); incs = (PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs); offs = PDL_REPROFFS(x); EXTEND(sp,x->nvals); for(ind=0; ind < x->ndims; ind++) inds[ind] = 0; while(!stop) { PDL_Anyval pdl_val = { -1, 0 }; pdl_val = pdl_at( data, x->datatype, inds, x->dims, incs, offs, x->ndims); ANYVAL_TO_SV(sv,pdl_val); PUSHs(sv_2mortal(sv)); stop = 1; for(ind = 0; ind < x->ndims; ind++) if(++(inds[ind]) >= x->dims[ind]) inds[ind] = 0; else {stop = 0; break;} } # returns the string 'BAD' if an element is bad # SV * listref_c(x) pdl *x PREINIT: PDL_Indx * inds; PDL_Indx * incs; PDL_Indx offs; void *data; int ind; int lind; int stop = 0; AV *av; SV *sv; PDL_Anyval pdl_val = { -1, 0 }; PDL_Anyval pdl_badval = { -1, 0 }; CODE: #if BADVAL /* # note: # the badvalue is stored in a PDL_Anyval, but that's what pdl_at() # returns */ int badflag = (x->state & PDL_BADVAL) > 0; # if BADVAL_USENAN /* do we have to bother about NaN's? */ if ( badflag && x->datatype < PDL_F ) { pdl_badval = pdl_get_pdl_badvalue( x ); } # else if ( badflag ) { pdl_badval = pdl_get_pdl_badvalue( x ); } # endif #endif pdl_make_physvaffine( x ); inds = pdl_malloc(sizeof(PDL_Indx) * x->ndims); /* GCC -> on stack :( */ data = PDL_REPRP(x); incs = (PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs); offs = PDL_REPROFFS(x); av = newAV(); av_extend(av,x->nvals); lind=0; for(ind=0; ind < x->ndims; ind++) inds[ind] = 0; while(!stop) { #if BADVAL pdl_val = pdl_at( data, x->datatype, inds, x->dims, incs, offs, x->ndims ); if ( badflag && # if BADVAL_USENAN ( (x->datatype < PDL_F && ANYVAL_EQ_ANYVAL(pdl_val, pdl_badval)) || (x->datatype == PDL_F && finite(pdl_val.value.F) == 0) || (x->datatype == PDL_D && finite(pdl_val.value.D) == 0) ) # else ANYVAL_EQ_ANYVAL(pdl_val, pdl_badval) # endif ) { sv = newSVpvn( "BAD", 3 ); } else { ANYVAL_TO_SV(sv, pdl_val); } av_store( av, lind, sv ); #else pdl_val = pdl_at( data, x->datatype, inds, x->dims, incs, offs, x->ndims ); ANYVAL_TO_SV(sv, pdl_val); av_store(av, lind, sv); #endif lind++; stop = 1; for(ind = 0; ind < x->ndims; ind++) { if(++(inds[ind]) >= x->dims[ind]) { inds[ind] = 0; } else { stop = 0; break; } } } RETVAL = newRV_noinc((SV *)av); OUTPUT: RETVAL void set_c(x,position,value) pdl* x SV* position PDL_Anyval value PREINIT: PDL_Indx * pos; int npos; int ipos; CODE: pdl_make_physvaffine( x ); pos = pdl_packdims( position, &npos); if (pos == NULL || npos < x->ndims) croak("Invalid position"); /* allow additional trailing indices * which must be all zero, i.e. a * [3,1,5] piddle is treated as an [3,1,5,1,1,1,....] * infinite dim piddle */ for (ipos=x->ndims; iposdatatype, pos, x->dims, (PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs), PDL_REPROFFS(x), x->ndims,value); if (PDL_VAFFOK(x)) pdl_vaffinechanged(x, PDL_PARENTDATACHANGED); else pdl_changed( x , PDL_PARENTDATACHANGED , 0 ); BOOT: { #if NVSIZE > 8 fprintf(stderr, "Your perl NV has more precision than PDL_Double. There will be loss of floating point precision!\n"); #endif /* Initialize structure of pointers to core C routines */ PDL.Version = PDL_CORE_VERSION; PDL.SvPDLV = SvPDLV; PDL.SetSV_PDL = SetSV_PDL; PDL.create = pdl_create; PDL.pdlnew = pdl_external_new; PDL.tmp = pdl_external_tmp; PDL.destroy = pdl_destroy; PDL.null = pdl_null; PDL.copy = pdl_copy; PDL.hard_copy = pdl_hard_copy; PDL.converttype = pdl_converttype; PDL.twod = pdl_twod; PDL.smalloc = pdl_malloc; PDL.howbig = pdl_howbig; PDL.packdims = pdl_packdims; PDL.unpackdims = pdl_unpackdims; PDL.setdims = pdl_setdims; PDL.grow = pdl_grow; PDL.flushcache = NULL; PDL.reallocdims = pdl_reallocdims; PDL.reallocthreadids = pdl_reallocthreadids; PDL.resize_defaultincs = pdl_resize_defaultincs; PDL.get_threadoffsp = pdl_get_threadoffsp; PDL.thread_copy = pdl_thread_copy; PDL.clearthreadstruct = pdl_clearthreadstruct; PDL.initthreadstruct = pdl_initthreadstruct; PDL.startthreadloop = pdl_startthreadloop; PDL.iterthreadloop = pdl_iterthreadloop; PDL.freethreadloop = pdl_freethreadloop; PDL.thread_create_parameter = pdl_thread_create_parameter; PDL.add_deletedata_magic = pdl_add_deletedata_magic; PDL.setdims_careful = pdl_setdims_careful; PDL.put_offs = pdl_put_offs; PDL.get_offs = pdl_get_offs; PDL.get = pdl_get; PDL.set_trans_childtrans = pdl_set_trans_childtrans; PDL.set_trans_parenttrans = pdl_set_trans_parenttrans; PDL.get_convertedpdl = pdl_get_convertedpdl; PDL.make_trans_mutual = pdl_make_trans_mutual; PDL.trans_mallocfreeproc = pdl_trans_mallocfreeproc; PDL.make_physical = pdl_make_physical; PDL.make_physdims = pdl_make_physdims; PDL.make_physvaffine = pdl_make_physvaffine; PDL.pdl_barf = pdl_barf; PDL.pdl_warn = pdl_warn; PDL.allocdata = pdl_allocdata; PDL.safe_indterm = pdl_safe_indterm; PDL.children_changesoon = pdl_children_changesoon; PDL.changed = pdl_changed; PDL.vaffinechanged = pdl_vaffinechanged; PDL.NaN_float = union_nan_float.f; PDL.NaN_double = union_nan_double.d; #if BADVAL PDL.propagate_badflag = propagate_badflag; PDL.propagate_badvalue = propagate_badvalue; PDL.get_pdl_badvalue = pdl_get_pdl_badvalue; #include "pdlbadvalinit.c" #endif /* "Publish" pointer to this structure in perl variable for use by other modules */ sv_setiv(get_sv("PDL::SHARE",TRUE|GV_ADDMULTI), PTR2IV(&PDL)); } # make piddle belonging to 'class' and of type 'type' # from avref 'array_ref' which is checked for being # rectangular first SV* pdl_avref(array_ref, class, type) SV* array_ref char* class int type PREINIT: AV *dims, *av; int i, depth; int datalevel = -1; SV* psv; pdl* p; CODE: /* make a piddle from a Perl array ref */ if (!SvROK(array_ref)) croak("pdl_avref: not a reference"); if (SvTYPE(SvRV(array_ref)) != SVt_PVAV) croak("pdl_avref: not an array reference"); // Expand the array ref to a list, and allocate a Perl list to hold the dimlist av = (AV *) SvRV(array_ref); dims = (AV *) sv_2mortal( (SV *) newAV()); av_store(dims,0,newSViv((IV) av_len(av)+1)); /* even if we contain nothing depth is one */ depth = 1 + av_ndcheck(av,dims,0,&datalevel); /* printf("will make type %s\n",class); */ /* at this stage start making a piddle and populate it with values from the array (which has already been checked in av_check) */ if (strcmp(class,"PDL") == 0) { p = pdl_from_array(av,dims,type,NULL); /* populate with data */ ST(0) = sv_newmortal(); SetSV_PDL(ST(0),p); } else { /* call class->initialize method */ PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(class, 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; psv = POPs; PUTBACK; p = SvPDLV(psv); /* and get piddle from returned object */ ST(0) = psv; pdl_from_array(av,dims,type,p); /* populate ;) */ } MODULE = PDL::Core PACKAGE = PDL # pdl_null is created/imported with no PREFIX as pdl_null. # 'null' is supplied in Core.pm that calls 'initialize' which calls # the pdl_null here pdl * pdl_null(...) MODULE = PDL::Core PACKAGE = PDL::Core PREFIX = pdl_ int pdl_pthreads_enabled() MODULE = PDL::Core PACKAGE = PDL PREFIX = pdl_ int isnull(self) pdl *self; CODE: RETVAL= !!(self->state & PDL_NOMYDIMS); OUTPUT: RETVAL pdl * make_physical(self) pdl *self; CODE: pdl_make_physical(self); RETVAL = self; OUTPUT: RETVAL pdl * make_physvaffine(self) pdl *self; CODE: pdl_make_physvaffine(self); RETVAL = self; OUTPUT: RETVAL pdl * make_physdims(self) pdl *self; CODE: pdl_make_physdims(self); RETVAL = self; OUTPUT: RETVAL void pdl_dump(x) pdl *x; void pdl_add_threading_magic(it,nthdim,nthreads) pdl *it int nthdim int nthreads void pdl_remove_threading_magic(it) pdl *it CODE: pdl_add_threading_magic(it,-1,-1); MODULE = PDL::Core PACKAGE = PDL SV * initialize(class) SV *class PREINIT: HV *bless_stash; PPCODE: if (SvROK(class)) { /* a reference to a class */ bless_stash = SvSTASH(SvRV(class)); } else { /* a class name */ bless_stash = gv_stashsv(class, 0); } ST(0) = sv_newmortal(); SetSV_PDL(ST(0),pdl_null()); /* set a null PDL to this SV * */ ST(0) = sv_bless(ST(0), bless_stash); /* bless appropriately */ XSRETURN(1); SV * get_dataref(self) pdl *self CODE: if(self->state & PDL_DONTTOUCHDATA) { croak("Trying to get dataref to magical (mmaped?) pdl"); } pdl_make_physical(self); /* XXX IS THIS MEMLEAK WITHOUT MORTAL? */ RETVAL = (newRV(self->datasv)); OUTPUT: RETVAL int get_datatype(self) pdl *self CODE: RETVAL = self->datatype; OUTPUT: RETVAL int upd_data(self) pdl *self PREINIT: STRLEN n_a; CODE: if(self->state & PDL_DONTTOUCHDATA) { croak("Trying to touch dataref of magical (mmaped?) pdl"); } self->data = SvPV((SV*)self->datasv,n_a); XSRETURN(0); void set_dataflow_f(self,value) pdl *self; int value; CODE: if(value) self->state |= PDL_DATAFLOW_F; else self->state &= ~PDL_DATAFLOW_F; void set_dataflow_b(self,value) pdl *self; int value; CODE: if(value) self->state |= PDL_DATAFLOW_B; else self->state &= ~PDL_DATAFLOW_B; int getndims(x) pdl *x ALIAS: PDL::ndims = 1 CODE: pdl_make_physdims(x); RETVAL = x->ndims; OUTPUT: RETVAL PDL_Indx getdim(x,y) pdl *x int y ALIAS: PDL::dim = 1 CODE: pdl_make_physdims(x); if (y < 0) y = x->ndims + y; if (y < 0) croak("negative dim index too large"); if (y < x->ndims) RETVAL = x->dims[y]; else RETVAL = 1; /* return size 1 for all other dims */ OUTPUT: RETVAL int getnthreadids(x) pdl *x CODE: pdl_make_physdims(x); RETVAL = x->nthreadids; OUTPUT: RETVAL int getthreadid(x,y) pdl *x int y CODE: RETVAL = x->threadids[y]; OUTPUT: RETVAL void setdims(x,dims_arg) pdl *x SV * dims_arg PREINIT: PDL_Indx * dims; int ndims; int i; CODE: { /* This mask avoids all kinds of subtle dereferencing bugs (CED 11/2015) */ if(x->trans || x->vafftrans || x->children.next ) { pdl_barf("Can't setdims on a PDL that already has children"); } /* not sure if this is still necessary with the mask above... (CED 11/2015) */ pdl_children_changesoon(x,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); dims = pdl_packdims(dims_arg,&ndims); pdl_reallocdims(x,ndims); for(i=0; idims[i] = dims[i]; pdl_resize_defaultincs(x); x->threadids[0] = ndims; x->state &= ~PDL_NOMYDIMS; pdl_changed(x,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); } void dowhenidle() CODE: pdl_run_delayed_magic(); XSRETURN(0); void bind(p,c) pdl *p SV *c PROTOTYPE: $& CODE: pdl_add_svmagic(p,c); XSRETURN(0); void sethdr(p,h) pdl *p SV *h PREINIT: HV* hash; CODE: if(p->hdrsv == NULL) { p->hdrsv = &PL_sv_undef; /*(void*) newSViv(0);*/ } /* Throw an error if we're not either undef or hash */ if ( (h != &PL_sv_undef && h != NULL) && ( !SvROK(h) || SvTYPE(SvRV(h)) != SVt_PVHV ) ) croak("Not a HASH reference"); /* Clear the old header */ SvREFCNT_dec(p->hdrsv); /* Put the new header (or undef) in place */ if(h == &PL_sv_undef || h == NULL) p->hdrsv = NULL; else p->hdrsv = (void*) newRV( (SV*) SvRV(h) ); SV * hdr(p) pdl *p CODE: pdl_make_physdims(p); /* Make sure that in the undef case we return not */ /* undef but an empty hash ref. */ if((p->hdrsv==NULL) || (p->hdrsv == &PL_sv_undef)) { p->hdrsv = (void*) newRV_noinc( (SV*)newHV() ); } RETVAL = newRV( (SV*) SvRV((SV*)p->hdrsv) ); OUTPUT: RETVAL # fhdr(p) is implemented in perl; see Core.pm.PL if you're looking for it # --CED 9-Feb-2003 # SV * gethdr(p) pdl *p CODE: pdl_make_physdims(p); if((p->hdrsv==NULL) || (p->hdrsv == &PL_sv_undef)) { RETVAL = &PL_sv_undef; } else { RETVAL = newRV( (SV*) SvRV((SV*)p->hdrsv) ); } OUTPUT: RETVAL void set_datatype(a,datatype) pdl *a int datatype CODE: pdl_make_physical(a); if(a->trans) pdl_destroytransform(a->trans,1); /* if(! (a->state && PDL_NOMYDIMS)) { */ pdl_converttype( &a, datatype, PDL_PERM ); /* } */ void threadover_n(...) PREINIT: int npdls; SV *sv; CODE: { npdls = items - 1; if(npdls <= 0) croak("Usage: threadover_n(pdl[,pdl...],sub)"); { int i,sd; pdl **pdls = malloc(sizeof(pdl *) * npdls); PDL_Indx *realdims = malloc(sizeof(PDL_Indx) * npdls); pdl_thread pdl_thr; SV *code = ST(items-1); for(i=0; i 0) nothers = SvIV(ST(0)); if(targs <= 0 || nothers < 0 || nothers >= targs) croak("Usage: threadover(nothers,pdl[,pdl...][,otherpars..],realdims,creating,sub)"); npdls = targs-nothers; { int i,nd1,nd2,dtype=0; PDL_Indx j,nc=npdls; SV* rdimslist = ST(items-3); SV* cdimslist = ST(items-2); SV *code = ST(items-1); pdl_thread pdl_thr; pdl **pdls = malloc(sizeof(pdl *) * npdls); pdl **child = malloc(sizeof(pdl *) * npdls); SV **csv = malloc(sizeof(SV *) * npdls); SV **dims = malloc(sizeof(SV *) * npdls); SV **incs = malloc(sizeof(SV *) * npdls); SV **others = malloc(sizeof(SV *) * nothers); PDL_Indx *creating = pdl_packint(cdimslist,&nd2); PDL_Indx *realdims = pdl_packint(rdimslist,&nd1); CHECKP(pdls); CHECKP(child); CHECKP(dims); CHECKP(incs); CHECKP(csv); if (nd1 != npdls || nd2 < npdls) croak("threadover: need one realdim and creating flag " "per pdl!"); for(i=0; idatatype); } } for (i=npdls+1; i<=targs; i++) others[i-npdls-1] = ST(i); if (nd2 < nc) croak("Not enough dimension info to create pdls"); #ifdef DEBUG_PTHREAD for (i=0;idims[j]); printf("] Incs: ["); for (j=0;jdatatype = dtype; pdl_thread_create_parameter(&pdl_thr,i,cp,0); nc += realdims[i]; pdl_make_physical(pdls[i]); PDLDEBUG_f(pdl_dump(pdls[i])); /* And make it nonnull, now that we've created it */ pdls[i]->state &= (~PDL_NOMYDIMS); } pdl_startthreadloop(&pdl_thr,NULL,NULL); for(i=0; idims,realdims[i])); incs[i] = newRV(pdl_unpackint(PDL_VAFFOK(pdls[i]) ? pdls[i]->vafftrans->incs: pdls[i]->dimincs,realdims[i])); /* need to make sure we get the vaffine (grand)parent */ if (PDL_VAFFOK(pdls[i])) pdls[i] = pdls[i]->vafftrans->from; child[i]=pdl_null(); /* instead of pdls[i] its vaffine parent !!!XXX */ PDL.affine_new(pdls[i],child[i],pdl_thr.offs[i],dims[i], incs[i]); pdl_make_physical(child[i]); /* make sure we can get at the vafftrans */ csv[i] = sv_newmortal(); SetSV_PDL(csv[i], child[i]); /* pdl* into SV* */ } do { /* the actual threadloop */ pdl_trans_affine *traff; dSP; PUSHMARK(sp); EXTEND(sp,npdls); for(i=0; itrans; traff->offs = pdl_thr.offs[i]; child[i]->vafftrans->offs = pdl_thr.offs[i]; child[i]->state |= PDL_PARENTDATACHANGED; PUSHs(csv[i]); } for (i=0; islice("5:10,2:30")->px->diagonal(3,4); PDL->px; =head1 DESCRIPTION These packages implements a couple of functions that should come in handy when debugging your PDL scripts. They make a lot of sense while you're doing rapid prototyping of new PDL code, let's say inside the perldl or pdl2 shell. =cut #' fool emacs package PDL::Dbg; # used by info $PDL::Dbg::Title = "Type Dimension Flow State Mem"; $PDL::Dbg::Infostr = "%6T %-15D %3F %-5S %12M"; package PDL; =head1 FUNCTIONS =head2 px =for ref Print info about a piddle (or all known piddles) =for example pdl> PDL->px pdl> $b += $a->clump(2)->px('clumptest')->sumover pdl> $a->px('%C (%A) Type: %T') # prints nothing unless $PDL::debug pdl> $PDL::debug = 1 pdl> $a->px('%C (%A) Type: %T') PDL (52433464) Type: Double This function prints some information about piddles. It can be invoked as a class method (e.g. Cpx> ) or as an instance method (e.g. C<$pdl-Epx($arg)>). If =over 2 =item invoked as a class method it prints info about all piddles found in the current package (I C variables). This comes in quite handy when you are not quite sure which pdls you have already defined, what data they hold , etc. C is supposed to support inheritance and prints info about all symbols for which an C is true. An optional string argument is interpreted as the package name for which to print symbols: pdl> PDL->px('PDL::Mypack') The default package is that of the caller. =item invoked as an instance method it prints info about that particular piddle if C<$PDL::debug> is true and returns the pdl object upon completion. It accepts an optional string argument that is simply prepended to the default info if it doesn't contain a C<%> character. If, however, the argument contains a C<%> then the string is passed to the C method to control the format of the printed information. This can be used to achieve customized output from C. See the documentation of C for further details. =back The output of px will be determined by the default formatting string that is passed to the C method (unless you pass a string containing C<%> to px when invoking as an instance method, see above). This default string is stored in C<$PDL::Dbg::Infostr> and the default output format can be accordingly changed by setting this variable. If you do this you should also change the default title string that the class method branch prints at the top of the listing to match your new format string. The default title is stored in the variable C<$PDL::Dbg::Title>. For historical reasons C is an alias for C. =cut sub px { my $arg = shift; my $str=""; if (ref($arg)) { return $arg unless $PDL::debug; my $info = $arg->info($#_ > -1 ? ($_[0] =~ /%/ ? $_[0] : "$_[0] $PDL::Dbg::Infostr") : $PDL::Dbg::Infostr); print "$info\n"; return $arg; } # we have been called as a class method my $package = $#_ > -1 ? shift : caller; my $classname = $arg; # find the correct package $package .= "::" unless $package =~ /::$/; *stab = *{"main::"}; while ($package =~ /(\w+?::)/g){ *stab = $ {stab}{$1}; } print "$classname variables in package $package\n\n"; my $title = "Name $PDL::Dbg::Title\n"; print $title; print '-'x(length($title)+3)."\n"; my ($pdl,$npdls,$key,$val,$info) = ((),0,"","",""); # while (($key,$val) = each(%stab)) { foreach $key ( sort { lc($a) cmp lc($b) } keys(%stab) ) { $val = $stab{$key}; $pdl = ${"$package$key"}; # print info for all objects derived from this class if (UNIVERSAL::isa($pdl,$classname)) { $npdls++; $info = $pdl->info($PDL::Dbg::Infostr); printf "\$%-11s %s %s\n",$key,$info,(ref($pdl) eq $classname ? '' : ref($pdl)); # also print classname for derived classes } } print "no $classname objects in package $package\n" unless $npdls; return $arg; } =head2 vars =for ref Alias for C =cut # make vars an alias # I hope this works with inheritance *vars = \&px; 1; # return success =head1 BUGS There are probably some. Please report if you find any. Bug reports should be sent to the PDL mailing list pdl-general@lists.sourceforge.net. =head1 AUTHOR Copyright(C) 1997 Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. PDL-2.018/Basic/Core/Dev.pm0000644060175006010010000005373213036512174013375 0ustar chmNone=head1 NAME PDL::Core::Dev - PDL development module =head1 DESCRIPTION This module encapsulates most of the stuff useful for PDL development and is often used from within Makefile.PL's. =head1 SYNOPSIS use PDL::Core::Dev; =head1 FUNCTIONS =cut # Stuff used in development/install environment of PDL Makefile.PL's # - not part of PDL itself. package PDL::Core::Dev; use File::Path; use File::Basename; use ExtUtils::Manifest; use English; require Exporter; @ISA = qw( Exporter ); @EXPORT = qw( isbigendian genpp %PDL_DATATYPES PDL_INCLUDE PDL_TYPEMAP PDL_AUTO_INCLUDE PDL_BOOT PDL_INST_INCLUDE PDL_INST_TYPEMAP pdlpp_postamble_int pdlpp_stdargs_int pdlpp_postamble pdlpp_stdargs write_dummy_make unsupported getcyglib trylink pdlpp_mkgen ); # Installation locations # beware: whereami_any now appends the /Basic or /PDL directory as appropriate # The INST are here still just in case we want to change something later. # print STDERR "executing PDL::Core::Dev from",join(',',caller),"\n"; # Return library locations sub PDL_INCLUDE { '"-I'.whereami_any().'/Core"' }; sub PDL_TYPEMAP { whereami_any().'/Core/typemap.pdl' }; # sub PDL_INST_INCLUDE { '-I'.whereami_any().'/Core' }; # sub PDL_INST_TYPEMAP { whereami_any().'/Core/typemap.pdl' }; sub PDL_INST_INCLUDE {&PDL_INCLUDE} sub PDL_INST_TYPEMAP {&PDL_TYPEMAP} sub PDL_AUTO_INCLUDE { my ($symname) = @_; $symname ||= 'PDL'; return << "EOR"; #include static Core* $symname; /* Structure holds core C functions */ static SV* CoreSV; /* Gets pointer to perl var holding core structure */ EOR } sub PDL_BOOT { my ($symname, $module) = @_; $symname ||= 'PDL'; $module ||= 'The code'; return << "EOR"; perl_require_pv ("PDL/Core.pm"); /* make sure PDL::Core is loaded */ #ifndef aTHX_ #define aTHX_ #endif if (SvTRUE (ERRSV)) Perl_croak(aTHX_ "%s",SvPV_nolen (ERRSV)); CoreSV = perl_get_sv("PDL::SHARE",FALSE); /* SV* value */ if (CoreSV==NULL) Perl_croak(aTHX_ "We require the PDL::Core module, which was not found"); $symname = INT2PTR(Core*,SvIV( CoreSV )); /* Core* value */ if ($symname->Version != PDL_CORE_VERSION) Perl_croak(aTHX_ "[$symname->Version: \%d PDL_CORE_VERSION: \%d XS_VERSION: \%s] $module needs to be recompiled against the newly installed PDL", $symname->Version, PDL_CORE_VERSION, XS_VERSION); EOR } # whereami_any returns appended 'Basic' or 'PDL' dir as appropriate use Cwd qw/abs_path/; sub whereami_any { my $dir = (&whereami(1) or &whereami_inst(1) or die "Unable to determine ANY directory path to PDL::Core::Dev module\n"); return abs_path($dir); } sub whereami { for $dir (@INC,qw|. .. ../.. ../../.. ../../../..|) { return ($_[0] ? $dir . '/Basic' : $dir) if -e "$dir/Basic/Core/Dev.pm"; } die "Unable to determine UNINSTALLED directory path to PDL::Core::Dev module\n" if !$_[0]; return undef; } sub whereami_inst { for $dir (@INC,map {$_."/blib"} qw|. .. ../.. ../../.. ../../../..|) { return ($_[0] ? $dir . '/PDL' : $dir) if -e "$dir/PDL/Core/Dev.pm"; } die "Unable to determine INSTALLED directory path to PDL::Core::Dev module\n" if !$_[0]; return undef; } # # To access PDL's configuration use %PDL::Config. Makefile.PL has been set up # to create this variable so it is available during 'perl Makefile.PL' and # it can be eval-ed during 'make' unless ( %PDL::Config ) { # look for the distribution and then the installed version # (a manual version of whereami_any) # my $dir; $dir = whereami(1); if ( defined $dir ) { $dir = abs_path($dir . "/Core"); } else { # as no argument given whereami_inst will die if it fails # (and it also returns a slightly different path than whereami(1) # does, since it does not include "/PDL") # $dir = whereami_inst; $dir = abs_path($dir . "/PDL"); } my $dir2 = $dir; $dir2 =~ s/\}/\\\}/g; eval sprintf('require q{%s/Config.pm};', $dir2); die "Unable to find PDL's configuration info\n [$@]" if $@; } # Data types to C types mapping # get the map from Types.pm { # load PDL::Types only if it has not been previously loaded my $loaded_types = grep (m%(PDL|Core)/Types[.]pm$%, keys %INC); $@ = ''; # reset eval('require "'.whereami_any().'/Core/Types.pm"') # lets dist Types.pm win unless $loaded_types; # only when PDL::Types not yet loaded if($@) { # if PDL::Types doesn't work try with full path (during build) my $foo = $@; $@=""; eval('require PDL::Types'); if($@) { die "can't find PDL::Types: $foo and $@" unless $@ eq ""; } } } PDL::Types->import(); my $inc = defined $PDL::Config{MALLOCDBG}->{include} ? "$PDL::Config{MALLOCDBG}->{include}" : ''; my $libs = defined $PDL::Config{MALLOCDBG}->{libs} ? "$PDL::Config{MALLOCDBG}->{libs}" : ''; %PDL_DATATYPES = (); foreach $key (keys %PDL::Types::typehash) { $PDL_DATATYPES{$PDL::Types::typehash{$key}->{'sym'}} = $PDL::Types::typehash{$key}->{'ctype'}; } # non-blocking IO configuration $O_NONBLOCK = defined $Config{'o_nonblock'} ? $Config{'o_nonblock'} : 'O_NONBLOCK'; =head2 isbigendian =for ref Is the machine big or little endian? =for example print "Your machins is big endian.\n" if isbigendian(); returns 1 if the machine is big endian, 0 if little endian, or dies if neither. It uses the C element of perl's C<%Config> array. =for usage my $retval = isbigendian(); =cut # ' emacs parsing dummy # big/little endian? sub isbigendian { use Config; my $byteorder = $Config{byteorder} || die "ERROR: Unable to find 'byteorder' in perl's Config\n"; return 1 if $byteorder eq "4321"; return 1 if $byteorder eq "87654321"; return 0 if $byteorder eq "1234"; return 0 if $byteorder eq "12345678"; die "ERROR: PDL does not understand your machine's byteorder ($byteorder)\n"; } #################### PDL Generic PreProcessor #################### # # Preprocesses *.g files to *.c files allowing 'generic' # type code which is converted to code for each type. # # e.g. the code: # # pdl x; # GENERICLOOP(x.datatype) # generic *xx = x.data; # for(i=0; i) { # Process files in @ARGV list - result to STDOUT # Do the miscellaneous substitutions first s/O_NONBLOCK/$O_NONBLOCK/go; # I/O if ( m/ (\s*)? \b GENERICLOOP \s* \( ( [^\)]* ) \) ( \s*; )? /x ){ # Start of generic code #print $MATCH, "=$1=\n"; die "Found GENERICLOOP while searching for ENDGENERICLOOP\n" if $gotstart; $loopvar = $2; $indent = $1; print $PREMATCH; @gencode = (); # Start saving code push @gencode, $POSTMATCH; $gotstart = 1; next; } if ( m/ \b ENDGENERICLOOP ( \s*; )? /x ) { die "Found ENDGENERICLOOP while searching for GENERICLOOP\n" unless $gotstart; push @gencode, $PREMATCH; flushgeneric(); # Output the generic code print $POSTMATCH; # End of genric code $gotstart = 0; next; } if ($gotstart) { push @gencode, $_; } else { print; } } # End while } sub flushgeneric { # Construct the generic code switch print $indent,"switch ($loopvar) {\n\n"; for $case (PDL::Types::typesrtkeys()){ $type = $PDL_DATATYPES{$case}; my $ppsym = $PDL::Types::typehash{$case}->{ppsym}; print $indent,"case $case:\n"; # Start of this case print $indent," {"; # Now output actual code with substutions for (@gencode) { $line = $_; $line =~ s/\bgeneric\b/$type/g; $line =~ s/\bgeneric_ppsym\b/$ppsym/g; print " ",$line; } print "}break;\n\n"; # End of this case } print $indent,"default:\n"; print $indent,' croak ("Not a known data type code=%d",'.$loopvar.");\n"; print $indent,"}"; } sub genpp_cmdline { my ($in, $out) = @_; require ExtUtils::MM; my $MM = bless { NAME => 'Fake' }, 'MM'; my $devpm = whereami_any()."/Core/Dev.pm"; sprintf($MM->oneliner(<<'EOF'), $devpm) . qq{ "$in" > "$out"}; require "%s"; PDL::Core::Dev->import(); genpp(); EOF } # Standard PDL postamble # # This is called via .../Gen/Inline/Pdlpp.pm, in the case that the INTERNAL # flag for the compilation is off (grep "ILSM" in that file to find the reference). # If it's ON, then postamble_int gets called instead. sub postamble { my ($self) = @_; sprintf <<'EOF', genpp_cmdline(qw($< $@)); # Rules for the generic preprocessor .SUFFIXES: .g .g.c : %s EOF } # Expects list in format: # [gtest.pd, GTest, PDL::GTest, ['../GIS/Proj', ...] ], [...] # source, prefix,module/package, optional deps # The idea is to support in future several packages in same dir - EUMM # 7.06 supports # each optional dep is a relative dir that a "make" will chdir to and # "make" first - so the *.pd file can then "use" what it makes # This is the function internal for PDL. sub pdlpp_postamble_int { join '',map { my($src,$pref,$mod, $deps) = @$_; die "If give dependencies, must be array-ref" if $deps and !ref $deps; my $w = whereami_any(); $w =~ s%/((PDL)|(Basic))$%%; # remove the trailing subdir my $top = File::Spec->abs2rel($w); my $basic = File::Spec->catdir($top, 'Basic'); my $core = File::Spec->catdir($basic, 'Core'); my $gen = File::Spec->catdir($basic, 'Gen'); my $depbuild = ''; for my $dep (@{$deps || []}) { my $target = ''; if ($dep eq 'core') { $dep = $top; $target = ' core'; } require ExtUtils::MM; $dep =~ s#([\(\)])#\\$1#g; # in case of unbalanced ( $depbuild .= MM->oneliner("exit(!(chdir q($dep) && !system(q(\$(MAKE)$target))))"); $depbuild .= "\n\t"; } qq| $pref.pm: $src $core/Types.pm $depbuild\$(PERLRUNINST) \"-MPDL::PP qw[$mod $mod $pref]\" $src $pref.xs: $pref.pm \$(TOUCH) \$@ $pref.c: $pref.xs $pref\$(OBJ_EXT): $pref.c | } (@_) } # This is the function to be used outside the PDL tree. sub pdlpp_postamble { join '',map { my($src,$pref,$mod) = @$_; my $w = whereami_any(); $w =~ s%/((PDL)|(Basic))$%%; # remove the trailing subdir qq| $pref.pm: $src \$(PERL) "-I$w" \"-MPDL::PP qw[$mod $mod $pref]\" $src $pref.xs: $pref.pm \$(TOUCH) \$@ $pref.c: $pref.xs $pref\$(OBJ_EXT): $pref.c install :: \@echo "Updating PDL documentation database..."; \$(ABSPERLRUN) -e 'exit if \$\$ENV{DESTDIR}; use PDL::Doc; eval { PDL::Doc::add_module(q{$mod}); }; '; | } (@_) } sub pdlpp_stdargs_int { my($rec) = @_; my($src,$pref,$mod) = @$rec; my $w = whereami(); my $malloclib = exists $PDL::Config{MALLOCDBG}->{libs} ? $PDL::Config{MALLOCDBG}->{libs} : ''; my $mallocinc = exists $PDL::Config{MALLOCDBG}->{include} ? $PDL::Config{MALLOCDBG}->{include} : ''; my $libsarg = $libs || $malloclib ? "$libs $malloclib " : ''; # for Win32 return ( %::PDL_OPTIONS, 'NAME' => $mod, 'VERSION_FROM' => "$w/Basic/Core/Version.pm", 'TYPEMAPS' => [&PDL_TYPEMAP()], 'OBJECT' => "$pref\$(OBJ_EXT)", PM => {"$pref.pm" => "\$(INST_LIBDIR)/$pref.pm"}, MAN3PODS => {"$pref.pm" => "\$(INST_MAN3DIR)/$mod.\$(MAN3EXT)"}, 'INC' => &PDL_INCLUDE()." $inc $mallocinc", 'LIBS' => $libsarg ? [$libsarg] : [], 'clean' => {'FILES' => "$pref.xs $pref.pm $pref\$(OBJ_EXT) $pref.c"}, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); } sub pdlpp_stdargs { my($rec) = @_; my($src,$pref,$mod) = @$rec; return ( %::PDL_OPTIONS, 'NAME' => $mod, 'TYPEMAPS' => [&PDL_INST_TYPEMAP()], 'OBJECT' => "$pref\$(OBJ_EXT)", PM => {"$pref.pm" => "\$(INST_LIBDIR)/$pref.pm"}, MAN3PODS => {"$pref.pm" => "\$(INST_MAN3DIR)/$mod.\$(MAN3EXT)"}, 'INC' => &PDL_INST_INCLUDE()." $inc", 'LIBS' => $libs ? ["$libs "] : [], 'clean' => {'FILES' => "$pref.xs $pref.pm $pref\$(OBJ_EXT) $pref.c"}, 'dist' => {'PREOP' => '$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" -MPDL::Core::Dev -e pdlpp_mkgen $(DISTVNAME)' }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); } # pdlpp_mkgen($dir) # - scans $dir/MANIFEST for all *.pd files and creates corresponding *.pm files # in $dir/GENERATED/ subdir; needed for proper doc rendering at metacpan.org # - it is used in Makefile.PL like: # dist => { PREOP=>'$(PERL) -MPDL::Core::Dev -e pdlpp_mkgen $(DISTVNAME)' } # so all the magic *.pm generation happens during "make dist" # - it is intended to be called as a one-liner: # perl -MPDL::Core::Dev -e pdlpp_mkgen DirName # sub pdlpp_mkgen { my $dir = @_ > 0 ? $_[0] : $ARGV[0]; die "pdlpp_mkgen: unspecified directory" unless defined $dir && -d $dir; my $file = "$dir/MANIFEST"; die "pdlpp_mkgen: non-existing '$dir/MANIFEST'" unless -f $file; my @pairs = (); my $manifest = ExtUtils::Manifest::maniread($file); for (keys %$manifest) { next if $_ !~ m/\.pd$/; # skip non-pd files next if $_ =~ m/^(t|xt)\//; # skip *.pd files in test subdirs next unless -f $_; my $content = do { local $/; open my $in, '<', $_; <$in> }; if ($content =~ /=head1\s+NAME\s+(\S+)\s+/sg) { push @pairs, [$_, $1]; } else { warn "pdlpp_mkgen: unknown module name for '$_' (use proper '=head1 NAME' section)\n"; } } my %added = (); for (@pairs) { my ($pd, $mod) = @$_; (my $prefix = $mod) =~ s|::|/|g; my $manifestpm = "GENERATED/$prefix.pm"; $prefix = "$dir/GENERATED/$prefix"; File::Path::mkpath(dirname($prefix)); #there is no way to use PDL::PP from perl code, thus calling via system() my @in = map { "-I$_" } @INC, 'inc'; my $rv = system($^X, @in, "-MPDL::PP qw[$mod $mod $prefix]", $pd); if ($rv == 0 && -f "$prefix.pm") { $added{$manifestpm} = "mod=$mod pd=$pd (added by pdlpp_mkgen)"; unlink "$prefix.xs"; #we need only .pm } else { warn "pdlpp_mkgen: cannot convert '$pd'\n"; } } if (scalar(keys %added) > 0) { #maniadd works only with this global variable local $ExtUtils::Manifest::MANIFEST = $file; ExtUtils::Manifest::maniadd(\%added); } } sub unsupported { my ($package,$os) = @_; "No support for $package on $os platform yet. Will skip build process"; } sub write_dummy_make { my ($msg) = @_; $msg =~ s#\n*\z#\n#; $msg =~ s#^\s*#\n#gm; print $msg; require ExtUtils::MakeMaker; ExtUtils::MakeMaker::WriteEmptyMakefile(NAME => 'Dummy', DIR => []); } sub getcyglib { my ($lib) = @_; my $lp = `gcc -print-file-name=lib$lib.a`; $lp =~ s|/[^/]+$||; $lp =~ s|^([a-z,A-Z]):|//$1|g; return "-L$lp -l$lib"; } =head2 trylink =for ref a perl configure clone =for example if (trylink 'libGL', '', 'char glBegin(); glBegin();', '-lGL') { $libs = '-lGLU -lGL'; $have_GL = 1; } else { $have_GL = 0; } $maybe = trylink 'libwhatever', $inc, $body, $libs, $cflags, {MakeMaker=>1, Hide=>0, Clean=>1}; Try to link some C-code making up the body of a function with a given set of library specifiers return 1 if successful, 0 otherwise =for usage trylink $infomsg, $include, $progbody, $libs [,$cflags,{OPTIONS}]; Takes 4 + 2 optional arguments. =over 5 =item * an informational message to print (can be empty) =item * any commands to be included at the top of the generated C program (typically something like C<#include "mylib.h">) =item * the body of the program (in function main) =item * library flags to use for linking. Preprocessing by MakeMaker should be performed as needed (see options and example). =item * compilation flags. For example, something like C<-I/usr/local/lib>. Optional argument. Empty if omitted. =item * OPTIONS =over =item MakeMaker Preprocess library strings in the way MakeMaker does things. This is advisable to ensure that your code will actually work after the link specs have been processed by MakeMaker. =item Hide Controls if linking output etc is hidden from the user or not. On by default except within the build of the PDL distribution where the config value set in F prevails. =item Clean Remove temporary files. Enabled by default. You might want to switch it off during debugging. =back =back =cut sub trylink { my $opt = ref $_[$#_] eq 'HASH' ? pop : {}; my ($txt,$inc,$body,$libs,$cflags) = @_; $cflags ||= ''; require File::Spec; require File::Temp; my $cdir = sub { return File::Spec->catdir(@_)}; my $cfile = sub { return File::Spec->catfile(@_)}; use Config; # check if MakeMaker should be used to preprocess the libs for my $key(keys %$opt) {$opt->{lc $key} = $opt->{$key}} my $mmprocess = exists $opt->{makemaker} && $opt->{makemaker}; my $hide = exists $opt->{hide} ? $opt->{hide} : exists $PDL::Config{HIDE_TRYLINK} ? $PDL::Config{HIDE_TRYLINK} : 1; my $clean = exists $opt->{clean} ? $opt->{clean} : 1; if ($mmprocess) { require ExtUtils::MakeMaker; require ExtUtils::Liblist; my $self = new ExtUtils::MakeMaker {DIR => [],'NAME' => 'NONE'}; my @libs = $self->ext($libs, 0); print "processed LIBS: $libs[0]\n" unless $hide; $libs = $libs[0]; # replace by preprocessed libs } print " Trying $txt...\n " unless $txt =~ /^\s*$/; my $HIDE = !$hide ? '' : '>/dev/null 2>&1'; if($^O =~ /mswin32/i) {$HIDE = '>NUL 2>&1'} my $tempd; $tempd = File::Temp::tempdir(CLEANUP=>1) || die "trylink: could not make TEMPDIR"; ### if($^O =~ /MSWin32/i) {$tempd = File::Spec->tmpdir()} ### else { ### $tempd = $PDL::Config{TEMPDIR} || ### } my ($tc,$te) = map {&$cfile($tempd,"testfile$_")} ('.c',''); open FILE,">$tc" or die "trylink: couldn't open testfile `$tc' for writing, $!"; my $prog = <<"EOF"; $inc int main(void) { $body return 0; } EOF print FILE $prog; close FILE; # print "test prog:\n$prog\n"; # make sure we can overwrite the executable. shouldn't need this, # but if it fails and HIDE is on, the user will never see the error. open(T, ">$te") or die( "unable to write to test executable `$te'"); close T; print "$Config{cc} $cflags -o $te $tc $libs $HIDE ...\n" unless $hide; my $success = (system("$Config{cc} $cflags -o $te $tc $libs $HIDE") == 0) && -e $te ? 1 : 0; unlink "$te","$tc" if $clean; print $success ? "\t\tYES\n" : "\t\tNO\n" unless $txt =~ /^\s*$/; print $success ? "\t\tSUCCESS\n" : "\t\tFAILED\n" if $txt =~ /^\s*$/ && !$hide; return $success; } =head2 datatypes_switch =for ref prints on C XS text for F. =cut sub datatypes_switch { my $ntypes = $#PDL::Types::names; my @m; foreach my $i ( 0 .. $ntypes ) { my $type = PDL::Type->new( $i ); my $typesym = $type->symbol; my $typeppsym = $type->ppsym; my $cname = $type->ctype; $cname =~ s/^PDL_//; push @m, "\tcase $typesym: retval.type = $typesym; retval.value.$typeppsym = PDL.bvals.$cname; break;"; } print map "$_\n", @m; } =head2 generate_core_flags =for ref prints on C XS text with core flags, for F. =cut my %flags = ( hdrcpy => { set => 1 }, fflows => { FLAG => "DATAFLOW_F" }, bflows => { FLAG => "DATAFLOW_B" }, is_inplace => { FLAG => "INPLACE", postset => 1 }, donttouch => { FLAG => "DONTTOUCHDATA" }, allocated => { }, vaffine => { FLAG => "OPT_VAFFTRANSOK" }, anychgd => { FLAG => "ANYCHANGED" }, dimschgd => { FLAG => "PARENTDIMSCHANGED" }, tracedebug => { FLAG => "TRACEDEBUG", set => 1}, ); #if ( $bvalflag ) { $flags{baddata} = { set => 1, FLAG => "BADVAL" }; } sub generate_core_flags { # access (read, if set is true then write as well; if postset true then # read first and write new value after that) # to piddle's state foreach my $name ( sort keys %flags ) { my $flag = "PDL_" . ($flags{$name}{FLAG} || uc($name)); if ( $flags{$name}{set} ) { print <<"!WITH!SUBS!"; int $name(x,mode=0) pdl *x int mode CODE: if (items>1) { setflag(x->state,$flag,mode); } RETVAL = ((x->state & $flag) > 0); OUTPUT: RETVAL !WITH!SUBS! } elsif ($flags{$name}{postset}) { print <<"!WITH!SUBS!"; int $name(x,mode=0) pdl *x int mode CODE: RETVAL = ((x->state & $flag) > 0); if (items>1) { setflag(x->state,$flag,mode); } OUTPUT: RETVAL !WITH!SUBS! } else { print <<"!WITH!SUBS!"; int $name(self) pdl *self CODE: RETVAL = ((self->state & $flag) > 0); OUTPUT: RETVAL !WITH!SUBS! } } # foreach: keys %flags } =head2 generate_badval_init =for ref prints on C XS text with badval initialisation, for F. =cut sub generate_badval_init { for my $type (PDL::Types::types()) { my $typename = $type->ctype; $typename =~ s/^PDL_//; my $bval = $type->defbval; if ($PDL::Config{BADVAL_USENAN} && $type->usenan) { # note: no defaults if usenan print "\tPDL.bvals.$typename = PDL.NaN_$type;\n"; #Core NaN value } else { print "\tPDL.bvals.$typename = PDL.bvals.default_$typename = $bval;\n"; } } # PDL.bvals.Byte = PDL.bvals.default_Byte = UCHAR_MAX; # PDL.bvals.Short = PDL.bvals.default_Short = SHRT_MIN; # PDL.bvals.Ushort = PDL.bvals.default_Ushort = USHRT_MAX; # PDL.bvals.Long = PDL.bvals.default_Long = INT_MIN; } 1; PDL-2.018/Basic/Core/Exporter.pm0000644060175006010010000000404512562522363014464 0ustar chmNone=head1 NAME PDL::Exporter - PDL export control =head1 DESCRIPTION Implements the standard conventions for import of PDL modules in to the namespace Hopefully will be extended to allow fine control of which namespace is used. =head1 SYNOPSIS use PDL::Exporter; use PDL::MyModule; # Import default function list ':Func' use PDL::MyModule ''; # Import nothing (OO) use PDL::MyModule '...'; # Same behaviour as Exporter =head1 SUMMARY C is a drop-in replacement for the L module. It confers the standard PDL export conventions to your module. Usage is fairly straightforward and best illustrated by an example. The following shows typical usage near the top of a simple PDL module: package PDL::MyMod; use strict; # For Perl 5.6: use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); # For more modern Perls: our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); require PDL::Exporter; @ISA = qw(PDL::Exporter); @EXPORT_OK = qw(inc myfunc); # these will be exported by default %EXPORT_TAGS = (Func=>[@EXPORT_OK], Internal => [qw/internfunc1 internfunc2/], ); # ... body of your module 1; # end of simple module =cut package PDL::Exporter; use Exporter; sub import { my $pkg = shift; return if $pkg eq 'PDL::Exporter'; # Module don't export thyself :) my $callpkg = caller($Exporter::ExportLevel); print "DBG: pkg=$pkg callpkg = $callpkg :@_\n" if($PDL::Exporter::Verbose); push @_, ':Func' unless @_; @_=() if scalar(@_)==1 and $_[0] eq ''; Exporter::export($pkg, $callpkg, @_); } 1; =head1 SEE ALSO L =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au). Some docs by Christian Soeller. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut PDL-2.018/Basic/Core/IFiles.pm0000644060175006010010000000302013036512174014013 0ustar chmNone=head1 NAME PDL::Install::Files -- Module for use by L and L =head1 SYNOPSIS use Inline with => 'PDL'; # or alternatively, if your XS module uses PDL: use ExtUtils::Depends; my $pkg = ExtUtils::Depends->new(qw(MyPackage PDL)); =head1 DESCRIPTION This module is for use by L and L. There are no user-serviceable parts inside. =cut package PDL::Install::Files; # support ExtUtils::Depends require PDL::Core::Dev; our $VERSION = '2.009'; $self = { 'typemaps' => [ &PDL::Core::Dev::PDL_TYPEMAP ], 'inc' => &PDL::Core::Dev::PDL_INCLUDE, 'libs' => '', 'deps' => [], }; @deps = @{ $self->{deps} }; @typemaps = @{ $self->{typemaps} }; $libs = $self->{libs}; $inc = $self->{inc}; $CORE = undef; foreach (@INC) { if ( -f "$_/PDL/Install/Files.pm") { $CORE = $_ . "/PDL/Install/"; last; } } sub deps { } # support: use Inline with => 'PDL'; require Inline; sub Inline { my ($class, $lang) = @_; return {} if $lang eq 'Pdlpp'; return unless $lang eq 'C'; unless($ENV{"PDL_Early_Inline"} // ($Inline::VERSION >= 0.68) ) { die "PDL::Inline: requires Inline version 0.68 or higher to make sense\n (yours is $Inline::VERSION). You should upgrade Inline, \n or else set \$ENV{PDL_Early_Inline} to a true value to ignore this message.\n"; } +{ TYPEMAPS => [ &PDL::Core::Dev::PDL_TYPEMAP ], INC => &PDL::Core::Dev::PDL_INCLUDE, AUTO_INCLUDE => &PDL::Core::Dev::PDL_AUTO_INCLUDE, BOOT => &PDL::Core::Dev::PDL_BOOT, }; } 1; PDL-2.018/Basic/Core/Makefile.PL0000644060175006010010000002033313036512174014262 0ustar chmNoneuse strict; use warnings; use Devel::CheckLib; use Config; use ExtUtils::MakeMaker; ## $DB::single = 1; # uncomment to have debugger stop here my $pthread_include = $Config::Config{usrinc}; # not good for win32 my $pthread_library = '-lpthread'; # not good for MSVC my $pthread_define = ' -DPDL_PTHREAD '; my $badval_define = " -DBADVAL=$PDL::Config{WITH_BADVAL} -DBADVAL_USENAN=$PDL::Config{BADVAL_USENAN} -DBADVAL_PER_PDL=$PDL::Config{BADVAL_PER_PDL}"; my $malloclib = $PDL::Config{MALLOCDBG}->{libs}; my $mallocinc = $PDL::Config{MALLOCDBG}->{include}; print "Trying to figure out POSIX threads support ...\n"; # TODO: replace directory and file checks for pthread.h by Devel::CheckLib test if ( exists $PDL::Config{POSIX_THREADS_INC} and defined $PDL::Config{POSIX_THREADS_INC} ) { $pthread_include = $PDL::Config{POSIX_THREADS_INC}; print "\t..setting \$pthread_include to $pthread_include\n"; } elsif (-d $pthread_include) { print "\tSaw pthread.h. Fine.\n"; $pthread_include = "-I$pthread_include" } else { print "\tEhh. Didn't see include file 'pthread.h'.\n"; $pthread_include = ''; } # TODO: need to clean up per-platform logic herer if ( exists $PDL::Config{POSIX_THREADS_LIBS} and defined $PDL::Config{POSIX_THREADS_LIBS} ) { $pthread_library = $PDL::Config{POSIX_THREADS_LIBS}; print "\tUsing POSIX_THREADS_LIBS from perldl.conf\n"; } elsif ($Config::Config{libs} =~ /-lpthread/) { # wrong print "\tFine, your perl was linked against pthread library.\n"; } elsif ($^O eq 'dec_osf') { if ($Config::Config{usemymalloc} eq 'n') { print "\tFine pthread, works with Digital Unixs malloc\n"; } else { # print "\tPerls malloc has problems when perl is not linked with -lpthread\n"; $pthread_library = ''; } } elsif ($^O eq 'freebsd'){ if ($Config::Config{libs} =~ /-lc_r/) { print "\tGood, found -lc_r on a freebsd system.\n"; } else { print "On FreeBSD try building perl with libc_r instead of libc\n"; $pthread_library = ''; } } elsif ($^O =~ /bsd$/i){ if ($Config::Config{ldflags} =~ /-pthread/) { if ($Config::Config{usemymalloc} eq 'y') { print "\tGood, usemymalloc=y, will build with pthread support\n"; } else { print "\tGot usemymalloc=$Config::Config{usemymalloc} so not building with pthreads\n"; $pthread_library = ''; } } else { print "\tMissing '-pthread' from ldflags=$Config::Config{lddlflags} so not building with pthreads\n"; $pthread_library = ''; } } else { print "\tNope, your perl was not linked against pthread library\n"; if ($^O =~ /mswin/i or $^O =~ /cygwin/i) { if (check_lib(LIB=>'-lpthread',header=>'pthread.h')) { print "\tWe found -lpthread and pthread.h so will build anyway\n"; $pthread_library = '-lpthread'; } else { $pthread_library = ''; } } else { print "\tWe'll try the default -lpthread anyway\n"; # $pthread_library = ''; } } $pthread_include = $pthread_library = '' unless $pthread_include and $pthread_library; { # TODO: use a Devel::CheckLib build/run test to verify working build params my $conf = $PDL::Config{WITH_POSIX_THREADS}; if ((!defined($conf) or $conf) and $pthread_include and $pthread_library) { print "\t==> Will build PDL with POSIX thread support. Gifts to TJL :-)\n"; $PDL::Config{WITH_POSIX_THREADS} = 1; } elsif($conf) { print "\t==> I couldn't find pthread support. However, you have\n"; print "\t turned on the forcing option in PDL_CONFIG so I guess I gotta do it\n"; } else { print "\t==> PDL will be built without POSIX thread support.\n"; print "\t==> *NOTE*: PDL threads are unrelated to perl threads (usethreads=y)!\n"; print "\t==> Enabling perl threads will not help!\n"; $pthread_define = ''; $PDL::Config{WITH_POSIX_THREADS} = 0; } } # isbigendian() is in PDL::Dev print "Trying to figure out endian-ness of machine..."; print " It is " . (PDL::Core::Dev::isbigendian() ? "big" : "little") . " endian\n"; sub nopl { my $txt = shift; $txt =~ s/[.]PL$//; return $txt} # Extra targets to build sub make_from_PL ($) { my $head = shift; return "\t" . '$(PERLRUNINST) ' . "${head}.PL $head\n"; } sub MY::xs_o { if($Config{make} =~ /\bnmake/i) { return' .xs$(OBJ_EXT): $(PERLRUN) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(DEFINE) $*.c ' } else { package MY; my $self = shift; return $self->SUPER::xs_o; } } undef &MY::processPL; *MY::processPL = sub { package MY; my ($self) = @_; return $self->SUPER::processPL unless $^O =~ /MSWin32/i && $Config::Config{make} =~ /\b[dn]make/i; return '' if $Config::Config{make} =~ /\bnmake/i; return "" unless $self->{PL_FILES}; my @m; my $alltarget = $ExtUtils::MakeMaker::VERSION >= 7.05_06 ? 'pure_nolink' : 'all'; my $colon = $Config::Config{make} =~ /\bdmake/i ? ':' : '::'; foreach my $plfile (sort keys %{$self->{PL_FILES}}) { my $list = ref($self->{PL_FILES}->{$plfile}) ? $self->{PL_FILES}->{$plfile} : [$self->{PL_FILES}->{$plfile}]; foreach my $target (@$list) { push @m, "\n$alltarget :: $target\n\t\$(NOECHO) \$(NOOP)\n", "\n$target $colon\n\t\$(PERLRUNINST) $plfile $target\n"; } } join "", @m; }; undef &MY::postamble; # suppress warning *MY::postamble = sub { # nmake doesn't seem to do inference rules right so spell it out my $pdlsections_g = sprintf <<'EOF', PDL::Core::Dev::genpp_cmdline(qw(pdlsections.g pdlsections.c)); pdlsections.c :: pdlsections.g Types.pm %s EOF my $text = PDL::Core::Dev::postamble() . " pdlbadvalinit.c:: pdlbadvalinit.c.PL Types.pm\n" . make_from_PL( 'pdlbadvalinit.c' ) ." pdldataswitch.c:: pdldataswitch.c.PL Types.pm\n" . make_from_PL( 'pdldataswitch.c' ) ." pdl.h:: pdl.h.PL Types.pm\n" . make_from_PL( 'pdl.h' ) . " pdlsimple.h:: pdlsimple.h.PL Types.pm\n" . make_from_PL( 'pdlsimple.h' ) . " pdlcore.h:: pdlcore.h.PL Types.pm\n" . make_from_PL( 'pdlcore.h' ); if($Config{make} =~ /\bdmake/i) { if($ExtUtils::MakeMaker::VERSION < 7) { return $text . $pdlsections_g; } else { #EU-MM >= 7 return $text; } } else { return $text. " # Bits of C code we generate from special perl scripts # # there must be a more elegant way of saying that # certain files have additional dependencies! pdlthread.c :: pdl.h pdlcore.h\n" ." pdlhash.c :: pdl.h pdlcore.h\n" ." pdlapi.c :: pdl.h pdlcore.h\n" ." pdlmagic.c :: pdlcore.h\n" ." pdlsections.c :: pdl.h pdlcore.h\n" ." pdlconv.c:: pdlconv.c.PL Types.pm\n" . make_from_PL( 'pdlconv.c' ) ." pdlcore.c:: pdlcore.c.PL Types.pm\n" . make_from_PL( 'pdlcore.c' ) . ($^O =~ /MSWin/ ? $pdlsections_g : ''); } }; my @cfiles = qw(pdlcore pdlapi pdlhash pdlthread pdlconv pdlmagic pdlsections); my $cobj = join ' ', map qq{$_\$(OBJ_EXT)}, @cfiles; WriteMakefile( 'NAME' => 'PDL::Core', 'VERSION_FROM' => 'Version.pm', 'PM' => { (map {($_,'$(INST_LIBDIR)/'.$_)} ( qw/Core.pm Basic.pm Version.pm Types.pm Dbg.pm Exporter.pm Config.pm Char.pm/ )), (map {($_,'$(INST_LIBDIR)/Core/'.$_)} ( qw/Dev.pm typemap.pdl pdl.h pdlcore.h pdlmagic.h pdlsimple.h pdlthread.h ppport.h/ )), qq/IFiles.pm/,'$(INST_LIBDIR)/Install/Files.pm', }, 'PL_FILES' => {map {($_ => nopl $_)} grep {!/^Makefile.PL$/} <*.PL>}, 'OBJECT' => 'Core$(OBJ_EXT) ' . $cobj, 'DEFINE' => $pthread_define.$badval_define, 'LIBS' => ["$pthread_library $malloclib"], 'clean' => {'FILES' => $cobj . ' pdlconv.c pdlsections.c pdlcore.c '. 'pdl.h pdlsimple.h pdlcore.h '. 'pdldataswitch.c pdlbadvalinit.c '. 'Types.pm Version.pm Core.c ' }, 'INC' => join(' ', PDL_INCLUDE(), map {length($_) ? qq{"$_"} : ()} $pthread_include, $mallocinc ), depend => { 'Core$(OBJ_EXT)' => '$(INST_ARCHLIB)$(DFSEP).exists pm_to_blib pdldataswitch.c pdlbadvalinit.c pdl.h pdlcore.h', # Core.xs needs blib/arch for -Mblib to work, as well as pm_to_blib }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Basic/Core/pdl.h.PL0000644060175006010010000004402213101130663013543 0ustar chmNone# -*-perl-*- use strict; use warnings; use Config; use File::Basename qw(&basename &dirname); # how many variable types (ie PDL_Byte, ...) are there? require './Types.pm'; my $ntypes = $#PDL::Types::names; my $PDL_DATATYPES = PDL::Types::datatypes_header(); require './Config.pm'; die "No PDL::Config found" unless %PDL::Config; my $mymalloc = $PDL::Config{MALLOCDBG}->{define} // ''; my $file = shift @ARGV; print "Extracting $file\n"; open OUT,">$file" or die "Can't create $file: $!"; chmod 0644, $file; # In this section, perl variables will be expanded during extraction. # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; /* * THIS FILE IS GENERATED FROM pdl.h.PL! Do NOT edit! */ #ifndef __PDL_H #define __PDL_H #define PDL_DEBUGGING 1 #ifdef PDL_DEBUGGING extern int pdl_debugging; #define PDLDEBUG_f(a) if(pdl_debugging) a #else #define PDLDEBUG_f(a) #endif #define ANYVAL_TO_SV(outsv,inany) do { switch (inany.type) { \\ case PDL_B: outsv = newSViv( (IV)(inany.value.B) ); break; \\ case PDL_S: outsv = newSViv( (IV)(inany.value.S) ); break; \\ case PDL_US: outsv = newSViv( (IV)(inany.value.U) ); break; \\ case PDL_L: outsv = newSViv( (IV)(inany.value.L) ); break; \\ case PDL_IND: outsv = newSViv( (IV)(inany.value.N) ); break; \\ case PDL_LL: outsv = newSViv( (IV)(inany.value.Q) ); break; \\ case PDL_F: outsv = newSVnv( (NV)(inany.value.F) ); break; \\ case PDL_D: outsv = newSVnv( (NV)(inany.value.D) ); break; \\ default: outsv = &PL_sv_undef; \\ } \\ } while (0) #define ANYVAL_FROM_CTYPE(outany,avtype,inval) do { switch (avtype) { \\ case PDL_B: outany.type = avtype; outany.value.B = (PDL_Byte)(inval); break; \\ case PDL_S: outany.type = avtype; outany.value.S = (PDL_Short)(inval); break; \\ case PDL_US: outany.type = avtype; outany.value.U = (PDL_Ushort)(inval); break; \\ case PDL_L: outany.type = avtype; outany.value.L = (PDL_Long)(inval); break; \\ case PDL_IND: outany.type = avtype; outany.value.N = (PDL_Indx)(inval); break; \\ case PDL_LL: outany.type = avtype; outany.value.Q = (PDL_LongLong)(inval); break; \\ case PDL_F: outany.type = avtype; outany.value.F = (PDL_Float)(inval); break; \\ case PDL_D: outany.type = avtype; outany.value.D = (PDL_Double)(inval); break; \\ default: outany.type = -1; outany.value.B = 0; \\ } \\ } while (0) #define ANYVAL_TO_CTYPE(outval,ctype,inany) do { switch (inany.type) { \\ case PDL_B: outval = (ctype)(inany.value.B); break; \\ case PDL_S: outval = (ctype)(inany.value.S); break; \\ case PDL_US: outval = (ctype)(inany.value.U); break; \\ case PDL_L: outval = (ctype)(inany.value.L); break; \\ case PDL_IND: outval = (ctype)(inany.value.N); break; \\ case PDL_LL: outval = (ctype)(inany.value.Q); break; \\ case PDL_F: outval = (ctype)(inany.value.F); break; \\ case PDL_D: outval = (ctype)(inany.value.D); break; \\ default: outval = 0; \\ } \\ } while (0) /* Auto-PThreading (i.e. multi-threading) settings for PDL functions */ /* Target number of pthreads: Actual will be this number or less. A 0 here means no pthreading */ extern int pdl_autopthread_targ; /* Actual number of pthreads: This is the number of pthreads created for the last operation where pthreading was used A 0 here means no pthreading */ extern int pdl_autopthread_actual; /* Minimum size of the target PDL involved in pdl function to attempt pthreading (in MBytes ) For small PDLs, it probably isn't worth starting multiple pthreads, so this variable is used to define that threshold (in M-elements, or 2^20 elements ) */ extern int pdl_autopthread_size; typedef struct pdl pdl; $PDL_DATATYPES extern int _anyval_eq_anyval(PDL_Anyval, PDL_Anyval); #define ANYVAL_EQ_ANYVAL(x,y) (_anyval_eq_anyval(x,y)) $mymalloc !GROK!THIS! # set up the badvalues structure # - for binary compatability, this is created whatever the # value of $bvalflag and $usenan print OUT "typedef struct badvals {\n"; foreach my $i ( reverse(0 .. $ntypes) ) { my $name = $PDL::Types::names[$i]; my $realctype = $PDL::Types::typehash{$name}->{realctype}; my $cname = $PDL::Types::typehash{$name}->{ctype}; $cname =~ s/^PDL_//; printf OUT " %18s %s;\n",$realctype,$cname; printf OUT " %18s default_%s;\n",$realctype,$cname; } print OUT "} badvals;\n"; print OUT <<'!NO!SUBS!'; /* * Define the pdl C data structure which maps onto the original PDL * perl data structure. * * Note: pdl.sv is defined as a void pointer to avoid having to * include perl.h in C code which just needs the pdl data. * * We start with the meanings of the pdl.flags bitmapped flagset, * continue with a prerequisite "trans" structure that represents * transformations between linked PDLs, and finish withthe PD * structure itself. */ #define PDL_NDIMS 6 /* Number of dims[] to preallocate */ #define PDL_NCHILDREN 8 /* Number of children ptrs to preallocate */ #define PDL_NTHREADIDS 4 /* Number of different threadids/pdl to preallocate */ /* Constants for pdl.state - not all combinations make sense */ /* data allocated for this pdl. this implies that the data */ /* is up to date if !PDL_PARENTCHANGED */ #define PDL_ALLOCATED 0x0001 /* Parent data has been altered without changing this pdl */ #define PDL_PARENTDATACHANGED 0x0002 /* Parent dims or incs has been altered without changing this pdl. */ #define PDL_PARENTDIMSCHANGED 0x0004 /* Physical data representation of the parent has changed (e.g. */ /* physical transposition), so incs etc. need to be recalculated. */ #define PDL_PARENTREPRCHANGED 0x0008 #define PDL_ANYCHANGED (PDL_PARENTDATACHANGED|PDL_PARENTDIMSCHANGED|PDL_PARENTREPRCHANGED) /* Dataflow tracking flags -- F/B for forward/back. These get set */ /* by transformations when they are set up. */ #define PDL_DATAFLOW_F 0x0010 #define PDL_DATAFLOW_B 0x0020 #define PDL_DATAFLOW_ANY (PDL_DATAFLOW_F|PDL_DATAFLOW_B) /* Was this PDL null originally? */ #define PDL_NOMYDIMS 0x0040 /* Dims should be received via trans. */ #define PDL_MYDIMS_TRANS 0x0080 /* OK to attach a vaffine transformation (i.e. a slice) */ #define PDL_OPT_VAFFTRANSOK 0x0100 #define PDL_OPT_ANY_OK (PDL_OPT_VAFFTRANSOK) /* This is the hdrcpy flag */ #define PDL_HDRCPY 0x0200 /* This is a badval flag for this PDL (hmmm -- there is also a flag */ /* in the struct itself -- must be clearer about what this is for. --CED) */ #define PDL_BADVAL 0x0400 /* Debugging flag */ #define PDL_TRACEDEBUG 0x0800 /* inplace flag */ #define PDL_INPLACE 0x1000 /* Flag indicating destruction in progress */ #define PDL_DESTROYING 0x2000 /* If this flag is set, you must not alter the data pointer nor */ /* free this piddle nor use datasv (which should be null). */ /* This means e.g. that the piddle is mmapped from a file */ #define PDL_DONTTOUCHDATA 0x4000 /* Not sure what this does, but PP uses it a lot. -- CED */ #define PDL_CR_SETDIMSCOND(wtrans,pdl) (((pdl)->state & PDL_MYDIMS_TRANS) \ && (pdl)->trans == (pdl_trans *)(wtrans)) /************************************************** * * Transformation structure * * The structure is general enough to deal with functional transforms * (which were originally intended) but only slices and retype transforms * were implemented. * */ typedef enum pdl_transtype { PDL_SLICE, PDL_RETYPE } pdl_transtype; /* Transformation flags */ #define PDL_TRANS_AFFINE 0x0001 /* Transpdl flags */ #define PDL_TPDL_VAFFINE_OK 0x01 typedef struct pdl_trans pdl_trans; typedef struct pdl_transvtable { pdl_transtype transtype; int flags; int nparents; int npdls; char *per_pdl_flags; void (*redodims)(pdl_trans *tr); /* Only dims and internal trans (makes phys) */ void (*readdata)(pdl_trans *tr); /* Only data, to "data" ptr */ void (*writebackdata)(pdl_trans *tr); /* "data" ptr to parent or granny */ void (*freetrans)(pdl_trans *tr); /* Free both the contents and it of the trans member */ void (*dump)(pdl_trans *tr); /* Dump this transformation */ void (*findvparent)(pdl_trans *tr); /* Find a virtual parent and make ready for readdata etc. */ pdl_trans *(*copy)(pdl_trans *tr); /* Full copy */ int structsize; char *name; /* For debuggers, mostly */ } pdl_transvtable; /* All trans must start with this */ /* Trans flags */ /* Reversible transform -- flag indicates data can flow both ways. */ /* This is critical in routines that both input from and output to */ /* a non-single-valued pdl: updating must occur. (Note that the */ /* transform is not necessarily mathematically reversible) */ #define PDL_ITRANS_REVERSIBLE 0x0001 /* Whether, if a child is changed, this trans should be destroyed or not */ /* (flow if set; sever if clear) */ #define PDL_ITRANS_DO_DATAFLOW_F 0x0002 #define PDL_ITRANS_DO_DATAFLOW_B 0x0004 #define PDL_ITRANS_DO_DATAFLOW_ANY (PDL_ITRANS_DO_DATAFLOW_F|PDL_ITRANS_DO_DATAFLOW_B) #define PDL_ITRANS_ISAFFINE 0x1000 #define PDL_ITRANS_VAFFINEVALID 0x2000 #define PDL_ITRANS_NONMUTUAL 0x4000 /* flag for destruction */ // These define struct pdl_trans and all derived structures. There are many // structures that defined in other parts of the code that can be referenced // like a pdl_trans* because all of these structures have the same pdl_trans // initial piece. These structures can contain multiple pdl* elements in them. // Thus pdl_trans itself ends with a flexible pdl*[] array, which can be used to // reference any number of pdl objects. As a result pdl_trans itself can NOT be // instantiated // vparent is the "virtual parent" which is either // the parent or grandparent or whatever. The trans -structure must store // both the relationship with our current parent and, if necessary, the // virtual parent. #define PDL_TRANS_START_COMMON \ int magicno; \ short flags; \ pdl_transvtable *vtable; \ void (*freeproc)(struct pdl_trans *); /* Call to free this \ (means whether malloced or not) */ \ int bvalflag; /* required for binary compatability even if WITH_BADVAL=0 */ \ int has_badvalue; \ PDL_Anyval badvalue; \ int __datatype #define PDL_TRANS_START(np) \ PDL_TRANS_START_COMMON; \ /* The pdls involved in the transformation */ \ pdl *pdls[np] #define PDL_TRANS_START_FLEXIBLE() \ PDL_TRANS_START_COMMON; \ /* The pdls involved in the transformation */ \ pdl *pdls[] #ifdef PDL_DEBUGGING #define PDL_CHKMAGIC_GENERAL(it,this_magic,type) if((it)->magicno != this_magic) croak("INVALID " #type "MAGIC NO 0x%p %d\n",it,(int)((it)->magicno)); else (void)0 #else #define PDL_CHKMAGIC_GENERAL(it,this_magic,type) #endif #define PDL_TR_MAGICNO 0x91827364 #define PDL_TR_SETMAGIC(it) it->magicno = PDL_TR_MAGICNO #define PDL_TR_CLRMAGIC(it) it->magicno = 0x99876134 #define PDL_TR_CHKMAGIC(it) PDL_CHKMAGIC_GENERAL(it, PDL_TR_MAGICNO, "TRANS ") // This is a generic parent of all the trans structures. It is a flexible array // (can store an arbitrary number of pdl objects). Thus this can NOT be // instantiated, only "child" structures can struct pdl_trans { PDL_TRANS_START_FLEXIBLE(); } ; typedef struct pdl_trans_affine { PDL_TRANS_START(2); /* affine relation to parent */ PDL_Indx *incs; PDL_Indx offs; } pdl_trans_affine; /* Need to make compatible with pdl_trans_affine */ typedef struct pdl_vaffine { PDL_TRANS_START(2); PDL_Indx *incs; PDL_Indx offs; int ndims; PDL_Indx def_incs[PDL_NDIMS]; pdl *from; } pdl_vaffine; #define PDL_VAFFOK(pdl) (pdl->state & PDL_OPT_VAFFTRANSOK) #define PDL_REPRINC(pdl,which) (PDL_VAFFOK(pdl) ? \ pdl->vafftrans->incs[which] : pdl->dimincs[which]) #define PDL_REPROFFS(pdl) (PDL_VAFFOK(pdl) ? pdl->vafftrans->offs : 0) #define PDL_REPRP(pdl) (PDL_VAFFOK(pdl) ? pdl->vafftrans->from->data : pdl->data) #define PDL_REPRP_TRANS(pdl,flag) ((PDL_VAFFOK(pdl) && \ (flag & PDL_TPDL_VAFFINE_OK)) ? pdl->vafftrans->from->data : pdl->data) #define VAFFINE_FLAG_OK(flags,i) ((flags == NULL) ? 1 : (flags[i] & \ PDL_TPDL_VAFFINE_OK)) typedef struct pdl_children { pdl_trans *trans[PDL_NCHILDREN]; struct pdl_children *next; } pdl_children; struct pdl_magic; /**************************************** * PDL structure * Should be kept under 250 bytes if at all possible, for * easier segmentation... * * The 'sv', 'datasv', and 'hdrsv' fields are all void * to avoid having to * load perl.h for C codes that only use PDLs and not the Perl API. * * Similarly, the 'magic' field is void * to avoid having to typedef pdl_magic * here -- it is declared in "pdl_magic.h". */ #define PDL_MAGICNO 0x24645399 #define PDL_CHKMAGIC(it) PDL_CHKMAGIC_GENERAL(it,PDL_MAGICNO,"") struct pdl { unsigned long magicno; /* Always stores PDL_MAGICNO as a sanity check */ /* This is first so most pointer accesses to wrong type are caught */ int state; /* What's in this pdl */ pdl_trans *trans; /* Opaque pointer to internals of transformation from parent */ pdl_vaffine *vafftrans; /* pointer to vaffine transformation a vafftrans is an optimization that is possible for some types of trans (slice etc) - unused for non-affine transformations */ void* sv; /* (optional) pointer back to original sv. ALWAYS check for non-null before use. We cannot inc refcnt on this one or we'd never get destroyed */ void *datasv; /* Pointer to SV containing data. We own one inc of refcnt */ void *data; /* Pointer to actual data (in SV), or NULL if we have no data */ /* bad value stored as double, since get_badvalue returns a double */ PDL_Anyval badvalue; /* BAD value is stored as a PDL_Anyval for portability */ int has_badvalue; /* flag is required by pdlapi.c (compare to PDL_BADVAL above -- why two? --CED) */ PDL_Indx nvals; /* Actual size of data (not quite nelem in case of dummy) */ pdl_datatypes datatype; /* One of the usual suspects (PDL_L, PDL_D, etc.) */ PDL_Indx *dims; /* Array of data dimensions - could point below or to an allocated array */ PDL_Indx *dimincs; /* Array of data default increments, aka strides through memory for each dim (0 for dummies) */ short ndims; /* Number of data dimensions in dims and dimincs */ unsigned char *threadids; /* Starting index of the thread index set n */ unsigned char nthreadids; pdl_children children; PDL_Indx def_dims[PDL_NDIMS]; /* Preallocated space for efficiency */ PDL_Indx def_dimincs[PDL_NDIMS]; /* Preallocated space for efficiency */ unsigned char def_threadids[PDL_NTHREADIDS]; struct pdl_magic *magic; void *hdrsv; /* "header", settable from Perl */ }; /************* * Some macros for looping over the children of a given PDL */ #define PDL_DECL_CHILDLOOP(p) \ int p##__i; pdl_children *p##__c; #define PDL_START_CHILDLOOP(p) \ p##__c = &p->children; \ do { \ for(p##__i=0; p##__itrans[p##__i]) { #define PDL_CHILDLOOP_THISCHILD(p) p##__c->trans[p##__i] #define PDL_END_CHILDLOOP(p) \ } \ } \ if(!p##__c) break; \ if(!p##__c->next) break; \ p##__c=p##__c->next; \ } while(1); #define PDLMAX(a,b) ((a) > (b) ? (a) : (b)) /*************** * Some macros to guard against dataflow infinite recursion. */ #define DECL_RECURSE_GUARD static int __nrec=0; #define START_RECURSE_GUARD __nrec++; if(__nrec > 1000) {__nrec=0; die("PDL:Internal Error: data structure recursion limit exceeded (max 1000 levels)\n\tThis could mean that you have found an infinite-recursion error in PDL, or\n\tthat you are building data structures with very long dataflow dependency\n\tchains. You may want to try using sever() to break the dependency.\n");} #define ABORT_RECURSE_GUARD __nrec=0; #define END_RECURSE_GUARD __nrec--; #define PDL_ENSURE_ALLOCATED(it) ( (void)((it->state & PDL_ALLOCATED) || ((pdl_allocdata(it)),1)) ) #define PDL_ENSURE_VAFFTRANS(it) \ ( ((!it->vafftrans) || (it->vafftrans->ndims < it->ndims)) && \ (pdl_vafftrans_alloc(it),1) ) /* __PDL_H */ #endif !NO!SUBS! PDL-2.018/Basic/Core/pdlapi.c0000644060175006010010000012614213036512174013732 0ustar chmNone /* pdlapi.c - functions for manipulating pdl structs */ /* - for a while (up to + including 2.2.1) this file */ /* created by pdlapi.c.PL [due to bad value code] */ /* we now have dummy functions so do not need to */ /* create the file */ #define PDL_CORE /* For certain ifdefs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ /* Uncomment the following if you have core dumps or strange * behaviour - it may reveal the cause by croaking because of * bad magic number. */ /* #define DONT_REALLY_FREE */ /* This define causes the affine transformations not to be * optimized away so $a->slice(...) will always made physical. * Uncommenting this define is not recommended at the moment */ /* #define DONT_OPTIMIZE * #define DONT_VAFFINE */ extern Core PDL; void pdl__ensure_trans(pdl_trans *trans,int what) ; static int has_children(pdl *it) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) return 1; PDL_END_CHILDLOOP(it) return 0; } static int is_child_of(pdl *it,pdl_trans *trans) { int i; for(i=trans->vtable->nparents; ivtable->npdls; i++) { if(trans->pdls[i] == it) return 1; } return 0; } static int is_parent_of(pdl *it,pdl_trans *trans) { int i; for(i=0; ivtable->nparents; i++) { if(trans->pdls[i] == it) return 1; } return 0; } pdl *pdl_null() { PDL_Indx d[1] = {0}; pdl *it = pdl_new(); PDL_Anyval zero = { PDL_B, 0 }; pdl_makescratchhash(it, zero); pdl_setdims(it,d,1); it->state |= PDL_NOMYDIMS; return it; } pdl *pdl_get_convertedpdl(pdl *old,int type) { if(old->datatype != type) { pdl *it; it = pdl_null(); PDL.converttypei_new(old,it,type); if(it->datatype != type) { croak("FOOBAR! HELP!\n"); } return it; } else { return old; } } void pdl_allocdata(pdl *it) { int i; PDL_Indx nvals=1; SV *bar; for(i=0; indims; i++) { nvals *= it->dims[i]; } it->nvals = nvals; PDLDEBUG_f(printf("pdl_allocdata %p, %"IND_FLAG", %d\n",(void*)it, it->nvals, it->datatype)); pdl_grow(it,nvals); PDLDEBUG_f(pdl_dump(it)); it->state |= PDL_ALLOCATED; } /* Wrapper to pdl_create so that the pdl_new and pdl_tmp functions can be stored in the Core struct and exported to external PDL XS modules */ pdl* pdl_external_new() { return pdl_new(); } pdl* pdl_external_tmp() { return pdl_tmp(); } /* Return a new pdl - type is PDL_PERM or PDL_TMP - the latter is auto-freed * when current perl context is left * * pdl_new() and pdl_tmp() are macroes defined in pdlcore.h * which just call this routine. */ pdl* pdl_create(int type) { int i; pdl* it; if(type == PDL_TMP) {croak("PDL internal error. FIX!\n");} it = (pdl*) malloc(sizeof(pdl)); if (it==NULL) croak("Out of Memory\n"); it->magicno = PDL_MAGICNO; it->state = 0; it->datatype = 0; it->trans = NULL; it->vafftrans = NULL; it->sv = NULL; it->datasv = 0; it->data = 0; it->has_badvalue = 0; it->dims = it->def_dims; it->dimincs = it->def_dimincs; it->ndims = 0; it->nthreadids = 0; it->threadids = it->def_threadids; it->threadids[0] = 0; for(i=0; ichildren.trans[i]=NULL;} it->children.next = NULL; it->magic = 0; it->hdrsv = 0; PDLDEBUG_f(printf("CREATE %p (size=%zu)\n",(void*)it,sizeof(pdl))); return it; } /* Explicit free. Do not use, use destroy instead, which causes this to be called when the time is right */ void pdl__free(pdl *it) { pdl_children *p1,*p2; PDL_CHKMAGIC(it); /* now check if magic is still there */ if (pdl__ismagic(it)) { PDLDEBUG_f(printf("%p is still magic\n",(void*)it)); PDLDEBUG_f(pdl__print_magic(it)); } it->magicno = 0x42424245; PDLDEBUG_f(printf("FREE %p\n",(void*)it)); #ifndef DONT_REALLY_FREE if(it->dims != it->def_dims) free((void*)it->dims); if(it->dimincs != it->def_dimincs) free((void*)it->dimincs); if(it->threadids != it->def_threadids) free((void*)it->threadids); if(it->vafftrans) { pdl_vafftrans_free(it); } p1 = it->children.next; while(p1) { p2 = p1->next; free(p1); p1 = p2; } /* Free the phys representation */ /* XXX MEMLEAK */ /* it->vtable->freetrans(it,it->trans); */ /* Call special freeing magic, if exists */ if(PDL_ISMAGIC(it)) { pdl__call_magic(it, PDL_MAGIC_DELETEDATA); pdl__magic_free(it); } if(it->datasv) { SvREFCNT_dec(it->datasv); it->data=0; } else if(it->data) { pdl_warn("Warning: special data without datasv is not freed currently!!"); } if(it->hdrsv) { SvREFCNT_dec(it->hdrsv); it->hdrsv = 0; } free(it); #endif PDLDEBUG_f(printf("ENDFREE %p\n",(void*)it)); } void pdl__destroy_childtranses(pdl *it,int ensure) { PDL_DECL_CHILDLOOP(it); PDL_START_CHILDLOOP(it) pdl_destroytransform(PDL_CHILDLOOP_THISCHILD(it),ensure); PDL_END_CHILDLOOP(it) } /* A piddle may be - a parent of something - just ensure & destroy - a child of something - just ensure & destroy - parent of two pdls which both propagate backwards - mustn't destroy. - both parent and child at same time, to something that propagates. Therefore, simple rules: - allowed to destroy if 1. a parent with max. 1 backwards propagating transformation 2. a child with no children When a piddle is destroyed, it must tell its children and/or parent. */ void pdl_destroy(pdl *it) { int nback=0,nback2=0,nforw=0,nundest=0,nundestp=0; int nafn=0; pdl_trans *curt; PDL_DECL_CHILDLOOP(it); PDL_CHKMAGIC(it); PDLDEBUG_f(printf("Destr. %p\n",(void*)it);) if(it->state & PDL_DESTROYING) { PDLDEBUG_f(printf("Already Destr. %p\n",(void*)it);) return; } it->state |= PDL_DESTROYING; /* Clear the sv field so that there will be no dangling ptrs */ if(it->sv) { sv_setiv(it->sv,0x4242); it->sv = NULL; } /* 1. count the children that do flow */ PDL_START_CHILDLOOP(it) curt = PDL_CHILDLOOP_THISCHILD(it); if(PDL_CHILDLOOP_THISCHILD(it)->flags & (PDL_ITRANS_DO_DATAFLOW_F| PDL_ITRANS_DO_DATAFLOW_B)) nforw ++; if(PDL_CHILDLOOP_THISCHILD(it)->flags & PDL_ITRANS_DO_DATAFLOW_B) { nback ++; /* Cases where more than two in relationship * must always be soft-destroyed */ if(curt->vtable->npdls > 2) nback2++; } if(PDL_CHILDLOOP_THISCHILD(it)->flags & PDL_ITRANS_ISAFFINE) { if(!(curt->pdls[1]->state & PDL_ALLOCATED)) { nafn ++; } } PDL_END_CHILDLOOP(it) /* First case where we may not destroy */ if(nback2 > 0) goto soft_destroy; if(nback > 1) goto soft_destroy; /* Also not here */ if(it->trans && nforw) goto soft_destroy; /* Also, we do not wish to destroy if the children would be larger * than the parent and are currently not allocated (e.g. lags). * Because this is too much work to check, we refrain from destroying * for now if there is an affine child that is not allocated */ if(nafn) goto soft_destroy; if(pdl__magic_isundestroyable(it)) { PDLDEBUG_f(printf("Magic, not Destr. %p\n",(void*)it);) goto soft_destroy; } pdl__destroy_childtranses(it,1); if(it->trans) { PDLDEBUG_f(printf("Destr_trans. %p %d\n",(void*)(it->trans), it->trans->flags);) /* Ensure only if there are other children! */ /* XXX Bad: tmp! */ if (it->trans->flags & PDL_ITRANS_NONMUTUAL) pdl_destroytransform_nonmutual(it->trans,(it->trans->vtable->npdls - it->trans->vtable->nparents > 1)); else pdl_destroytransform(it->trans,(it->trans->vtable->npdls - it->trans->vtable->nparents > 1)); } /* Here, this is a child but has no children */ goto hard_destroy; hard_destroy: pdl__free(it); PDLDEBUG_f(printf("End destroy %p\n",(void*)it);) return; soft_destroy: PDLDEBUG_f(printf("May have dependencies, not destr. %p, nu(%d, %d), nba(%d, %d), nforw(%d), tra(%p), nafn(%d)\n", (void*)it, nundest, nundestp, nback, nback2, nforw, (void*)(it->trans), nafn);) it->state &= ~PDL_DESTROYING; } /* Straight copy, no dataflow */ pdl *pdl_hard_copy(pdl *src) { int i; pdl *it = pdl_null(); it->state = 0; pdl_make_physical(src); /* Wasteful XXX... should be lazier */ it->datatype = src->datatype; pdl_setdims(it,src->dims,src->ndims); pdl_allocdata(it); /* null != [0] */ #ifdef ELIFSLEFJSEFSE if(src->ndims == 1 && src->dims[0] == 0) #else if(src->state & PDL_NOMYDIMS) #endif it->state |= PDL_NOMYDIMS; pdl_reallocthreadids(it,src->nthreadids); for(i=0; inthreadids; i++) { it->threadids[i] = src->threadids[i]; } memcpy(it->data,src->data, pdl_howbig(it->datatype) * it->nvals); return it; } /* some constants for the dump_XXX routines */ #define PDL_FLAGS_TRANS 0 #define PDL_FLAGS_PDL 1 #define PDL_MAXSPACE 256 /* maximal number of prefix spaces in dump routines */ #define PDL_MAXLIN 60 void pdl_dump_flags_fixspace(int flags, int nspac, int type) { int i; int len, found, sz; int pdlflagval[] = { PDL_ALLOCATED,PDL_PARENTDATACHANGED, PDL_PARENTDIMSCHANGED,PDL_PARENTREPRCHANGED, PDL_DATAFLOW_F,PDL_DATAFLOW_B,PDL_NOMYDIMS, PDL_OPT_VAFFTRANSOK,PDL_INPLACE,PDL_DESTROYING, PDL_DONTTOUCHDATA, PDL_MYDIMS_TRANS, PDL_HDRCPY, PDL_BADVAL, PDL_TRACEDEBUG, 0 }; char *pdlflagchar[] = { "ALLOCATED","PARENTDATACHANGED", "PARENTDIMSCHANGED","PARENTREPRCHANGED", "DATAFLOW_F","DATAFLOW_B","NOMYDIMS", "OPT_VAFFTRANSOK","INPLACE","DESTROYING", "DONTTOUCHDATA","MYDIMS_TRANS", "HDRCPY", "BADVAL", "TRACEDEBUG" }; int transflagval[] = { PDL_ITRANS_REVERSIBLE, PDL_ITRANS_DO_DATAFLOW_F, PDL_ITRANS_DO_DATAFLOW_B, PDL_ITRANS_ISAFFINE, PDL_ITRANS_VAFFINEVALID, PDL_ITRANS_NONMUTUAL, 0 }; char *transflagchar[] = { "REVERSIBLE", "DO_DATAFLOW_F", "DO_DATAFLOW_B", "ISAFFINE", "VAFFINEVALID", "NONMUTUAL" }; int *flagval; char **flagchar; char spaces[PDL_MAXSPACE]; if (nspac >= PDL_MAXSPACE) { printf("too many spaces requested: %d" " (increase PDL_MAXSPACE in pdlapi.c), returning\n",nspac); return; } if (type == PDL_FLAGS_PDL) { flagval = pdlflagval; flagchar = pdlflagchar; } else { flagval = transflagval; flagchar = transflagchar; } for(i=0; iPDL_MAXLIN) {sz=0; printf("\n %s",spaces);} } printf("\n"); } /* Dump a transformation (don't dump the pdls, just pointers to them */ void pdl_dump_trans_fixspace (pdl_trans *it, int nspac) { int i; char spaces[PDL_MAXSPACE]; if (nspac >= PDL_MAXSPACE) { printf("too many spaces requested: %d" " (increase PDL_MAXSPACE in pdlapi.c), returning\n",nspac); return; } for(i=0; ivtable->name); pdl_dump_flags_fixspace(it->flags,nspac+3,PDL_FLAGS_TRANS); if(it->flags & PDL_ITRANS_ISAFFINE) { pdl_trans_affine *foo = (pdl_trans_affine *)it; if(it->pdls[1]->state & PDL_PARENTDIMSCHANGED) { printf("%s AFFINE, BUT DIMSCHANGED\n",spaces); } else { printf("%s AFFINE: o:%"IND_FLAG", i:(",spaces,foo->offs); for(i=0; ipdls[1]->ndims; i++) { printf("%s%"IND_FLAG,(i?" ":""),foo->incs[i]); } printf(") d:("); for(i=0; ipdls[1]->ndims; i++) { printf("%s%"IND_FLAG,(i?" ":""),foo->pdls[1]->dims[i]); } printf(")\n"); } } /* if(it->vtable->dump) {it->vtable->dump(it);} */ printf("%s INPUTS: (",spaces); for(i=0; ivtable->nparents; i++) printf("%s%p",(i?" ":""),(void*)(it->pdls[i])); printf(") OUTPUTS: ("); for(;ivtable->npdls; i++) printf("%s%p",(i?" ":""),(void*)(it->pdls[i])); printf(")\n"); } void pdl_dump_fixspace(pdl *it,int nspac) { PDL_DECL_CHILDLOOP(it) PDL_Indx i; char spaces[PDL_MAXSPACE]; if (nspac >= PDL_MAXSPACE) { printf("too many spaces requested: %d" " (increase PDL_MAXSPACE in pdlapi.c), returning\n",nspac); return; } for(i=0; idatatype); pdl_dump_flags_fixspace(it->state,nspac+3,PDL_FLAGS_PDL); printf("%s transvtable: %p, trans: %p, sv: %p\n",spaces, (void*)(it->trans?it->trans->vtable:0), (void*)(it->trans), (void*)(it->sv)); if(it->datasv) { printf("%s Data SV: %p, Svlen: %d, data: %p, nvals: %"IND_FLAG"\n", spaces, (void*)(it->datasv), (int)SvCUR((SV*)it->datasv), (void*)(it->data), it->nvals); } printf("%s Dims: %p (",spaces,(void*)(it->dims)); for(i=0; indims; i++) { printf("%s%"IND_FLAG,(i?" ":""),it->dims[i]); }; printf(")\n%s ThreadIds: %p (",spaces,(void*)(it->threadids)); for(i=0; inthreadids+1; i++) { printf("%s%d",(i?" ":""),it->threadids[i]); } if(PDL_VAFFOK(it)) { printf(")\n%s Vaffine ok: %p (parent), o:%"IND_FLAG", i:(", spaces,(void*)(it->vafftrans->from),it->vafftrans->offs); for(i=0; indims; i++) { printf("%s%"IND_FLAG,(i?" ":""),it->vafftrans->incs[i]); } } if(it->state & PDL_ALLOCATED) { printf(")\n%s First values: (",spaces); for(i=0; invals && i<10; i++) { printf("%s%f",(i?" ":""),pdl_get_offs(it,i).value.D); } } else { printf(")\n%s (not allocated",spaces); } printf(")\n"); if(it->trans) { pdl_dump_trans_fixspace(it->trans,nspac+3); } printf("%s CHILDREN:\n",spaces); PDL_START_CHILDLOOP(it) pdl_dump_trans_fixspace(PDL_CHILDLOOP_THISCHILD(it),nspac+4); PDL_END_CHILDLOOP(it) /* XXX phys etc. also */ } void pdl_dump (pdl *it) { pdl_dump_fixspace(it,0); } /* Reallocate this PDL to have ndims dimensions. The previous dims are copied. */ void pdl_reallocdims(pdl *it,int ndims) { int i; if (it->ndims < ndims) { /* Need to realloc for more */ if(it->dims != it->def_dims) free(it->dims); if(it->dimincs != it->def_dimincs) free(it->dimincs); if (ndims>PDL_NDIMS) { /* Need to malloc */ it->dims = malloc(ndims*sizeof(*(it->dims))); it->dimincs = malloc(ndims*sizeof(*(it->dimincs))); if (it->dims==NULL || it->dimincs==NULL) croak("Out of Memory\n"); } else { it->dims = it->def_dims; it->dimincs = it->def_dimincs; } } it->ndims = ndims; } /* Reallocate n threadids. Set the new extra ones to the end */ /* XXX Check logic */ void pdl_reallocthreadids(pdl *it,int n) { int i; unsigned char *olds; int nold; if(n <= it->nthreadids) { it->nthreadids = n; it->threadids[n] = it->ndims; return; } nold = it->nthreadids; olds = it->threadids; if(n >= PDL_NTHREADIDS-1) { it->threadids = malloc(sizeof(*(it->threadids))*(n+1)); } else { /* already is default */ } it->nthreadids = n; if(it->threadids != olds) { for(i=0; ithreadids[i] = olds[i]; } if(olds != it->def_threadids) { free(olds); } for(i=nold; inthreadids; i++) { it->threadids[i] = it->ndims; } } /* Calculate default increments and grow the PDL data */ void pdl_resize_defaultincs(pdl *it) { PDL_Indx inc = 1; int i=0; for(i=0; indims; i++) { it->dimincs[i] = inc; inc *= it->dims[i]; } it->nvals = inc; it->state &= ~PDL_ALLOCATED; /* Need to realloc when phys */ #ifdef DONT_OPTIMIZE pdl_allocdata(it); #endif } /* Init dims & incs - if *incs is NULL ignored (but space is always same for both) */ void pdl_setdims(pdl* it, PDL_Indx * dims, int ndims) { int i; pdl_reallocdims(it,ndims); for(i=0; idims[i] = dims[i]; pdl_resize_defaultincs(it); pdl_reallocthreadids(it,0); /* XXX Maybe trouble */ } /* This is *not* careful! */ void pdl_setdims_careful(pdl *it) { pdl_resize_defaultincs(it); #ifdef DONT_OPTIMIZE pdl_allocdata(it); #endif pdl_reallocthreadids(it,0); /* XXX For now */ } void pdl_print(pdl *it) { #ifdef FOO int i; printf("PDL %d: sv = %d, data = %d, datatype = %d, nvals = %d, ndims = %d\n", (int)it, (int)(it->hash), (int)(it->data), it->datatype, it->nvals, it->ndims); printf("Dims: "); for(i=0; indims; i++) { printf("%d(%d) ",it->dims[i],it->dimincs[i]); } printf("\n"); #endif } /* pdl_get is now vaffine aware */ PDL_Anyval pdl_get(pdl *it,PDL_Indx *inds) { int i; PDL_Indx *incs; PDL_Indx offs=PDL_REPROFFS(it); incs = PDL_VAFFOK(it) ? it->vafftrans->incs : it->dimincs; for(i=0; indims; i++) offs += incs[i] * inds[i]; return pdl_get_offs(PDL_REPRP(it),offs); } PDL_Anyval pdl_get_offs(pdl *it, PDL_Indx offs) { PDL_Indx dummy1=offs+1; PDL_Indx dummy2=1; return pdl_at(it->data, it->datatype, &offs, &dummy1, &dummy2, 0, 1); } void pdl_put_offs(pdl *it, PDL_Indx offs, PDL_Anyval value) { PDL_Indx dummy1=offs+1; PDL_Indx dummy2=1; pdl_set(it->data, it->datatype, &offs, &dummy1, &dummy2, 0, 1, value); } void pdl__addchildtrans(pdl *it,pdl_trans *trans,int nth) { int i; pdl_children *c; trans->pdls[nth] = it; c = &it->children; do { for(i=0; itrans[i]) { c->trans[i] = trans; return; } } if(!c->next) break; c=c->next; } while(1) ; c->next = malloc(sizeof(pdl_children)); c->next->trans[0] = trans; for(i=1; inext->trans[i] = 0; c->next->next = 0; } /* Problem with this function: when transformation is destroyed, * there may be several different children with the same name. * Therefore, we cannot croak :( */ void pdl__removechildtrans(pdl *it,pdl_trans *trans,int nth,int all) { int i; pdl_children *c; int flag = 0; if(all) { for(i=0; ivtable->nparents; i++) if(trans->pdls[i] == it) trans->pdls[i] = NULL; } else { trans->pdls[nth] = 0; } c = &it->children; do { for(i=0; itrans[i] == trans) { c->trans[i] = NULL; flag = 1; if(!all) return; /* return; Cannot return; might be many times (e.g. $a+$a) */ } } c=c->next; } while(c); /* this might be due to a croak when performing the trans; so warn only for now, otherwise we leave trans undestructed ! */ if(!flag) pdl_warn("Child not found for pdl %d, %d\n",it, trans); } void pdl__removeparenttrans(pdl *it, pdl_trans *trans, int nth) { trans->pdls[nth] = 0; it->trans = 0; } void pdl_make_physdims(pdl *it) { int i; int c = (it->state & (PDL_PARENTDIMSCHANGED | PDL_PARENTREPRCHANGED)) ; PDLDEBUG_f(printf("Make_physdims %p\n",(void*)it)); PDL_CHKMAGIC(it); if(!(it->state & (PDL_PARENTDIMSCHANGED | PDL_PARENTREPRCHANGED))) { PDLDEBUG_f(printf("Make_physdims_exit (NOP) %p\n",(void*)it)); return; } it->state &= ~(PDL_PARENTDIMSCHANGED | PDL_PARENTREPRCHANGED); /* the fact that a PARENTXXXCHANGED flag is set seems to imply that this pdl has an associated trans ? */ for(i=0; itrans->vtable->nparents; i++) { pdl_make_physdims(it->trans->pdls[i]); } /* doesn't this mean that all children of this trans have now their dims set and accordingly all those flags should be reset? Otherwise redodims will be called for them again? */ PDLDEBUG_f(printf("Make_physdims: calling redodims %p on %p\n", (void*)(it->trans),(void*)it)); it->trans->vtable->redodims(it->trans); /* why this one? will the old allocated data be freed correctly? */ if((c & PDL_PARENTDIMSCHANGED) && (it->state & PDL_ALLOCATED)) { it->state &= ~PDL_ALLOCATED; } PDLDEBUG_f(printf("Make_physdims_exit %p\n",(void*)it)); } void pdl_writeover(pdl *it) { pdl_make_physdims(it); pdl_children_changesoon(it,PDL_PARENTDATACHANGED); it->state &= ~PDL_PARENTDATACHANGED; } /* Order is important: do childtrans first, then parentrans. */ void pdl_set_trans_childtrans(pdl *it, pdl_trans *trans,int nth) { pdl__addchildtrans(it,trans,nth); /* Determine if we want to do dataflow */ if(it->state & PDL_DATAFLOW_F) trans->flags |= PDL_ITRANS_DO_DATAFLOW_F; if(it->state & PDL_DATAFLOW_B) trans->flags |= PDL_ITRANS_DO_DATAFLOW_B; } /* This is because for "+=" (a = a + b) we must check for previous parent transformations and mutate if they exist if no dataflow. */ void pdl_set_trans_parenttrans(pdl *it, pdl_trans *trans,int nth) { int i; int nthind; if((it->trans || is_parent_of(it,trans)) /* && (it->state & PDL_DATAFLOW_F) */ ) { /* XXX What if in several places */ nthind=-1; for(i=0; ivtable->nparents; i++) if(trans->pdls[i] == it) nthind = i; croak("Sorry, families not allowed now (i.e. You cannot modify dataflowing pdl)\n"); /* pdl_family_create(it,trans,nthind,nth); */ } else { it->trans = trans; it->state |= PDL_PARENTDIMSCHANGED | PDL_PARENTDATACHANGED ; trans->pdls[nth] = it; #ifdef FOOBARBAR if(trans->flags & PDL_ITRANS_DO_DATAFLOW_F) it->state |= PDL_DATAFLOW_F; if(trans->flags & PDL_ITRANS_DO_DATAFLOW_B) it->state |= PDL_DATAFLOW_B; #endif } } /* Called with a filled pdl_trans struct. * Sets the parent and trans fields of the piddles correctly, * creating families and the like if necessary. * Alternatively may just execute transformation * that would require families but is not dataflown. */ void pdl_make_trans_mutual(pdl_trans *trans) { int i; int fflag=0; int cfflag=0; int pfflag=0; PDL_TR_CHKMAGIC(trans); /* Then, set our children. This is: */ /* First, determine whether any of our children already have * a parent, and whether they need to be updated. If this is * the case, we need to do some thinking. */ PDLDEBUG_f(printf("make_trans_mutual %p\n",(void*)trans)); for(i=trans->vtable->nparents; ivtable->npdls; i++) { if(trans->pdls[i]->trans) fflag ++; if(trans->pdls[i]->state & PDL_DATAFLOW_ANY) cfflag++; } for(i=0; ivtable->nparents; i++) if(trans->pdls[i]->state & PDL_DATAFLOW_ANY) pfflag++; /* If children are flowing, croak. It's too difficult to handle * properly */ if(cfflag) croak("Sorry, cannot flowing families right now\n"); /* Same, if children have trans yet parents are flowing */ if(pfflag && fflag) croak("Sorry, cannot flowing families right now (2)\n"); /* Now, if parents are not flowing, just execute the transformation */ if(!pfflag && !(trans->flags & PDL_ITRANS_DO_DATAFLOW_ANY)) { int *wd = malloc(sizeof(int) * trans->vtable->npdls); /* mark this transform as non mutual in case we croak during ensuring it */ trans->flags |= PDL_ITRANS_NONMUTUAL; for(i=trans->vtable->nparents; ivtable->npdls; i++) { pdl_children_changesoon(trans->pdls[i], wd[i]=(trans->pdls[i]->state & PDL_NOMYDIMS ? PDL_PARENTDIMSCHANGED : PDL_PARENTDATACHANGED)); } /* mark all pdls that have been given as nulls (PDL_NOMYDIMS) as getting their dims from this trans */ for(i=trans->vtable->nparents; ivtable->npdls; i++) { if(trans->pdls[i]->state & PDL_NOMYDIMS) { trans->pdls[i]->state &= ~PDL_NOMYDIMS; trans->pdls[i]->state |= PDL_MYDIMS_TRANS; trans->pdls[i]->trans = trans; } } #ifdef BARBARBAR /* Not done */ for(i=trans->vtable->nparents; ivtable->npdls; i++) trans->pdls[i]->state |= PDL_PARENTDIMSCHANGED | PDL_PARENTDATACHANGED; #endif if(!trans->vtable) {die("INVALID TRANS: has no vtable!\n");} /* now actually perform the transformation, i.e. call transform's redodims and readdata vtable entries */ pdl__ensure_trans(trans,PDL_PARENTDIMSCHANGED); /* XXX Why? */ /* Es ist vollbracht */ for(i=trans->vtable->nparents; ivtable->npdls; i++) { #ifndef DONT_VAFFINE if( PDL_VAFFOK(trans->pdls[i]) && (trans->vtable->per_pdl_flags[i] & PDL_TPDL_VAFFINE_OK) ) { if(wd[i] & PDL_PARENTDIMSCHANGED) pdl_changed(trans->pdls[i], PDL_PARENTDIMSCHANGED,0); pdl_vaffinechanged( trans->pdls[i],PDL_PARENTDATACHANGED); } else #endif pdl_changed(trans->pdls[i],wd[i],0); } pdl_destroytransform_nonmutual(trans,0); free(wd); } else { /* do the full flowing transform */ PDLDEBUG_f(printf("make_trans_mutual flowing!\n")); for(i=0; ivtable->nparents; i++) pdl_set_trans_childtrans(trans->pdls[i],trans,i); for(i=trans->vtable->nparents; ivtable->npdls; i++) pdl_set_trans_parenttrans(trans->pdls[i],trans,i); if(!(trans->flags & PDL_ITRANS_REVERSIBLE)) trans->flags &= ~PDL_ITRANS_DO_DATAFLOW_B; for(i=trans->vtable->nparents; ivtable->npdls; i++) { if(trans->pdls[i]->state & PDL_NOMYDIMS) { trans->pdls[i]->state &= ~PDL_NOMYDIMS; trans->pdls[i]->state |= PDL_MYDIMS_TRANS; } } } #ifdef FOO /* If we are not flowing, we must disappear */ if(!(trans->flags & PDL_ITRANS_DO_DATAFLOW_ANY)) { pdl_destroytransform(trans,1); } #endif PDLDEBUG_f(printf("make_trans_mutual_exit %p\n",(void*)trans)); } /* pdl_make_trans_mutual() */ void pdl_make_physical(pdl *it) { int i, vaffinepar=0; DECL_RECURSE_GUARD; PDLDEBUG_f(printf("Make_physical %p\n",(void*)it)); PDL_CHKMAGIC(it); START_RECURSE_GUARD; if(it->state & PDL_ALLOCATED && !(it->state & PDL_ANYCHANGED)) { goto mkphys_end; } if(!(it->state & PDL_ANYCHANGED)) { pdl_allocdata(it); goto mkphys_end; } if(!it->trans) { ABORT_RECURSE_GUARD; die("PDL Not physical but doesn't have parent"); } #ifndef DONT_OPTIMIZE #ifndef DONT_VAFFINE if(it->trans->flags & PDL_ITRANS_ISAFFINE) { if(!PDL_VAFFOK(it)) pdl_make_physvaffine(it); } if(PDL_VAFFOK(it)) { PDLDEBUG_f(printf("Make_phys: VAFFOK\n")); pdl_readdata_vaffine(it); it->state &= (~PDL_ANYCHANGED); PDLDEBUG_f(pdl_dump(it)); goto mkphys_end; } #endif #endif PDL_TR_CHKMAGIC(it->trans); for(i=0; itrans->vtable->nparents; i++) { #ifndef DONT_OPTIMIZE #ifndef DONT_VAFFINE if(it->trans->vtable->per_pdl_flags[i] & PDL_TPDL_VAFFINE_OK) { pdl_make_physvaffine(it->trans->pdls[i]); /* check if any of the parents is a vaffine */ vaffinepar = vaffinepar || (it->trans->pdls[i]->data != PDL_REPRP(it->trans->pdls[i])); } else #endif #endif pdl_make_physical(it->trans->pdls[i]); } /* the next one is really strange: * * why do we need to call redodims if !(it->state & PDL_ALLOCATED) ??? * this results in a) redodims called twice if make_physdims had already been * called for this piddle and results in associated memory leaks! * On the other hand, if I comment out !(it->state & PDL_ALLOCATED) * then we get errors for cases like * $in = $lut->xchg(0,1)->index($im->dummy(0)); * $in .= pdl -5; * Currently ugly fix: detect in initthreadstruct that it has been called before * and free all pdl_thread related memory before reallocating * NOTE: this does not catch leaks when additional memory was allocated from with * redodims!!!!! * * The real question is: why do we need another call to * redodims if !(it->state & PDL_ALLOCATED)?????? * changed it so that redodims only called if * (!(it->state & PDL_ALLOCATED) && vaffinepar) * i.e. at least one of the parent piddles is a real vaffine * CS */ if((!(it->state & PDL_ALLOCATED) && vaffinepar) || it->state & PDL_PARENTDIMSCHANGED || it->state & PDL_PARENTREPRCHANGED) { it->trans->vtable->redodims(it->trans); } if(!(it->state & PDL_ALLOCATED)) { pdl_allocdata(it); } /* Make parents physical first. XXX Needs more reasonable way */ /* Already done * for(i=0; itrans->vtable->nparents; i++) { * pdl_make_physical(it->trans->pdls[i]); * } */ /* * We think we made them physical or physvaffine already... * for(i=0; itrans->vtable->npdls; i++) { * if(!(it->trans->pdls[i]->state & PDL_ALLOCATED)) { * croak("Trying to readdata without physicality"); * } *} */ it->trans->vtable->readdata(it->trans); it->state &= (~PDL_ANYCHANGED) & (~PDL_OPT_ANY_OK); mkphys_end: PDLDEBUG_f(printf("Make_physical_exit %p\n",(void*)it)); END_RECURSE_GUARD; } void pdl_children_changesoon_c(pdl *it,int what) { pdl_trans *t; int i; PDL_DECL_CHILDLOOP(it); PDL_START_CHILDLOOP(it) t = PDL_CHILDLOOP_THISCHILD(it); if(!(t->flags & PDL_ITRANS_DO_DATAFLOW_F)) { pdl_destroytransform(t,1); } else { for(i=t->vtable->nparents; ivtable->npdls; i++) { pdl_children_changesoon_c(t->pdls[i],what); } } PDL_END_CHILDLOOP(it) } /* Change soon: if this is not writeback, separate from parent. If the children of this are not writeback, separate them. */ void pdl_children_changesoon(pdl *it, int what) { pdl_children *c; int i; if(it->trans && !(it->trans->flags & PDL_ITRANS_DO_DATAFLOW_B)) { pdl_destroytransform(it->trans,1); } else if(it->trans) { if(!(it->trans->flags & PDL_ITRANS_REVERSIBLE)) { die("PDL: Internal error: Trying to reverse irreversible trans"); } for(i=0; itrans->vtable->nparents; i++) pdl_children_changesoon(it->trans->pdls[i],what); return; } pdl_children_changesoon_c(it,what); } /* what should always be PARENTDATA */ void pdl_vaffinechanged(pdl *it, int what) { if(!PDL_VAFFOK(it)) { croak("Vaffine not ok!, trying to use vaffinechanged"); } PDLDEBUG_f(printf("pdl_vaffinechanged: writing back data, triggered by pdl %p, using parent %p\n",(void*)it,(void*)(it->vafftrans->from))); pdl_changed(it->vafftrans->from,what,0); } /* This is inefficient: _changed writes back, which it really should not, before a parent is used (?). */ void pdl_changed(pdl *it, int what, int recursing) { pdl_children *c; int i; int j; PDLDEBUG_f( printf("pdl_changed: entry for pdl %p, what %d, recursing: %d\n", (void*)it,what,recursing); if (it->state & PDL_TRACEDEBUG) pdl_dump(it); ); /* XXX This might save time but is actually unsafe: * if a -> b -> c, and c made physical and a changed again, * the changedness doesn't propagate to c */ /* if((it->state & what) == what) { return; } */ if(recursing) { it->state |= what; /* The next one is commented out since it breaks PP functions with more (1) than 1 output arg (i.e. more than 2 children) (2) that are called with chained slices of the same parent and (3) require these args to be physicalized An example of this scenario (which actually occurred first in actual code with complex numbers) is in t/pptest.t (at the end). Presumably the bit of code below that unsets the vafftransok flag was only inserted to make the 'foomethod' example work. It explores changing parameters of a transformation and making sure that everything flows correctly. Based on this idea removing the statement below should not break anything and fix the problem with PP funcs described above (CS 190403) */ /* it->state &= ~PDL_OPT_VAFFTRANSOK; */ if(pdl__ismagic(it)) pdl__call_magic(it,PDL_MAGIC_MARKCHANGED); } if(it->trans && !recursing && (it->trans->flags & PDL_ITRANS_DO_DATAFLOW_B)) { if((it->trans->flags & PDL_ITRANS_ISAFFINE) && (PDL_VAFFOK(it))) { PDLDEBUG_f(printf("pdl_changed: calling writebackdata_vaffine (pdl %p)\n",(void*)it)); pdl_writebackdata_vaffine(it); pdl_changed(it->vafftrans->from,what,0); } else { if(!it->trans->vtable->writebackdata) { die("Internal error: got so close to reversing irrev."); } PDLDEBUG_f(printf("pdl_changed: calling writebackdata from vtable, triggered by pdl %p, using trans %p\n",(void*)it,(void*)(it->trans))); it->trans->vtable->writebackdata(it->trans); for(i=0; itrans->vtable->nparents; i++) { if((it->trans->vtable->per_pdl_flags[i] & PDL_TPDL_VAFFINE_OK) && (it->trans->pdls[i]->trans) && (it->trans->pdls[i]->trans->flags & PDL_ITRANS_ISAFFINE) && (PDL_VAFFOK(it->trans->pdls[i])) ) { pdl_changed(it->trans->pdls[i]->vafftrans->from,what,0); } else { pdl_changed(it->trans->pdls[i],what,0); } } } } else { c=&it->children; do { for(i=0; itrans[i]) { for(j=c->trans[i]->vtable->nparents; jtrans[i]->vtable->npdls; j++) { pdl_changed(c->trans[i]->pdls[j],what,1); } } } c=c->next; } while(c); } PDLDEBUG_f(printf("pdl_changed: exiting for pdl %p\n",(void*)it)); } /* This transformation changes soon, so make sure the children * who don't flow go away * XXX Should be able to specify which children. */ void pdl_trans_changesoon(pdl_trans *trans,int what) { int i; for(i=trans->vtable->nparents; ivtable->npdls; i++) { pdl_children_changesoon_c(trans->pdls[i],what); } } /* Changed, just propagate changes to children * XXX should be able to specify which children */ void pdl_trans_changed(pdl_trans *trans,int what) { int i; for(i=trans->vtable->nparents; ivtable->npdls; i++) { pdl_changed(trans->pdls[i],what,1); } } /* Make sure transformation is done */ void pdl__ensure_trans(pdl_trans *trans,int what) { int j; /* Make parents physical */ int flag=0; int par_pvaf=0; flag |= what; PDL_TR_CHKMAGIC(trans); for(j=0; jvtable->nparents; j++) { #ifndef DONT_OPTIMIZE #ifndef DONT_VAFFINE if(trans->vtable->per_pdl_flags[j] & PDL_TPDL_VAFFINE_OK) { par_pvaf++; if(!trans->pdls[j]) {return;} /* XXX!!! */ pdl_make_physvaffine(trans->pdls[j]); } else { #endif #endif if(!trans->pdls[j]) {return;} /* XXX!!! */ pdl_make_physical(trans->pdls[j]); } } for(; jvtable->npdls; j++) { if(trans->pdls[j]->trans != trans) { #ifndef DONT_OPTIMIZE #ifndef DONT_VAFFINE if(trans->vtable->per_pdl_flags[j] & PDL_TPDL_VAFFINE_OK) { par_pvaf++; if(!trans->pdls[j]) {return;} /* XXX!!! */ pdl_make_physvaffine(trans->pdls[j]); } else #endif #endif { if(!trans->pdls[j]) {return;} /* XXX!!! */ PDLDEBUG_f(printf("not vaffine ok: %d\n", trans->vtable->per_pdl_flags[j])); pdl_make_physical(trans->pdls[j]); } } flag |= trans->pdls[j]->state & PDL_ANYCHANGED; } if(flag & PDL_PARENTDIMSCHANGED) { /* redodims called here... */ trans->vtable->redodims(trans); } for(j=0; jvtable->npdls; j++) { if(trans->pdls[j]->trans == trans) PDL_ENSURE_ALLOCATED(trans->pdls[j]); } if(flag & (PDL_PARENTDATACHANGED | PDL_PARENTDIMSCHANGED)) { int i; if(par_pvaf && (trans->flags & PDL_ITRANS_ISAFFINE)) { /* Attention: this assumes affine = p2child */ /* need to signal that redodims has already been called */ /* is it correct to also unset PDL_PARENTREPRCHANGED? */ trans->pdls[1]->state &= ~(PDL_PARENTDIMSCHANGED | PDL_PARENTREPRCHANGED); pdl_make_physvaffine(((pdl_trans_affine *)(trans))->pdls[1]); pdl_readdata_vaffine(((pdl_trans_affine *)(trans))->pdls[1]); } else { #ifdef DONT_VAFFINE for(i=0; ivtable->npdls; i++) { if(!(trans->pdls[i]->state & PDL_ALLOCATED)) { croak("Trying to readdata without physicality"); } } #endif trans->vtable->readdata(trans); } } for(j=trans->vtable->nparents; jvtable->npdls; j++) { trans->pdls[j]->state &= ~PDL_ANYCHANGED; } } void pdl__ensure_transdims(pdl_trans *trans) { int j; int flag=0; PDL_TR_CHKMAGIC(trans); for(j=0; jvtable->nparents; j++) { pdl_make_physdims(trans->pdls[j]); } trans->vtable->redodims(trans); } /* There is a potential problem here, calling pdl_destroy while the trans structure is not in a defined state. We shall ignore this problem for now and hope it goes away ;) (XXX FIX ME) */ /* XXX Two next routines are memleaks */ /* somehow this transform will call (implicitly) redodims twice on an unvaffined pdl; leads to memleak if redodims allocates stuff that is only freed in later call to freefunc */ void pdl_destroytransform(pdl_trans *trans,int ensure) { int j; pdl *foo; pdl *destbuffer[100]; int ndest = 0; PDLDEBUG_f(printf("entering pdl_destroytransform %p (ensure %d)\n", (void*)trans,ensure)); if(100 < trans->vtable->npdls) { die("Huge trans"); } PDL_TR_CHKMAGIC(trans); if(!trans->vtable) { die("ZERO VTABLE DESTTRAN 0x%p %d\n",trans,ensure); } if(ensure) { PDLDEBUG_f(printf("pdl_destroytransform: ensure\n")); pdl__ensure_trans(trans,0); } for(j=0; jvtable->nparents; j++) { foo = trans->pdls[j]; if(!foo) continue; PDL_CHKMAGIC(foo); PDLDEBUG_f(printf("pdl_removectransform(%p): %p %d\n", (void*)trans, (void*)(trans->pdls[j]), j)); pdl__removechildtrans(trans->pdls[j],trans,j,1); if(!(foo->state & PDL_DESTROYING) && !foo->sv) { destbuffer[ndest++] = foo; } } for(; jvtable->npdls; j++) { foo = trans->pdls[j]; PDL_CHKMAGIC(foo); PDLDEBUG_f(printf("pdl_removeptransform(%p): %p %d\n", (void*)trans, (void*)(trans->pdls[j]), j)); pdl__removeparenttrans(trans->pdls[j],trans,j); if(foo->vafftrans) { PDLDEBUG_f(printf("pdl_removevafft: %p\n", (void*)foo)); pdl_vafftrans_remove(foo); } if(!(foo->state & PDL_DESTROYING) && !foo->sv) { destbuffer[ndest++] = foo; } } PDL_TR_CHKMAGIC(trans); if(trans->vtable->freetrans) { PDLDEBUG_f(printf("call freetrans\n")); trans->vtable->freetrans(trans); /* Free malloced objects */ } PDL_TR_CLRMAGIC(trans); trans->vtable = 0; /* Make sure no-one uses this */ if(trans->freeproc) { PDLDEBUG_f(printf("call freeproc\n")); trans->freeproc(trans); } else { PDLDEBUG_f(printf("call free\n")); free(trans); } for(j=0; jvtable->nparents; ivtable->npdls; i++) { trans->pdls[i]->state &= ~PDL_NOMYDIMS; if(trans->pdls[i]->trans == trans) trans->pdls[i]->trans = 0; } PDL_TR_CHKMAGIC(trans); if(trans->vtable->freetrans) { trans->vtable->freetrans(trans); } PDL_TR_CLRMAGIC(trans); trans->vtable = 0; /* Make sure no-one uses this */ if(trans->freeproc) { trans->freeproc(trans); } else { free(trans); } PDLDEBUG_f(printf("leaving pdl_destroytransform_nonmutual\n")); } void pdl_trans_mallocfreeproc(struct pdl_trans *tr) { free(tr); } #ifndef DONT_OPTIMIZE /* Recursive! */ void pdl_vafftrans_remove(pdl * it) { pdl_trans *t; int i; PDL_DECL_CHILDLOOP(it); PDL_START_CHILDLOOP(it) t = PDL_CHILDLOOP_THISCHILD(it); if(t->flags & PDL_ITRANS_ISAFFINE) { for(i=t->vtable->nparents; ivtable->npdls; i++) pdl_vafftrans_remove(t->pdls[i]); } PDL_END_CHILDLOOP(it) pdl_vafftrans_free(it); } void pdl_vafftrans_free(pdl *it) { if(it->vafftrans && it->vafftrans->incs) free(it->vafftrans->incs); if(it->vafftrans) free(it->vafftrans); it->vafftrans=0; it->state &= ~PDL_OPT_VAFFTRANSOK; } /* Current assumptions: only * "slice" and "diagonal"-type things supported. * * We need to do careful testing for clump-type things. */ /* pdl_make_physvaffine can be called on *any* pdl -- vaffine or not -- it will call make_physical as needed on those this function is the right one to call in any case if you want to make only those physical (i.e. allocating their own data, etc) which have to be and leave those vaffine with updated dims, etc, that do have an appropriate transformation of which they are a child should probably have been called make_physcareful to point out what it really does */ void pdl_make_physvaffine(pdl *it) { pdl_trans *t; pdl_trans_affine *at; pdl *parent; pdl *current; PDL_Indx *incsleft = 0; int i,j; PDL_Indx inc; PDL_Indx newinc; PDL_Indx ninced; int flag; int incsign; PDLDEBUG_f(printf("Make_physvaffine %p\n",(void*)it)); pdl_make_physdims(it); if(!it->trans) { pdl_make_physical(it); goto mkphys_vaff_end; /* croak("Trying to make physvaffine without parent!\n"); */ } if(!(it->trans->flags & PDL_ITRANS_ISAFFINE)) { pdl_make_physical(it); goto mkphys_vaff_end; } (void)PDL_ENSURE_VAFFTRANS(it); incsleft = malloc(sizeof(*incsleft)*it->ndims); PDLDEBUG_f(printf("vaff_malloc: got %p\n",(void*)incsleft)); for(i=0; indims; i++) { it->vafftrans->incs[i] = it->dimincs[i]; } flag=0; it->vafftrans->offs = 0; t=it->trans; current = it; while(t && (t->flags & PDL_ITRANS_ISAFFINE)) { PDL_Indx cur_offset = 0; at = (pdl_trans_affine *)t; parent = t->pdls[0]; /* For all dimensions of the childest piddle */ for(i=0; indims; i++) { PDL_Indx offset_left = it->vafftrans->offs; /* inc = the increment at the current stage */ inc = it->vafftrans->incs[i]; incsign = (inc >= 0 ? 1:-1); inc *= incsign; newinc = 0; /* For all dimensions of the current piddle */ for(j=current->ndims-1; j>=0 && current->dimincs[j] != 0; j--) { cur_offset = offset_left / current->dimincs[j]; offset_left -= cur_offset * current->dimincs[j]; if(incsign < 0) { cur_offset = (current->dims[j]-1) - cur_offset; } /* If the absolute value > this so */ /* we have a contribution from this dimension */ if(inc >= current->dimincs[j]) { /* We used this many of this dim */ ninced = inc / current->dimincs[j]; if(cur_offset + it->dims[i]*ninced > current->dims[j]) { PDL_Indx foo = (cur_offset + it->dims[i]*ninced)* current->dimincs[j]; int k; for(k=j+1; kndims; k++) { foo -= current->dimincs[k-1] * current->dims[k-1]; if(foo<=0) break; if(at->incs[k] != at->incs[k-1] * current->dims[k-1]) { /* XXXXX */ flag=1; /* warn("Illegal vaffine; fix loop to break: %d %d %d k=%d s=%d, (%d+%d*%d>%d) %d %d %d %d.\n",at,current,it, k,incsign,cur_offset,it->dims[i],ninced,current->dims[j],current->dimincs[j], at->incs[k],at->incs[k-1],current->dims[k-1]); */ /* croak("Illegal vaffine; fix loop to break.\n"); */ } } } newinc += at->incs[j]*ninced; inc %= current->dimincs[j]; } } incsleft[i] = incsign*newinc; } if(flag) break; for(i=0; indims; i++) { it->vafftrans->incs[i] = incsleft[i]; } { PDL_Indx offset_left = it->vafftrans->offs; inc = it->vafftrans->offs; newinc = 0; for(j=current->ndims-1; j>=0 && current->dimincs[j] != 0; j--) { cur_offset = offset_left / current->dimincs[j]; offset_left -= cur_offset * current->dimincs[j]; newinc += at->incs[j]*cur_offset; } it->vafftrans->offs = newinc; it->vafftrans->offs += at->offs; } t = parent->trans; current = parent; } it->vafftrans->from = current; it->state |= PDL_OPT_VAFFTRANSOK; pdl_make_physical(current); mkphys_vaff_end: PDLDEBUG_f(printf("vaff_malloc: %p\n",(void*)incsleft)); if (incsleft != NULL) free(incsleft); PDLDEBUG_f(printf("Make_physvaffine_exit %p\n",(void*)it)); } void pdl_vafftrans_alloc(pdl *it) { if(!it->vafftrans) { it->vafftrans = malloc(sizeof(*(it->vafftrans))); it->vafftrans->incs = 0; it->vafftrans->ndims = 0; } if(!it->vafftrans->incs || it->vafftrans->ndims < it->ndims ) { if(it->vafftrans->incs) free(it->vafftrans->incs); it->vafftrans->incs = malloc(sizeof(*(it->vafftrans->incs)) * it->ndims); it->vafftrans->ndims = it->ndims; } } #endif PDL-2.018/Basic/Core/pdlbadvalinit.c.PL0000644060175006010010000000031112562522363015601 0ustar chmNone# using this because XSUBs won't do INCLUDE_COMMAND in BOOT: use PDL::Core::Dev; my $file = shift @ARGV; open my $fh, '>', $file or die "$file: $!"; select $fh; PDL::Core::Dev::generate_badval_init(); PDL-2.018/Basic/Core/pdlconv.c.PL0000644060175006010010000002007613101130663014427 0ustar chmNone# # Create pdlconv.c # - for many different datatypes use strict; use Config; use File::Basename qw(&basename &dirname); require './Dev.pm'; PDL::Core::Dev->import; use vars qw( %PDL_DATATYPES ); require './Types.pm'; #for typesrtkeys # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" print "Extracting $file\n"; open OUT,">$file" or die "Can't create $file: $!"; chmod 0644, $file; # $date = `date`; chop $date; ##### HEADER ###### print OUT <<"!WITH!SUBS!"; /*************************************************************** pdlconv.c automatically created by pdlconv.c.PL ****************************************************************/ !WITH!SUBS! print OUT <<'!NO!SUBS!'; #define PDL_CORE /* For certain ifdefs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ !NO!SUBS! # these 2 routines shouldn't need to be changed to handle # bad values, since all they do is copy data from # one piddle to another of the same type # (assuming no per-piddle bad values) # for(['readdata_vaffine', "*ap = *pp"], ['writebackdata_vaffine', "*pp = *ap"]) { my $name = $_->[0]; my $code = $_->[1]; print OUT <<"!WITH!SUBS!"; void pdl_${name}(pdl *a) { PDL_Indx i; int j; int intype = a->datatype; if(!PDL_VAFFOK(a)) { die("pdl_$name without vaffine"); } PDL_ENSURE_ALLOCATED(a); switch ( intype ) { !WITH!SUBS! ##### Generate code for each data type ##### for my $in ( PDL::Types::typesrtkeys() ) { my $intype = $PDL_DATATYPES{$in}; print OUT <<"!WITH!SUBS!"; case ${in}: { $intype *ap = ($intype *) a->data; $intype *pp = ($intype *) a->vafftrans->from->data; pp += a->vafftrans->offs; for(i=0; invals; i++) { ${code}; for(j=0; jndims; j++) { pp += a->vafftrans->incs[j]; if((j < a->ndims - 1 && (i+1) % a->dimincs[j+1]) || j == a->ndims - 1) break; pp -= a->vafftrans->incs[j] * a->dims[j]; } ap ++; } } break; !WITH!SUBS! } #### End of perl loop #### # default: # die("pdl_$name does not recognise the datatype"); print OUT <<'!NO!SUBS!'; } /* switch( intype ) */ /*** free(inds); ***/ } !NO!SUBS! } # End of outer perl loop print OUT <<'!NO!SUBS!'; /* Various conversion utilities for pdl data types */ /* Swap pdls */ void pdl_swap(pdl** a, pdl** b) { pdl* tmp; tmp = *b; *b=*a; *a=tmp; } /* Change the type of all the data in a pdl struct, either changing the original perl structure or making a temporary copy */ /* * it seems this does not have to be aware of bad values * (at least in the current scheme) */ void pdl_converttype( pdl** aa, int targtype, Logical changePerl ) { pdl* a=*aa; /* Point to cache */ int intype; void* b; /* Scratch data ptr */ SV* bar; HV* hash; STRLEN nbytes; int diffsize; PDL_Indx i; #if (PERL_VERSION >= 5) && (PERL_SUBVERSION >= 57) dXSARGS; #endif PDLDEBUG_f(printf("pdl_converttype %p, %d, %d, %d\n", (void*)a, a->datatype, targtype, changePerl);) intype = a->datatype; if (intype == targtype) return; diffsize = pdl_howbig(targtype) != pdl_howbig(a->datatype); nbytes = a->nvals * pdl_howbig(targtype); /* Size of converted data */ if (changePerl) { /* Grow data */ if(a->state & PDL_DONTTOUCHDATA) { croak("Trying to convert of magical (mmaped?) pdl"); } if (diffsize) { b = a->data; /* pointer to old data */ a->data = pdl_malloc(nbytes); /* Space for changed data */ } else{ b = a->data; /* In place */ } }else{ die("Sorry, temporary type casting is not allowed now"); b = a->data; /* Ptr to old data */ a = pdl_tmp(); /* Brand new scratch pdl */ /* pdl_clone(*aa, a); */ /* Copy old pdl entries */ a->data = pdl_malloc(nbytes); /* Space for changed data */ *aa = a; /* Change passed value to new address */ } /* Do the conversion as nested switch statements */ switch ( intype ) { !NO!SUBS! ##### Generate code for each pair of data types ##### for my $in ( PDL::Types::typesrtkeys() ) { my $intype = $PDL_DATATYPES{$in}; print OUT <<"!WITH!SUBS!"; case ${in}: { $intype *bb = ($intype *) b; i = a->nvals; switch ( targtype ) { !WITH!SUBS! for my $targ ( PDL::Types::typesrtkeys() ) { next if $in eq $targ; # Skip duplicates my $targtype = $PDL_DATATYPES{$targ}; print OUT <<"!WITH!SUBS!"; case ${targ}: { $targtype *aa = ($targtype *) a->data; aa += i-1; bb += i-1; while (i--) *aa-- = ($targtype) *bb--; } break; !WITH!SUBS! } # for: $targ print OUT <<"!WITH!SUBS!"; default: croak("Don't know how to convert datatype $in to #%d", targtype); } /* switch targtype */ break; } /* case: $in */ !WITH!SUBS! } # for: $in #### Trailer #### print OUT <<'!NO!SUBS!'; default: croak("Don't know how to convert datatype %d to %d", intype, targtype); } if (changePerl) { /* Tidy up */ /* Store new data */ if (diffsize) { STRLEN n_a; bar = a->datasv; sv_setpvn( bar, (char*) a->data, nbytes ); a->data = (void*) SvPV(bar, n_a); } } a->datatype = targtype; } /* Ensure 'a' and 'b' are the same data types of high enough precision, using a reasonable set of rules. */ void pdl_coercetypes( pdl** aa, pdl** bb, Logical changePerl ) { pdl* a = *aa; /* Double ptr passed as value of ptr may be changed to */ pdl* b = *bb; /* point at a temporary copy of the cached pdl */ Logical oneisscalar; pdl *scalar,*vector; int targtype; if (a->datatype == b->datatype) /* Nothing to be done */ return; /* Detect the vector & scalar case */ oneisscalar = (a->nvals==1 || b->nvals==1) && !(a->nvals==1 && b->nvals==1); /* Rules for deciding what the target data type is */ if (oneisscalar) { /* Vector x Scalar case */ scalar = a; vector = b; if (b->nvals==1) { scalar = b; vector = a; } if (vector->datatype >= scalar->datatype) /* Vector more complex - easy */ targtype = vector->datatype; else { /* Scalar more complex than vector- special rules to avoid overzealous promotion of vector */ if (vector->datatype == PDL_F) /* FxD is OK as F */ targtype = vector->datatype; else if (vector->datatype < PDL_F && scalar->datatype < PDL_F) targtype = vector->datatype; /* two ints is OK as input int */ else if (vector->datatype <= PDL_F && scalar->datatype==PDL_D) targtype = PDL_F; /* Only promote FOOxD as far as F */ else targtype = scalar->datatype; } }else{ /* Vector x Vector - easy */ targtype = a->datatype; if (b->datatype > a->datatype) targtype = b->datatype; } /* Do the conversion */ pdl_converttype(aa, targtype, changePerl); pdl_converttype(bb, targtype, changePerl); } /* Given PDL return an allocated **ptr to 2D data thus allowing a[j][i] syntax */ void ** pdl_twod( pdl* x ) { PDL_Indx i,nx,ny; int size; void **p; char *xx; if (x->ndims>2) croak("Data must be 1 or 2-dimensional for this routine"); xx = (char*) x->data; nx = *(x->dims); ny = x->ndims==2 ? *(x->dims+1) : 1; size=pdl_howbig(x->datatype); p = pdl_malloc( ny*sizeof(void*) ); /* 1D array of ptrs p[i] */ for (i=0;iimport; use vars qw( %PDL_DATATYPES ); # check for bad value support require './Config.pm'; # to load the PDL not the Perl one die "No PDL::Config found" unless %PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL}; my $usenan = $PDL::Config{BADVAL_USENAN}; require './Types.pm'; PDL::Types->import(':All'); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" if ( $bvalflag ) { print "Extracting $file (WITH bad value support)\n"; } else { print "Extracting $file (NO bad value support)\n"; } open OUT,">$file" or die "Can't create $file: $!"; chmod 0644, $file; print OUT <<"!WITH!SUBS!"; /* pdlcore.c - generated automatically by pdlcore.c.PL */ /* - bad value support = $bvalflag */ !WITH!SUBS! print OUT <<'!HEADER!'; #undef FOODEB #define PDL_CORE /* For certain ifdefs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ /* Needed to get badvals from the Core structure (in pdl_avref_) */ extern Core PDL; /*************** * So many ways to be undefined... */ #define sv_undef(sv) ( (!(sv) || ((sv)==&PL_sv_undef)) || !(SvNIOK(sv) || (SvTYPE(sv)==SVt_PVMG) || SvPOK(sv) || SvROK(sv))) !HEADER! ############################## # Figure out the best definition for the 'finite()' call or call-like macro # We short-circuit the process for the cl compiler; for other compilers we search # for 'isfinite' or 'finite', with a preference for 'isfinite' (IEEE recommends this). if($Config{cc} eq 'cl') { # _finite in VC++ 4.0 print OUT <<'FOO'; #define finite _finite #include FOO } else { my $finite_inc; my $use_isfinite = 0; foreach my $inc ( qw/ math.h ieeefp.h / ) { if ( trylink ("finite: $inc", "#include <$inc>", 'isfinite(3.2);', '' ) ) { $finite_inc = $inc; $use_isfinite = 1; last; } if ( (!defined($finite_inc)) and trylink ("finite: $inc", "#include <$inc>", 'finite(3.2);','') ) { $finite_inc = $inc; } } if ( defined $finite_inc ) { print OUT "#include <$finite_inc>\n"; print OUT "#define finite(a) (isfinite(a))\n"; } else { print OUT <<'!NO!SUBS!'; /* Kludgy finite/isfinite because pdlcore.c.PL was unable to find one in your math library */ #ifndef finite #ifdef isfinite #define finite isfinite #else #define finite(a) (((a) * 0) == (0)) #endif #endif !NO!SUBS! } } ############################## # PDL handling stuff starts here # print OUT <<'!NO!SUBS!' int _anyval_eq_anyval(PDL_Anyval x, PDL_Anyval y) { switch (x.type) { case PDL_B: switch (y.type) { case PDL_B: return (x.value.B == y.value.B) ? 1 : 0; case PDL_S: return ((PDL_Short)(x.value.B) == y.value.S) ? 1 : 0; case PDL_US: return ((PDL_Ushort)(x.value.B) == y.value.U) ? 1 : 0; case PDL_L: return ((PDL_Long)(x.value.B) == y.value.L) ? 1 : 0; case PDL_IND: return ((PDL_Indx)(x.value.B) == y.value.N) ? 1 : 0; case PDL_LL: return ((PDL_LongLong)(x.value.B) == y.value.Q) ? 1 : 0; case PDL_F: return ((PDL_Float)(x.value.B) == y.value.F) ? 1 : 0; case PDL_D: return ((PDL_Double)(x.value.B) == y.value.D) ? 1 : 0; default: return 0; } case PDL_S: switch (y.type) { case PDL_B: return (x.value.S == (PDL_Short)(y.value.B)) ? 1 : 0; case PDL_S: return (x.value.S == y.value.S) ? 1 : 0; case PDL_US: return ((PDL_Long)(x.value.S) == (PDL_Long)(y.value.U)) ? 1 : 0; case PDL_L: return ((PDL_Long)(x.value.S) == y.value.L) ? 1 : 0; case PDL_IND: return ((PDL_Indx)(x.value.S) == y.value.N) ? 1 : 0; case PDL_LL: return ((PDL_LongLong)(x.value.S) == y.value.Q) ? 1 : 0; case PDL_F: return ((PDL_Float)(x.value.S) == y.value.F) ? 1 : 0; case PDL_D: return ((PDL_Double)(x.value.S) == y.value.D) ? 1 : 0; default: return 0; } case PDL_US: switch (y.type) { case PDL_B: return (x.value.U == (PDL_Ushort)(y.value.B)) ? 1 : 0; case PDL_S: return ((PDL_Long)(x.value.U) == (PDL_Long)(y.value.S)) ? 1 : 0; case PDL_US: return (x.value.U == y.value.U) ? 1 : 0; case PDL_L: return ((PDL_Long)(x.value.U) == y.value.L) ? 1 : 0; case PDL_IND: return ((PDL_Indx)(x.value.U) == y.value.N) ? 1 : 0; case PDL_LL: return ((PDL_LongLong)(x.value.U) == y.value.Q) ? 1 : 0; case PDL_F: return ((PDL_Float)(x.value.U) == y.value.F) ? 1 : 0; case PDL_D: return ((PDL_Double)(x.value.U) == y.value.D) ? 1 : 0; default: return 0; } case PDL_L: switch (y.type) { case PDL_B: return (x.value.L == (PDL_Long)(y.value.B)) ? 1 : 0; case PDL_S: return (x.value.L == (PDL_Long)(y.value.S)) ? 1 : 0; case PDL_US: return (x.value.L == (PDL_Long)(y.value.U)) ? 1 : 0; case PDL_L: return (x.value.L == y.value.L) ? 1 : 0; case PDL_IND: return ((PDL_Indx)(x.value.L) == y.value.N) ? 1 : 0; case PDL_LL: return ((PDL_LongLong)(x.value.L) == y.value.Q) ? 1 : 0; case PDL_F: return ((PDL_Float)(x.value.L) == y.value.F) ? 1 : 0; case PDL_D: return ((PDL_Double)(x.value.L) == y.value.D) ? 1 : 0; default: return 0; } case PDL_IND: switch (y.type) { case PDL_B: return (x.value.N == (PDL_Indx)(y.value.B)) ? 1 : 0; case PDL_S: return (x.value.N == (PDL_Indx)(y.value.S)) ? 1 : 0; case PDL_US: return (x.value.N == (PDL_Indx)(y.value.U)) ? 1 : 0; case PDL_L: return (x.value.N == (PDL_Indx)(y.value.L)) ? 1 : 0; case PDL_IND: return (x.value.N == y.value.N) ? 1 : 0; case PDL_LL: return ((PDL_LongLong)(x.value.N) == y.value.Q) ? 1 : 0; case PDL_F: return ((PDL_Float)(x.value.N) == y.value.F) ? 1 : 0; case PDL_D: return ((PDL_Double)(x.value.N) == y.value.D) ? 1 : 0; default: return 0; } case PDL_LL: switch (y.type) { case PDL_B: return (x.value.Q == (PDL_LongLong)(y.value.B)) ? 1 : 0; case PDL_S: return (x.value.Q == (PDL_LongLong)(y.value.S)) ? 1 : 0; case PDL_US: return (x.value.Q == (PDL_LongLong)(y.value.U)) ? 1 : 0; case PDL_L: return (x.value.Q == (PDL_LongLong)(y.value.L)) ? 1 : 0; case PDL_IND: return (x.value.Q == (PDL_LongLong)(y.value.N)) ? 1 : 0; case PDL_LL: return (x.value.Q == y.value.Q) ? 1 : 0; case PDL_F: return ((PDL_Float)(x.value.Q) == y.value.F) ? 1 : 0; case PDL_D: return ((PDL_Double)(x.value.Q) == y.value.D) ? 1 : 0; default: return 0; } case PDL_F: switch (y.type) { case PDL_B: return (x.value.F == (PDL_Float)(y.value.B)) ? 1 : 0; case PDL_S: return (x.value.F == (PDL_Float)(y.value.S)) ? 1 : 0; case PDL_US: return (x.value.F == (PDL_Float)(y.value.U)) ? 1 : 0; case PDL_L: return (x.value.F == (PDL_Float)(y.value.L)) ? 1 : 0; case PDL_IND: return (x.value.F == (PDL_Float)(y.value.N)) ? 1 : 0; case PDL_LL: return (x.value.F == (PDL_Float)(y.value.Q)) ? 1 : 0; case PDL_F: return (x.value.F == y.value.F) ? 1 : 0; case PDL_D: return ((PDL_Double)(x.value.F) == y.value.D) ? 1 : 0; default: return 0; } case PDL_D: switch (y.type) { case PDL_B: return (x.value.D == (PDL_Double)(y.value.B)) ? 1 : 0; case PDL_S: return (x.value.D == (PDL_Double)(y.value.S)) ? 1 : 0; case PDL_US: return (x.value.D == (PDL_Double)(y.value.U)) ? 1 : 0; case PDL_L: return (x.value.D == (PDL_Double)(y.value.L)) ? 1 : 0; case PDL_IND: return (x.value.D == (PDL_Double)(y.value.N)) ? 1 : 0; case PDL_LL: return (x.value.D == (PDL_Double)(y.value.Q)) ? 1 : 0; case PDL_F: return (x.value.D == (PDL_Double)(y.value.F)) ? 1 : 0; case PDL_D: return (x.value.D == y.value.D) ? 1 : 0; default: return 0; } default: return 0; } } static SV *getref_pdl(pdl *it) { SV *newref; if(!it->sv) { SV *ref; HV *stash = gv_stashpv("PDL",TRUE); SV *psv = newSViv(PTR2IV(it)); it->sv = psv; newref = newRV_noinc(it->sv); (void)sv_bless(newref,stash); } else { newref = newRV_inc(it->sv); SvAMAGIC_on(newref); } return newref; } void SetSV_PDL ( SV *sv, pdl *it ) { SV *newref = getref_pdl(it); /* YUCK!!!! */ sv_setsv(sv,newref); SvREFCNT_dec(newref); } /* Size of data type information */ int pdl_howbig (int datatype) { switch (datatype) { !NO!SUBS! ; # generate the cases for the various types for my $type (typesrtkeys()) { my ($sym,$ctype) = map {typefld($type,$_)} qw/sym ctype/; print OUT << "!WITH!SUBS!"; case $sym: return sizeof($ctype); !WITH!SUBS! } print OUT <<'!NO!SUBS!'; default: croak("Unknown datatype code = %d",datatype); } } /* Check minimum datatype required to represent number */ /* Microsoft compilers do some unbelievable things - hence some #ifdef's inserted by Sisyphus */ #if defined _MSC_VER && _MSC_VER < 1400 #define TESTTYPE(b,a) {a foo = nv; a bar = foo; foo += 0; if(nv == bar) return b;} #else #define TESTTYPE(b,a) {a foo = nv; if(nv == foo) return b;} #endif #if defined _MSC_VER && _MSC_VER < 1400 #pragma optimize("", off) #endif int pdl_whichdatatype (IV nv) { !NO!SUBS! # generate the cases for the various types for my $type (typesrtkeys()) { my ($sym,$ctype) = map {typefld($type,$_)} qw/sym ctype/; print OUT << "!WITH!SUBS!"; TESTTYPE($sym,$ctype) !WITH!SUBS! } print OUT <<'!NO!SUBS!'; croak("Something's gone wrong: %ld cannot be converted by whichdatatype", nv); } /* Check minimum, at least float, datatype required to represent number */ int pdl_whichdatatype_double (NV nv) { TESTTYPE(PDL_F,PDL_Float) TESTTYPE(PDL_D,PDL_Double) /* Default return type PDL_Double */ return PDL_D; } #if defined _MSC_VER && _MSC_VER < 1400 #pragma optimize("", on) #endif /* Make a scratch dataspace for a scalar pdl */ void pdl_makescratchhash(pdl *ret, PDL_Anyval data) { STRLEN n_a; HV *hash; SV *dat; PDL_Indx fake[1]; /* Compress to smallest available type. */ ret->datatype = data.type; /* Create a string SV of apropriate size. The string is arbitrary * and just has to be larger than the largest datatype. */ dat = newSVpvn(" ",pdl_howbig(ret->datatype)); ret->data = SvPV(dat,n_a); ret->datasv = dat; /* Refcnt should be 1 already... */ /* Make the whole pdl mortal so destruction happens at the right time. * If there are dangling references, pdlapi.c knows not to actually * destroy the C struct. */ sv_2mortal(getref_pdl(ret)); pdl_setdims(ret, fake, 0); /* 0 dims in a scalar */ ret->nvals = 1; /* 1 val in a scalar */ /* NULLs should be ok because no dimensions. */ pdl_set(ret->data, ret->datatype, NULL, NULL, NULL, 0, 0, data); } /* "Convert" a perl SV into a pdl (alright more like a mapping as the data block is not actually copied in the most common case of a single scalar) scalars are automatically converted to PDLs. */ pdl* SvPDLV ( SV* sv ) { pdl* ret; PDL_Indx fake[1]; SV *sv2; if ( !SvROK(sv) ) { /* The scalar is not a ref, so we can use direct conversion. */ SV *dat; PDL_Anyval data; int datatype; NV tmp_NV; IV tmp_IV; ret = pdl_new(); /* Scratch pdl */ /* Scratch hash for the pdl :( - slow but safest. */ /* handle undefined values */ if( sv_undef(sv) ) { sv = get_sv("PDL::undefval",1); if(SvIV(get_sv("PDL::debug",1))){ fprintf(stderr,"Warning: SvPDLV converted undef to $PDL::undefval (%g).\n",SvNV(sv)); } } /* Figure datatype to use */ if ( !SvIOK(sv) ) { /* Perl Double (e.g. 2.0) */ tmp_NV = SvNV(sv); !NO!SUBS! ########## # If badvals and usenan are true, we default NaNs to type double. if ( $bvalflag and $usenan ) { print OUT q{ /* * default NaN/Infs to double * */ if ( finite(tmp_NV) == 0 ) { datatype = PDL_D; } else { datatype = pdl_whichdatatype_double(tmp_NV); } } } else { print OUT q{ datatype = pdl_whichdatatype_double(tmp_NV); } } # if: $bvalflag print OUT <<'!NO!SUBS!'; ANYVAL_FROM_CTYPE(data, datatype, tmp_NV); } /* end of Perl Double case for data type */ else { /* Perl Int (e.g. 2) */ tmp_IV = SvIV(sv); datatype = pdl_whichdatatype(tmp_IV); ANYVAL_FROM_CTYPE(data, datatype, tmp_IV); } pdl_makescratchhash(ret, data); return ret; } /* End of scalar case */ /* If execution reaches here, then sv is NOT a scalar * (i.e. it is a ref). */ if(SvTYPE(SvRV(sv)) == SVt_PVHV) { HV *hash = (HV*)SvRV(sv); SV **svp = hv_fetch(hash,"PDL",3,0); if(svp == NULL) { croak("Hash given as a pdl - but not {PDL} key!"); } if(*svp == NULL) { croak("Hash given as a pdl - but not {PDL} key (*svp)!"); } /* This is the magic hook which checks to see if {PDL} is a code ref, and if so executes it. It should return a standard piddle. This allows all kinds of funky objects to be derived from PDL, and allow normal PDL functions to still work so long as the {PDL} code returns a standard piddle on demand - KGB */ if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) { dSP; int count; ENTER ; SAVETMPS ; PUSHMARK(sp) ; count = perl_call_sv(*svp, G_SCALAR|G_NOARGS); SPAGAIN ; if (count != 1) croak("Execution of PDL structure failed to return one value\n") ; sv=newSVsv(POPs); PUTBACK ; FREETMPS ; LEAVE ; } else { sv = *svp; } if(SvGMAGICAL(sv)) { mg_get(sv); } if ( !SvROK(sv) ) { /* Got something from a hash but not a ref */ croak("Hash given as pdl - but PDL key is not a ref!"); } } if(SvTYPE(SvRV(sv)) == SVt_PVAV) { /* This is similar to pdl_avref in Core.xs.PL -- we do the same steps here. */ AV *dims, *av; int i, depth; int datalevel = -1; pdl *p; av = (AV *)SvRV(sv); dims = (AV *)sv_2mortal((SV *)newAV()); av_store(dims,0,newSViv( (IV) av_len(av)+1 ) ); /* Pull sizes using av_ndcheck */ depth = 1 + av_ndcheck(av,dims,0,&datalevel); return pdl_from_array(av, dims, -1, NULL); /* -1 means pdltype autodetection */ } /* end of AV code */ if (SvTYPE(SvRV(sv)) != SVt_PVMG) croak("Error - tried to use an unknown data structure as a PDL"); else if( !( sv_derived_from( sv, "PDL") ) ) croak("Error - tried to use an unknown Perl object type as a PDL"); sv2 = (SV*) SvRV(sv); /* Return the pdl * pointer */ ret = INT2PTR(pdl *, SvIV(sv2)); /* Final check -- make sure it has the right magic number */ if(ret->magicno != PDL_MAGICNO) { croak("Fatal error: argument is probably not a piddle, or\ magic no overwritten. You're in trouble, guv: %p %p %lu\n",sv2,ret,ret->magicno); } return ret; } /* Make a new pdl object as a copy of an old one and return - implement by callback to perl method "copy" or "new" (for scalar upgrade) */ SV* pdl_copy( pdl* a, char* option ) { SV* retval; char meth[20]; dSP ; int count ; retval = newSVpv("",0); /* Create the new SV */ ENTER ; SAVETMPS ; PUSHMARK(sp) ; /* Push arguments */ #ifdef FOOBAR if (sv_isobject((SV*)a->hash)) { #endif XPUSHs(sv_2mortal(getref_pdl(a))); strcpy(meth,"copy"); XPUSHs(sv_2mortal(newSVpv(option, 0))) ; #ifdef FOOBAR } else{ XPUSHs(perl_get_sv("PDL::name",FALSE)); /* Default object */ XPUSHs(sv_2mortal(getref_pdl(a))); strcpy(meth,"new"); } #endif PUTBACK ; count = perl_call_method(meth, G_SCALAR); /* Call Perl */ SPAGAIN; if (count !=1) croak("Error calling perl function\n"); sv_setsv( retval, POPs ); /* Save the perl returned value */ PUTBACK ; FREETMPS ; LEAVE ; return retval; } /* Pack dims array - returns dims[] (pdl_malloced) and ndims */ PDL_Indx* pdl_packdims ( SV* sv, int *ndims ) { SV* bar; AV* array; int i; PDL_Indx *dims; if (!(SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)) /* Test */ return NULL; array = (AV *) SvRV(sv); /* dereference */ *ndims = (int) av_len(array) + 1; /* Number of dimensions */ dims = (PDL_Indx *) pdl_malloc( (*ndims) * sizeof(*dims) ); /* Array space */ if (dims == NULL) croak("Out of memory"); for(i=0; i<(*ndims); i++) { bar = *(av_fetch( array, i, 0 )); /* Fetch */ dims[i] = (PDL_Indx) SvIV(bar); } return dims; } /* unpack dims array into PDL SV* */ void pdl_unpackdims ( SV* sv, PDL_Indx *dims, int ndims ) { AV* array; HV* hash; int i; hash = (HV*) SvRV( sv ); array = newAV(); (void)hv_store(hash, "Dims", strlen("Dims"), newRV( (SV*) array), 0 ); if (ndims==0 ) return; for(i=0; i= 0 && at < dsz) return at; pdl_barf("access [%d] out of range [0..%d] (inclusive) at %s line %d", at, dsz-1, file?file:"?", lineno); return at; // This can never happen - placed to avoid a compiler warning. } /* pdl_malloc - utility to get temporary memory space. Uses a mortal *SV for this so it is automatically freed when the current context is terminated without having to call free(). Naughty but nice! */ void* pdl_malloc ( STRLEN nbytes ) { STRLEN n_a; SV* work; work = sv_2mortal(newSVpv("", 0)); SvGROW( work, nbytes); return (void *) SvPV(work, n_a); } /*********** Stuff for barfing *************/ /* This routine barfs/warns in a thread-safe manner. If we're in the main thread, this calls the perl-level barf/warn. If in a worker thread, we save the message to barf/warn in the main thread later */ static void pdl_barf_or_warn(const char* pat, int iswarn, va_list* args) { /* If we're in a worker thread, we queue the * barf/warn for later, and exit the thread ... */ if( pdl_pthread_barf_or_warn(pat, iswarn, args) ) return; /* ... otherwise we fall through and barf by calling * the perl-level PDL::barf() or PDL::cluck() */ { /* scope block for C89 compatibility */ SV * sv; dSP; ENTER; SAVETMPS; PUSHMARK(SP); sv = sv_2mortal(newSV(0)); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); va_end(*args); XPUSHs(sv); PUTBACK; if(iswarn) call_pv("PDL::cluck", G_DISCARD); else call_pv("PDL::barf", G_DISCARD); FREETMPS; LEAVE; } /* end C89 compatibility scope block */ } #define GEN_PDL_BARF_OR_WARN_I_STDARG(type, iswarn) \ void pdl_##type(const char* pat, ...) \ { \ va_list args; \ va_start(args, pat); \ pdl_barf_or_warn(pat, iswarn, &args); \ } #define GEN_PDL_BARF_OR_WARN_LEGACY(type, iswarn) \ void pdl_##type(pat, va_alist) \ char *pat; \ va_dcl \ { \ va_list args; \ va_start(args); \ pdl_barf_or_warn(pat, iswarn, &args); \ } #ifdef I_STDARG GEN_PDL_BARF_OR_WARN_I_STDARG(barf, 0) GEN_PDL_BARF_OR_WARN_I_STDARG(warn, 1) #else GEN_PDL_BARF_OR_WARN_LEGACY(barf, 0) GEN_PDL_BARF_OR_WARN_LEGACY(warn, 1) #endif /********************************************************************** * * CONSTRUCTOR/INGESTION HELPERS * * The following routines assist with the permissive constructor, * which is designed to build a PDL out of basically anything thrown at it. * * They are all called by pdl_avref in Core.xs, which in turn is called by the constructors * in Core.pm.PL. The main entry point is pdl_from_array(), which calls * av_ndcheck() to identify the necessary size of the output PDL, and then dispatches * the copy into pdl_setav_ according to the type of the output PDL. * */ /****************************** * av_ndcheck - * traverse a Perl array ref recursively, following down any number of * levels of references, and generate a minimal PDL dim list that can * encompass them all according to permissive-constructor rules. * * Scalars, array refs, and PDLs may be mixed in the incoming AV. * * The routine works out the dimensions of a corresponding * piddle (in the AV dims) in reverse notation (vs PDL conventions). * * It does not enforce a rectangular array on the input, the idea being that * omitted values will be set to zero or the undefval in the resulting piddle, * i.e. we can make piddles from 'sparse' array refs. * * Empty PDLs are treated like any other dimension -- i.e. their * 0-length dimensions are thrown into the mix just like nonzero * dimensions would be. * * The possible presence of empty PDLs forces us to pad out dimensions * to unity explicitly in cases like * [ Empty[2x0x2], 5 ] * where simple parsing would yield a dimlist of * [ 2,0,2,2 ] * which is still Empty. */ PDL_Indx av_ndcheck(AV* av, AV* dims, int level, int *datalevel) { PDL_Indx i, len, oldlen; int newdepth, depth = 0; int n_scalars = 0; SV *el, **elp; pdl *dest_pdl; /* Stores PDL argument */ if(dims==NULL) { pdl_barf("av_ndcheck - got a null dim array! This is a bug in PDL."); } /* Start with a clean slate */ if(level==0) { av_clear(dims); } len = av_len(av); /* Loop over elements of the AV */ for (i=0; i<= len; i++) { newdepth = 0; /* Each element - find depth */ elp = av_fetch(av,i,0); el = elp ? *elp : 0; /* Get the ith element */ if (el && SvROK(el)) { /* It is a reference */ if (SvTYPE(SvRV(el)) == SVt_PVAV) { /* It is an array reference */ /* Recurse to find depth inside the array reference */ newdepth = 1 + av_ndcheck((AV *) SvRV(el), dims, level+1, datalevel); } else if ( (dest_pdl = SvPDLV(el)) ) { /* It is a PDL - walk down its dimension list, exactly as if it * were a bunch of nested array refs. We pull the ndims and dims * fields out to local variables so that nulls can be treated specially. */ int j; short pndims; PDL_Indx *pdims; PDL_Indx pnvals; pdl_make_physdims(dest_pdl); pndims = dest_pdl->ndims; pdims = dest_pdl->dims; pnvals = dest_pdl->nvals; for(j=0;j= jl && av_fetch(dims,jl,0) != NULL && SvIOK(*(av_fetch(dims,jl,0)))) { /* We have already found something that specifies this dimension -- so */ /* we keep the size if possible, or enlarge if necessary. */ oldlen=(PDL_Indx)SvIV(*(av_fetch(dims,jl,0))); if(siz > oldlen) { sv_setiv(*(av_fetch(dims,jl,0)),(IV)(pdims[j])); } } else { /* Breaking new dimensional ground here -- if this is the first element */ /* in the arg list, then we can keep zero elements -- but if it is not */ /* the first element, we have to pad zero dims to unity (because the */ /* prior object had implicit size of 1 in all implicit dimensions) */ av_store(dims, jl, newSViv((IV)(siz?siz:(i?1:0)))); } } /* We have specified all the dims in this PDL. Now pad out the implicit */ /* dims of size unity, to wipe out any dims of size zero we have already */ /* marked. */ for(j=pndims+1; j <= av_len(dims); j++) { SV **svp = av_fetch(dims,j,0); if(!svp){ av_store(dims, j, newSViv((IV)1)); } else if( (int)SvIV(*svp) == 0 ) { sv_setiv(*svp, (IV)1); } } newdepth= pndims; } else { croak("av_ndcheck: non-array, non-PDL ref in structure\n\t(this is usually a problem with a pdl() call)"); } } else { /* got a scalar (not a ref) */ n_scalars++; } if (newdepth > depth) depth = newdepth; } len++; // convert from funky av_len return value to real count if (av_len(dims) >= level && av_fetch(dims, level, 0) != NULL && SvIOK(*(av_fetch(dims, level, 0)))) { oldlen = (PDL_Indx) SvIV(*(av_fetch(dims, level, 0))); if (len > oldlen) sv_setiv(*(av_fetch(dims, level, 0)), (IV) len); } else av_store(dims,level,newSViv((IV) len)); /* We found at least one element -- so pad dims to unity at levels earlier than this one */ if(n_scalars) { for(i=0;i, below, based on the * type of the destination PDL. */ pdl* pdl_from_array(AV* av, AV* dims, int type, pdl* p) { int ndims, i, level=0; PDL_Indx *pdims; PDL_Anyval undefval = { -1, 0 }; ndims = av_len(dims)+1; pdims = (PDL_Indx *) pdl_malloc( (ndims) * sizeof(*pdims) ); for (i=0; idatatype = type; pdl_allocdata (p); pdl_make_physical(p); { /****** * Copy the undefval to fill empty spots in the piddle... */ SV *sv = get_sv("PDL::undefval",0); if ((!sv) || (sv==&PL_sv_undef)) { ANYVAL_FROM_CTYPE(undefval, type, 0); } else { /* Need to set undefvalue from the perl scalar */ if (SvIOK(sv)) { ANYVAL_FROM_CTYPE(undefval, type, SvIV(sv)); } else if (SvNOK(sv)) { ANYVAL_FROM_CTYPE(undefval, type, SvNV(sv)); } else { ANYVAL_FROM_CTYPE(undefval, type, 0); /* this should not happen */ } } } switch (type) { !NO!SUBS! ########## # Perl snippet autogenerates switch statement to distribute # pdl_setav calls... # for my $type(typesrtkeys()){ my $t2 = $PDL_DATATYPES{$type}; $t2 =~ s/PDL_//; print OUT <<"!WITH!SUBS!"; case $type: pdl_setav_$t2(p->data,av,pdims,ndims,level, undefval.value.$PDL::Types::typehash{$type}->{ppsym}, p); break; !WITH!SUBS! } # # Back to your regularly scheduled C code emission... ######## print OUT <<'!NO!SUBS!'; default: croak("pdl_from_array: internal error: got type %d",type); break; } p->state &= ~PDL_NOMYDIMS; return p; } /* * pdl_kludge_copy_ - copy a PDL into a part of a being-formed PDL. * It is only used by pdl_setav_, to handle the case where a PDL is part * of the argument list. * * kludge_copy recursively walks down the dim list of both the source and dest * pdls, copying values in as we go. It differs from PP copy in that it operates * on only a portion of the output pdl. * * (If I were Lazier I would have popped up into the perl level and used threadloops to * assign to a slice of the output pdl -- but this is probably a little faster.) * * -CED 17-Jun-2004 * * Arguments: * poff is an integer indicating which element along the current direction is being treated (for padding accounting) * pdata is a pointer into the destination PDL's data; * pdims is a pointer to the destination PDL's dim list; * ndims is the size of the destination PDL's dimlist; * level is the conjugate dimension along which copying is happening (indexes pdims). * "conjugate" means that it counts backward through the dimension array. * stride is the increment in the data array corresponding to this dimension; * * pdl is the input PDL. * plevel is the dim number for the input PDL, which works in the same sense as level. * It is offset to account for the difference in dimensionality between the input and * output PDLs. It is allowed to be negative (which is equivalent to the "permissive * slicing" that treats missing dimensions as present and having size 1), but should * not match or exceed pdl->ndims. * pptr is the current offset data pointer into pdl->data. * * Kludge-copy works backward through the dim lists, so that padding is simpler: if undefval * padding is required at any particular dimension level, the padding occupies a contiguous * block of memory. */ !NO!SUBS! for my $in ( typesrtkeys() ) { (my $type = $PDL_DATATYPES{$in}) =~ s/^PDL_//; print OUT <<"!WITH!SUBS!"; PDL_Indx pdl_kludge_copy_$type(PDL_Indx poff, // Offset into the dest data array PDL_$type* pdata, // Data pointer in the dest data array PDL_Indx* pdims, // Pointer to the dimlist for the dest pdl PDL_Indx ndims, // Number of dimensions in the dest pdl int level, // Recursion level PDL_Indx stride, // Stride through memory for the current dim pdl* source_pdl, // pointer to the source pdl int plevel, // level within the source pdl void* pptr, // Data pointer in the source pdl PDL_$type undefval, // undefval for the dest pdl pdl* p // pointer to the dest pdl ) { PDL_Indx i; PDL_Indx undef_count = 0; /* Can't copy into a level deeper than the number of dims in the output PDL */ if(level > ndims ) { fprintf(stderr,"pdl_kludge_copy: level=%d; ndims=%"IND_FLAG"\\n",level,ndims); croak("Internal error - please submit a bug report at http://sourceforge.net/projects/pdl/:\\n pdl_kludge_copy: Assertion failed; ndims-1-level (%"IND_FLAG") < 0!.",ndims-1-level); } if(level >= ndims - 1) { /* We are in as far as we can go in the destination PDL, so direct copying is in order. */ int pdldim = source_pdl->ndims - 1 - plevel; // which dim are we working in the source PDL? PDL_Indx pdlsiz; int oob = (ndims-1-level < 0); // out-of-bounds flag /* Do bounds checking on the source dimension -- if we wander off the end of the * dimlist, we are doing permissive-slicing kind of stuff (not enough dims in the * source to fully account for the output dimlist); if we wander off the beginning, we * are doing dimensional padding. In either case, we just iterate once. */ if(pdldim < 0 || pdldim >= source_pdl->ndims) { pdldim = (pdldim < 0) ? (0) : (source_pdl->ndims - 1); pdlsiz = 1; } else { pdlsiz = source_pdl->dims[pdldim]; } #if BADVAL /* This is used inside the switch in order to detect badvalues. */ PDL_Anyval source_badval = PDL.get_pdl_badvalue(source_pdl); #endif /* BADVAL */ /* This is the actual data-copying code. It is generated with a Perl loop, to * ensure that all current PDL types get treated. */ switch(source_pdl->datatype) { !WITH!SUBS! # perl loop to emit code for all the PDL types -- ctype gets the C type of # the source PDL, switch_type gets the Perl name, ppsym gets # the symbol need to retrieve from a PDL_Anyval, and type_usenan is a # boolean indicating whether this type handles NaNs. foreach my $switch_type ( typesrtkeys() ) { my $ctype = $PDL::Types::typehash{$switch_type}{ctype}; my $stype = $PDL::Types::typehash{$switch_type}{ctype}; $stype =~ s/PDL_//; my $ppsym = $PDL::Types::typehash{$switch_type}{ppsym}; my $type_usenan = $PDL::Types::typehash{$switch_type}{usenan}; my $comp_for_nan = $type_usenan # if not equal, check if both are NaN ? "( !finite( (($ctype *)pptr)[i] ) && !finite(source_badval.value.$ppsym) )" # otherwise it must be false : '0'; print OUT <<"!WITH!SUBS!"; case ${switch_type}: /* copy data (unless the source pointer is null) */ i=0; if(pptr && pdata && pdlsiz) { for(; ihas_badvalue || (source_pdl->state & PDL_BADVAL)) { /* Retrieve directly from .value.* instead of using ANYVAL_EQ_ANYVAL */ if( (($ctype *)pptr)[i] == source_badval.value.$ppsym || $comp_for_nan ) { /* bad value in source PDL -- use our own type's bad value instead */ pdata[i] = PDL.bvals.$type; p->state |= PDL_BADVAL; } else { pdata[i] = (PDL_$type) ((${ctype} *)pptr)[i]; } } else { pdata[i] = (PDL_$type) ((${ctype} *)pptr)[i]; } #else pdata[i] = (PDL_$type) ((${ctype} *)pptr)[i]; #endif } // end of loop over pdlsiz } else { // pptr or pdata or pdlsiz are 0 if(pdata) pdata[i] = undefval; } /* pad out, in the innermost dimension */ if( !oob ) { for(; i< pdims[0]-poff; i++) { undef_count++; pdata[i] = undefval; } } break; !WITH!SUBS! } # end of foreach in the perl generator code print OUT <<"!WITH!SUBS!"; default: croak("Internal error - please submit a bug report at http://sourceforge.net/projects/pdl/:\\n pdl_kludge_copy: unknown datatype of %d.",(int)(source_pdl->datatype)); break; } return undef_count; } /* If we are here, we are not at the bottom level yet. So walk * across this dim and handle copying one dim deeper via recursion. * The loop is placed in a convenience block so we can define the * dimensional boundscheck flag -- that avoids having to evaluate the complex * ternary expression for every loop iteration. */ { PDL_Indx limit = ( (plevel >= 0 && (source_pdl->ndims - 1 - plevel >= 0) ) ? (source_pdl->dims[ source_pdl->ndims-1-plevel ]) : 1 ); for(i=0; i < limit ; i++) { undef_count += pdl_kludge_copy_$type(0, pdata + stride * i, pdims, ndims, level+1, stride / ((pdims[ndims-2-level]) ? (pdims[ndims-2-level]) : 1), source_pdl, plevel+1, ((PDL_Byte *) pptr) + source_pdl->dimincs[source_pdl->ndims-1-plevel] * i * pdl_howbig(source_pdl->datatype), undefval, p ); } /* end of kludge_copy recursion loop */ } /* end of recursion convenience block */ /* pad the rest of this dim to zero if there are not enough elements in the source PDL... */ if(i < pdims[ndims - 1 - level]) { int cursor, target; cursor = i * stride; target = pdims[ndims-1-level]*stride; undef_count += target - cursor; for(; cursor < target; cursor++) { pdata[cursor] = undefval; } } /* end of padding IF statement */ return undef_count; } /* * pdl_setav_ loads a new PDL with values from a Perl AV, another PDL, or * a mix of both. Heterogeneous sizes are handled by padding the new PDL's * values out to size with the undefval. It is only called by pdl_setav in Core.XS, * via the trampoline pdl_from_array just above. pdl_from_array dispatches execution * to pdl_setav_ according to the type of the destination PDL. * * The code is complicated by the "bag-of-stuff" nature of AVs. We handle * Perl scalars, AVs, *and* PDLs (via pdl_kludge_copy). * * - pdata is the data pointer from a PDL * - av is the array ref (or PDL) to use to fill the data with, * - pdims is the dimlist * - ndims is the size of the dimlist * - level is the recursion level, which is also the dimension that we are filling */ PDL_Indx pdl_setav_$type(PDL_$type* pdata, AV* av, PDL_Indx* pdims, int ndims, int level, PDL_$type undefval, pdl *p) { PDL_Indx cursz = pdims[ndims-1-level]; /* we go from the highest dim inward */ PDL_Indx len = av_len(av); PDL_Indx i,stride=1; SV *el, **elp; PDL_Indx undef_count = 0; for (i=0;i= 0 && pddex < ndims ? pdims[ pddex ] : 0); if(!pd) pd = 1; undef_count += pdl_kludge_copy_$type(0, pdata,pdims,ndims, level+1, stride / pd , pdl, 0, pdl->data,undefval, p); } else { /* The element is a non-PDL, non-AV ref. Not allowed. */ croak("Non-array, non-PDL element in list"); } } else { /* el==0 || SvROK(el)==0: this is a scalar or undef element */ if( sv_undef(el) ) { /* undef case */ *pdata = (PDL_$type) undefval; undef_count++; } else { /* scalar case */ if (SvIOK(el)) { *pdata = (PDL_$type) SvIV(el); } else { *pdata = (PDL_$type) SvNV(el); } } /* Pad dim if we are not deep enough */ if(level < ndims-1) { PDL_$type *cursor = pdata; PDL_$type *target = pdata + stride; for( cursor++; cursor < target; cursor++ ) { *cursor = (PDL_$type)undefval; undef_count++; } } } } /* end of element loop through the supplied AV */ /* in case this dim is incomplete set any remaining elements to the undefval */ if(len < cursz-1 ) { PDL_$type *target = pdata + stride * (cursz - 1 - len); for( ; pdata < target; pdata++ ) { *pdata = (PDL_$type) undefval; undef_count++; } } /* If the Perl scalar PDL::debug is set, announce padding */ if(level==0 && undef_count) { char debug_flag; SV *sv; sv = get_sv("PDL::debug",0); debug_flag = (sv_undef(sv)) ? 0 : (char)SvIV(sv); if(debug_flag) { fflush(stdout); fprintf(stderr,"Warning: pdl_setav_$type converted undef to $PDL::undefval (%g) %ld time%s\\n",(double)undefval,undef_count,undef_count==1?"":"s"); fflush(stderr); } } return undef_count; } !WITH!SUBS! } # end type loop PDL-2.018/Basic/Core/pdlcore.h.PL0000644060175006010010000003446013101130663014421 0ustar chmNone# -*-perl-*- ############################## # # Be sure to increment $pdl_core_version (about 20 lines below this note) # if you change any prototypes or modify the Core structure! # ############################## use strict; use Config; use File::Basename qw(&basename &dirname); require './Dev.pm'; PDL::Core::Dev->import; use vars qw( %PDL_DATATYPES ); # version 2 is for versions after PDL 2.1.1 # version 4 has pdl_hard_copy included in the Core structure. # version 6 is introduced after 2.4.2, due to the experimental # per-piddle bad values code (the BADVAL_PER_PDL option) # version 7 introduced for some changes to function prototypes # for pthreading (i.e. multi-threading) capabilities # version 8 for beginning support for >2GiB piddles # version 9 for STRLEN/Size_t/Off_t for mmap delete magic # version 10 for 64bit index support (PDL index datatype) # version 11 for core cleanup (proto-PDL-3) # version 12 for PDL_Anyval union data type (full 64bit support) use vars qw( $pdl_core_version ); $pdl_core_version = 12; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" print "Extracting $file\n"; open OUT,">$file" or die "Can't create $file: $!"; chmod 0644, $file; # In this section, perl variables will be expanded during extraction. # You can use $Config{...} to use Configure variables. print OUT <<'!NO!SUBS!'; /* * THIS FILE IS GENERATED FROM pdlcore.h.PL! Do NOT edit! */ #ifndef __PDLCORE_H #define __PDLCORE_H #include "EXTERN.h" /* std perl include */ #include "perl.h" /* std perl include */ #include "XSUB.h" /* for the win32 perlCAPI crap */ #include "ppport.h" /* include this AFTER XSUB.h */ #if defined(CONTEXT) && defined(__osf__) #undef CONTEXT #endif #include "pdl.h" #include "pdlthread.h" /* the next one causes trouble in c++ compiles - exclude for now */ #ifndef __cplusplus #include "pdlmagic.h" #endif !NO!SUBS! print OUT "#define PDL_CORE_VERSION $pdl_core_version\n"; print OUT <<'!NO!SUBS!' if ($^O =~ /MSWin/); #define finite _finite #include !NO!SUBS! print OUT <<'!NO!SUBS!'; #define PDL_TMP 0 /* Flags */ #define PDL_PERM 1 #define BIGGESTOF(a,b) ( a->nvals>b->nvals ? a->nvals : b->nvals ) #define SVavref(x) (SvROK(x) && SvTYPE(SvRV(x))==SVt_PVAV) /* Create portable NaN's with the NaN_float and NaN_double macros. * The end values are 7f to turn off sign bit to avoid printing "-NaN". * This produces QNaN's or quiet nan's on architectures that support it. * * The below uses IEEE-754, so it should be portable. Also note the symmetry * which makes the bigendian vs little-endian issue moot. If platforms should * arise which require further consideration, use the pdl function, * PDL::Core::Dev::isbigendian() which returns a boolean value (a false value * garantees little-endian), and #ifdef's for exotic architectures. You'll be * hard pressed to find an architecture that doesn't support ieee-754 but does * support NaN. See http://en.wikipedia.org/wiki/NaN to understand why * this works. */ static const union {unsigned char c[4]; float f;} union_nan_float = {{0x7f, 0xff, 0xff, 0x7f}}; static const union {unsigned char c[8]; double d;} union_nan_double = {{0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f}}; /* Use our own barf and our own warn. * We defer barf (and warn) handling until after multi-threaded (i.e pthreading) * processing is finished. * This is needed because segfaults happen when perl's croak is called * during one of the spawned pthreads for PDL processing. */ #define barf PDL->pdl_barf #undef warn #define warn PDL->pdl_warn typedef int Logical; /*************** Function prototypes *********************/ /* pdlcore.c */ int pdl_howbig (int datatype); /* Size of data type (bytes) */ pdl* SvPDLV ( SV* sv ); /* Map SV* to pdl struct */ void SetSV_PDL( SV *sv, pdl *it ); /* Outputting a pdl from.. */ SV* pdl_copy( pdl* a, char* option ); /* call copy method */ PDL_Indx * pdl_packdims ( SV* sv, int*ndims ); /* Pack dims[] into SV aref */ void pdl_unpackdims ( SV* sv, PDL_Indx *dims, /* Unpack */ int ndims ); void* pdl_malloc ( STRLEN nbytes ); /* malloc memory - auto free()*/ void pdl_makescratchhash(pdl *ret, PDL_Anyval data); PDL_Indx pdl_safe_indterm(PDL_Indx dsz, PDL_Indx at, char *file, int lineno); void pdl_barf(const char* pat,...); /* General croaking utility */ void pdl_warn(const char* pat,...); /* General warn utility */ PDL_Indx av_ndcheck(AV* av, AV* dims, int level, int *datalevel); pdl* pdl_from_array(AV* av, AV* dims, int type, pdl* p); !NO!SUBS! for my $in ( PDL::Types::typesrtkeys() ) { (my $type = $PDL_DATATYPES{$in}) =~ s/^PDL_//; print OUT <<"!WITH!SUBS!"; PDL_Indx pdl_setav_$type(PDL_$type* pdata, AV* av, PDL_Indx* pdims, PDL_Long ndims, int level, PDL_$type undefval, pdl *p); !WITH!SUBS! } print OUT <<'!NO!SUBS!'; /* pdlapi.c */ void pdl_vaffinechanged(pdl *it, int what); void pdl_trans_mallocfreeproc(struct pdl_trans *tr); void pdl_make_trans_mutual(pdl_trans *trans); void pdl_destroytransform_nonmutual(pdl_trans *trans,int ensure); void pdl_vafftrans_free(pdl *it); void pdl_vafftrans_remove(pdl * it); void pdl_make_physvaffine(pdl *it); void pdl_vafftrans_alloc(pdl *it); pdl *pdl_null(); pdl *pdl_get_convertedpdl(pdl *pdl,int type); void pdl_destroytransform(pdl_trans *trans,int ensure); pdl *pdl_hard_copy(pdl *src); #define pdl_new() pdl_create(PDL_PERM) #define pdl_tmp() pdl_create(PDL_TMP) pdl* pdl_external_new(); pdl* pdl_external_tmp(); pdl* pdl_create(int type); void pdl_destroy(pdl *it); void pdl_setdims(pdl* it, PDL_Indx* dims, int ndims); void pdl_reallocdims ( pdl *it,int ndims ); /* reallocate dims and incs */ void pdl_reallocthreadids ( pdl *it,int ndims ); /* reallocate threadids */ void pdl_resize_defaultincs ( pdl *it ); /* Make incs out of dims */ void pdl_unpackarray ( HV* hash, char *key, PDL_Indx *dims, int ndims ); void pdl_print(pdl *it); void pdl_dump(pdl *it); void pdl_allocdata(pdl *it); PDL_Indx *pdl_get_threadoffsp(pdl_thread *thread); /* For pthreading */ void pdl_thread_copy(pdl_thread *from,pdl_thread *to); void pdl_clearthreadstruct(pdl_thread *it); void pdl_initthreadstruct(int nobl,pdl **pdls,PDL_Indx *realdims,PDL_Indx *creating,int npdls, pdl_errorinfo *info,pdl_thread *thread,char *flags, int noPthreadFlag ); int pdl_startthreadloop(pdl_thread *thread,void (*func)(pdl_trans *),pdl_trans *); int pdl_iterthreadloop(pdl_thread *thread,int which); void pdl_freethreadloop(pdl_thread *thread); void pdl_thread_create_parameter(pdl_thread *thread,int j,PDL_Indx *dims, int temp); void pdl_croak_param(pdl_errorinfo *info,int paramIndex, char *pat, ...); void pdl_setdims_careful(pdl *pdl); void pdl_put_offs(pdl *pdl,PDL_Indx offs, PDL_Anyval val); PDL_Anyval pdl_get_offs(pdl *pdl,PDL_Indx offs); PDL_Anyval pdl_get(pdl *pdl,PDL_Indx *inds); void pdl_set_trans(pdl *it, pdl *parent, pdl_transvtable *vtable); void pdl_make_physical(pdl *it); void pdl_make_physdims(pdl *it); void pdl_children_changesoon(pdl *it, int what); void pdl_changed(pdl *it, int what, int recursing); void pdl_separatefromparent(pdl *it); void pdl_trans_changesoon(pdl_trans *trans,int what); void pdl_trans_changed(pdl_trans *trans,int what); void pdl_set_trans_childtrans(pdl *it, pdl_trans *trans,int nth); void pdl_set_trans_parenttrans(pdl *it, pdl_trans *trans,int nth); /* pdlhash.c */ pdl* pdl_getcache( HV* hash ); /* Retrieve address of $$x{PDL} */ pdl* pdl_fillcache( HV* hash, SV* ref); /* Fill/create $$x{PDL} cache */ void pdl_fillcache_partial( HV *hash, pdl *thepdl ) ; SV* pdl_getKey( HV* hash, char* key ); /* Get $$x{Key} SV* with deref */ void pdl_flushcache( pdl *thepdl ); /* flush cache */ /* pdlconv.c */ void pdl_writebackdata_vaffine(pdl *it); void pdl_readdata_vaffine(pdl *it); void pdl_swap(pdl** a, pdl** b); /* Swap two pdl ptrs */ void pdl_converttype( pdl** a, int targtype, /* Change type of a pdl */ Logical changePerl ); void pdl_coercetypes( pdl** a, pdl **b, Logical changePerl ); /* Two types to same */ void pdl_grow ( pdl* a, PDL_Indx newsize); /* Change pdl 'Data' size */ void pdl_retype( pdl* a, int newtype); /* Change pdl 'Datatype' value */ void** pdl_twod( pdl* x ); /* Return 2D pointer to data array */ /* pdlsections.c */ PDL_Indx pdl_get_offset(PDL_Indx* pos, PDL_Indx* dims, PDL_Indx *incs, PDL_Indx offset, int ndims); /* Offset of pixel x,y,z... */ PDL_Indx pdl_validate_section( PDL_Indx* sec, PDL_Indx* dims, /* Check section */ int ndims ); void pdl_row_plusplus ( PDL_Indx* pos, PDL_Indx* dims, /* Move down one row */ int ndims ); void pdl_subsection( char *y, char*x, int datatype, /* Take subsection */ PDL_Indx* sec, PDL_Indx* dims, PDL_Indx *incs, PDL_Indx offset, int* ndims); void pdl_insertin( char*y, PDL_Indx* ydims, int nydims, /* Insert pdl in pdl */ char*x, PDL_Indx* xdims, int nxdims, int datatype, PDL_Indx* pos); PDL_Anyval pdl_at( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, /* Value at x,y,z,... */ PDL_Indx *incs, PDL_Indx offset, int ndims); void pdl_set( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, /* Set value at x,y,z... */ PDL_Indx *incs, PDL_Indx offs, int ndims, PDL_Anyval value); void pdl_axisvals( pdl* a, int axis ); /* Fill with axis values */ /* Structure to hold pointers core PDL routines so as to be used by many modules */ struct Core { I32 Version; pdl* (*SvPDLV) ( SV* ); void (*SetSV_PDL) ( SV *sv, pdl *it ); #if defined(PDL_clean_namespace) || defined(PDL_OLD_API) pdl* (*new) ( ); /* make it work with gimp-perl */ #else pdl* (*pdlnew) ( ); /* renamed because of C++ clash */ #endif pdl* (*tmp) ( ); pdl* (*create) (int type); void (*destroy) (pdl *it); pdl* (*null) (); SV* (*copy) ( pdl*, char* ); pdl* (*hard_copy) ( pdl* ); void (*converttype) ( pdl**, int, Logical ); void** (*twod) ( pdl* ); void* (*smalloc) ( STRLEN ); int (*howbig) ( int ); PDL_Indx* (*packdims) ( SV* sv, int *ndims ); /* Pack dims[] into SV aref */ void (*setdims) ( pdl* it, PDL_Indx* dims, int ndims ); void (*unpackdims) ( SV* sv, PDL_Indx *dims, /* Unpack */ int ndims ); void (*grow) ( pdl* a, PDL_Indx newsize); /* Change pdl 'Data' size */ void (*flushcache)( pdl *thepdl ); /* flush cache */ void (*reallocdims) ( pdl *it,int ndims ); /* reallocate dims and incs */ void (*reallocthreadids) ( pdl *it,int ndims ); void (*resize_defaultincs) ( pdl *it ); /* Make incs out of dims */ void (*thread_copy)(pdl_thread *from,pdl_thread *to); void (*clearthreadstruct)(pdl_thread *it); void (*initthreadstruct)(int nobl,pdl **pdls,PDL_Indx *realdims,PDL_Indx *creating,int npdls, pdl_errorinfo *info,pdl_thread *thread,char *flags, int noPthreadFlag ); int (*startthreadloop)(pdl_thread *thread,void (*func)(pdl_trans *),pdl_trans *); PDL_Indx *(*get_threadoffsp)(pdl_thread *thread); /* For pthreading */ int (*iterthreadloop)(pdl_thread *thread,int which); void (*freethreadloop)(pdl_thread *thread); void (*thread_create_parameter)(pdl_thread *thread,int j,PDL_Indx *dims, int temp); void (*add_deletedata_magic) (pdl *it,void (*func)(pdl *, Size_t param), Size_t param); /* Automagic destructor */ /* This needs to be fixed to work correctly for File::Map implementation */ /* XXX NOT YET IMPLEMENTED */ void (*setdims_careful)(pdl *pdl); void (*put_offs)(pdl *pdl,PDL_Indx offs, PDL_Anyval val); PDL_Anyval (*get_offs)(pdl *pdl,PDL_Indx offs); PDL_Anyval (*get)(pdl *pdl,PDL_Indx *inds); void (*set_trans_childtrans)(pdl *it, pdl_trans *trans,int nth); void (*set_trans_parenttrans)(pdl *it, pdl_trans *trans,int nth); pdl *(*make_now)(pdl *it); pdl *(*get_convertedpdl)(pdl *pdl,int type); void (*make_trans_mutual)(pdl_trans *trans); /* Affine trans. THESE ARE SET IN ONE OF THE OTHER Basic MODULES and not in Core.xs ! */ void (*readdata_affine)(pdl_trans *tr); void (*writebackdata_affine)(pdl_trans *tr); void (*affine_new)(pdl *par,pdl *child,PDL_Indx offs,SV *dims,SV *incs); /* Converttype. Similar */ void (*converttypei_new)(pdl *par,pdl *child,int type); void (*trans_mallocfreeproc)(struct pdl_trans *tr); void (*make_physical)(pdl *it); void (*make_physdims)(pdl *it); void (*pdl_barf) (const char* pat,...); void (*pdl_warn) (const char* pat,...); void (*make_physvaffine)(pdl *it); void (*allocdata) (pdl *it); PDL_Indx (*safe_indterm)(PDL_Indx dsz, PDL_Indx at, char *file, int lineno); float NaN_float; double NaN_double; !NO!SUBS! # set up the qsort routines # fortunately it looks like Types.pm.PL is processed before this # file require "./Types.pm"; # ie PDL::Types for (PDL::Types::typesrtkeys()) { my $ctype = $PDL::Types::typehash{$_}{ctype}; my $ppsym = $PDL::Types::typehash{$_}{ppsym}; print OUT "void (*qsort_${ppsym}) (${ctype} *xx, PDL_Indx a, PDL_Indx b );\n"; print OUT "void (*qsort_ind_${ppsym}) (${ctype} *xx, PDL_Indx *ix, PDL_Indx a, PDL_Indx b );\n"; } # storage space for bad values print OUT <<'!NO!SUBS!'; badvals bvals; /* store the default bad values */ void (*propagate_badflag) (pdl *it, int newval ); /* defined in bad.pd */ void (*propagate_badvalue) (pdl *it); void (*children_changesoon)(pdl *it, int what); void (*changed)(pdl *it, int what, int recursing); void (*vaffinechanged)(pdl *it, int what); PDL_Anyval (*get_pdl_badvalue)(pdl *it); }; typedef struct Core Core; Core *pdl__Core_get_Core(); /* INTERNAL TO CORE! DON'T CALL FROM OUTSIDE */ /* __PDLCORE_H */ #endif !NO!SUBS! PDL-2.018/Basic/Core/pdldataswitch.c.PL0000644060175006010010000000032412562522363015623 0ustar chmNone# using this because XSUBs won't do INCLUDE_COMMAND in C part before MODULE use PDL::Core::Dev; my $file = shift @ARGV; open my $fh, '>', $file or die "$file: $!"; select $fh; PDL::Core::Dev::datatypes_switch(); PDL-2.018/Basic/Core/pdlhash.c0000644060175006010010000000401712562522363014104 0ustar chmNone /* pdlhash.c - functions for manipulating pdl hashes */ #define PDL_CORE /* For certain ifdefs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ /* * DJB July 10 2006 * moved from pdlhash.c into Core.xs since it only seems to * be used there (and is not defined in any .h file so * should not be used by code outside Core/) * * Free the data if possible; used by mmapper void pdl_freedata (pdl *a) { if(a->datasv) { SvREFCNT_dec(a->datasv); a->datasv=0; a->data=0; } else if(a->data) { die("Trying to free data of untouchable (mmapped?) pdl"); } } */ /* Utility to change the size of the data compt of a pdl */ void pdl_grow (pdl* a, PDL_Indx newsize) { SV* foo; HV* hash; STRLEN nbytes; STRLEN ncurr; STRLEN len; if(a->state & PDL_DONTTOUCHDATA) { die("Trying to touch data of an untouchable (mmapped?) pdl"); } if(a->datasv == NULL) a->datasv = newSVpv("",0); foo = a->datasv; nbytes = ((STRLEN) newsize) * pdl_howbig(a->datatype); ncurr = SvCUR( foo ); if (ncurr == nbytes) return; /* Nothing to be done */ /* We don't want to do this: if someone is resizing it * but wanting to preserve data.. */ #ifdef FEOIJFOESIJFOJE if (ncurr>nbytes) /* Nuke back to zero */ sv_setpvn(foo,"",0); #endif if(nbytes > (1024*1024*1024)) { SV *sv = get_sv("PDL::BIGPDL",0); if(sv == NULL || !(SvTRUE(sv))) die("Probably false alloc of over 1Gb PDL! (set $PDL::BIGPDL = 1 to enable)"); fflush(stdout); } { void *p; p = SvGROW ( foo, nbytes ); SvCUR_set( foo, nbytes ); } a->data = (void *) SvPV( foo, len ); a->nvals = newsize; } /* unpack dims array into Hash */ void pdl_unpackarray ( HV* hash, char *key, PDL_Indx *dims, int ndims ) { AV* array; int i; array = newAV(); (void)hv_store(hash, key, strlen(key), newRV( (SV*) array), 0 ); if (ndims==0 ) return; for(i=0; i #endif /* Variable storing our the pthread ID for the main PDL thread. * This is used to tell if we are in the main pthread, or in one of * the pthreads spawned for PDL processing * This is only used when compiled with pthreads. */ #ifdef PDL_PTHREAD static pthread_t pdl_main_pthreadID; static int done_pdl_main_pthreadID_init = 0; /* deferred error messages are stored here. We can only barf/warn from the main * thread, so worker threads complain here and the complaints are printed out * altogether later */ static char* pdl_pthread_barf_msgs = NULL; static int pdl_pthread_barf_msgs_len = 0; static char* pdl_pthread_warn_msgs = NULL; static int pdl_pthread_warn_msgs_len = 0; #endif /* Singly linked list */ /* Note that this zeroes ->next!) */ void pdl__magic_add(pdl *it,pdl_magic *mag) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { foo = &((*foo)->next); } (*foo) = mag; mag->next = NULL; } void pdl__magic_rm(pdl *it,pdl_magic *mag) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); int found = 0; while(*foo) { if(*foo == mag) { *foo = (*foo)->next; found = 1; } else{ foo = &((*foo)->next); } } if( !found ){ die("PDL:Magic not found: Internal error\n"); } return; } void pdl__magic_free(pdl *it) { if (pdl__ismagic(it) && !pdl__magic_isundestroyable(it)) { pdl_magic *foo = (pdl_magic *)(it->magic); while(foo) { pdl_magic *next = foo->next; free(foo); foo = next; } } } /* Test for undestroyability */ int pdl__magic_isundestroyable(pdl *it) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { if((*foo)->what & PDL_MAGIC_UNDESTROYABLE) {return 1;} foo = &((*foo)->next); } return 0; } /* Call magics */ void *pdl__call_magic(pdl *it,int which) { void *ret = NULL; pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { if((*foo)->what & which) { if((*foo)->what & PDL_MAGIC_DELAYED) pdl_add_delayed_magic(*foo); else ret = (void *)((*foo)->vtable->cast(*foo)); /* Cast spell */ } foo = &((*foo)->next); } return ret; } /* XXX FINDS ONLY FIRST */ pdl_magic *pdl__find_magic(pdl *it, int which) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { if((*foo)->what & which) { return *foo; } foo = &((*foo)->next); } return NULL; } pdl_magic *pdl__print_magic(pdl *it) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { printf("Magic %p\ttype: ",(void*)(*foo)); if((*foo)->what & PDL_MAGIC_MARKCHANGED) printf("PDL_MAGIC_MARKCHANGED"); else if ((*foo)->what & PDL_MAGIC_MUTATEDPARENT) printf("PDL_MAGIC_MUTATEDPARENT"); else if ((*foo)->what & PDL_MAGIC_THREADING) printf("PDL_MAGIC_THREADING"); else printf("UNKNOWN"); if ((*foo)->what & (PDL_MAGIC_DELAYED|PDL_MAGIC_UNDESTROYABLE)) { printf(" qualifier(s): "); if ((*foo)->what & PDL_MAGIC_DELAYED) printf(" PDL_MAGIC_DELAYED"); if ((*foo)->what & PDL_MAGIC_UNDESTROYABLE) printf(" PDL_MAGIC_UNDESTROYABLE"); } printf("\n"); foo = &((*foo)->next); } return NULL; } int pdl__ismagic(pdl *it) { return (it->magic != 0); } static pdl_magic **delayed=NULL; static int ndelayed = 0; void pdl_add_delayed_magic(pdl_magic *mag) { /* FIXME: Common realloc mistake: 'delayed' nulled but not freed upon failure */ delayed = realloc(delayed,sizeof(*delayed)*++ndelayed); delayed[ndelayed-1] = mag; } void pdl_run_delayed_magic() { int i; pdl_magic **oldd = delayed; /* In case someone makes new delayed stuff */ int nold = ndelayed; delayed = NULL; ndelayed = 0; for(i=0; ivtable->cast(oldd[i]); } free(oldd); } /**************** * * ->bind - magic */ void *svmagic_cast(pdl_magic *mag) { pdl_magic_perlfunc *magp = (pdl_magic_perlfunc *)mag; dSP; PUSHMARK(sp); perl_call_sv(magp->sv, G_DISCARD | G_NOARGS); return NULL; } static pdl_magic_vtable svmagic_vtable = { svmagic_cast, NULL }; pdl_magic *pdl_add_svmagic(pdl *it,SV *func) { AV *av; pdl_magic_perlfunc *ptr = malloc(sizeof(pdl_magic_perlfunc)); ptr->what = PDL_MAGIC_MARKCHANGED | PDL_MAGIC_DELAYED; ptr->vtable = &svmagic_vtable; ptr->sv = newSVsv(func); ptr->pdl = it; ptr->next = NULL; pdl__magic_add(it,(pdl_magic *)ptr); if(it->state & PDL_ANYCHANGED) pdl_add_delayed_magic((pdl_magic *)ptr); /* In order to have our SV destroyed in time for the interpreter, */ /* XXX Work this out not to memleak */ av = perl_get_av("PDL::disposable_svmagics",TRUE); av_push(av,ptr->sv); return (pdl_magic *)ptr; } /**************** * * ->bind - magic */ pdl_trans *pdl_find_mutatedtrans(pdl *it) { if(!it->magic) return 0; return pdl__call_magic(it,PDL_MAGIC_MUTATEDPARENT); } static void *fammutmagic_cast(pdl_magic *mag) { pdl_magic_fammut *magp = (pdl_magic_fammut *)mag; return magp->ftr; } struct pdl_magic_vtable familymutmagic_vtable = { fammutmagic_cast, NULL }; pdl_magic *pdl_add_fammutmagic(pdl *it,pdl_trans *ft) { pdl_magic_fammut *ptr = malloc(sizeof(pdl_magic_fammut)); ptr->what = PDL_MAGIC_MUTATEDPARENT; ptr->vtable = &familymutmagic_vtable; ptr->ftr = ft; ptr->pdl = it; ptr->next = NULL; pdl__magic_add(it,(pdl_magic *)ptr); return (pdl_magic *)ptr; } #ifdef PDL_PTHREAD /************** * * pthreads * */ #define TVERB 0 typedef struct ptarg { pdl_magic_pthread *mag; void (*func)(pdl_trans *); pdl_trans *t; int no; } ptarg; int pdl_pthreads_enabled(void) {return 1;} static void *pthread_perform(void *vp) { struct ptarg *p = (ptarg *)vp; /* if(TVERB) printf("STARTING THREAD %d (%d)\n",p->no, pthread_self()); */ if(TVERB) printf("STARTING THREAD number %d\n",p->no); pthread_setspecific(p->mag->key,(void *)&(p->no)); (p->func)(p->t); /* if(TVERB) printf("ENDING THREAD %d (%d)\n",p->no, pthread_self()); */ if(TVERB) printf("ENDING THREAD number %d\n",p->no); return NULL; } int pdl_magic_thread_nthreads(pdl *it,int *nthdim) { pdl_magic_pthread *ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) return 0; *nthdim = ptr->nthdim; return ptr->nthreads; } int pdl_magic_get_thread(pdl *it) { /* XXX -> only one thread can handle pdl at once */ pdl_magic_pthread *ptr; int *p; ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) {die("Invalid pdl_magic_get_thread!");} p = (int*)pthread_getspecific(ptr->key); if(!p) { die("Invalid pdl_magic_get_thread specific!!!!"); } return *p; } void pdl_magic_thread_cast(pdl *it,void (*func)(pdl_trans *),pdl_trans *t, pdl_thread *thread) { pdl_magic_pthread *ptr; pthread_t *tp; ptarg *tparg; int i; int clearMagic = 0; /* Flag = 1 if we are temporarily creating pthreading magic in the supplied pdl. */ SV * barf_msg; /* Deferred barf message. Using a perl SV here so it's memory can be freeed by perl after it is sent to croak */ SV * warn_msg; /* Similar deferred warn message. */ ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) { /* Magic doesn't exist, create it Probably was deleted before the transformation performed, due to pdl lazy evaluation. */ pdl_add_threading_magic(it, thread->mag_nth, thread->mag_nthr); clearMagic = 1; /* Set flag to delete magic later */ /* Try to get magic again */ ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) {die("Invalid pdl_magic_thread_cast!");} } tp = malloc(sizeof(pthread_t) * thread->mag_nthr); tparg = malloc(sizeof(*tparg) * thread->mag_nthr); pthread_key_create(&(ptr->key),NULL); if(TVERB) printf("CREATING THREADS, ME: TBD, key: %ld\n", (unsigned long)(ptr->key)); /* Get the pthread ID of this main thread we are in. * Any barf, warn, etc calls in the spawned pthreads can use this * to tell if its a spawned pthread */ pdl_main_pthreadID = pthread_self(); /* should do inside pthread_once() */ done_pdl_main_pthreadID_init = 1; for(i=0; imag_nthr; i++) { tparg[i].mag = ptr; tparg[i].func = func; tparg[i].t = t; tparg[i].no = i; if (pthread_create(tp+i, NULL, pthread_perform, tparg+i)) { die("Unable to create pthreads!"); } } if(TVERB) printf("JOINING THREADS, ME: TBD, key: %ld\n", (unsigned long)(ptr->key)); for(i=0; imag_nthr; i++) { pthread_join(tp[i], NULL); } if(TVERB) printf("FINISHED THREADS, ME: TBD, key: %ld\n", (unsigned long)(ptr->key)); pthread_key_delete((ptr->key)); /* Remove pthread magic if we created in this function */ if( clearMagic ){ pdl_add_threading_magic(it, -1, -1); } /* Clean up memory allocated */ free(tp); free(tparg); // handle any errors that may have occurred in the worker threads I reset the // length before actually barfing/warning because barf() may not come back. // In that case, I'll have len==0, but an unfreed pointer. This memory will // be reclaimed the next time we barf/warn something (since I'm using // realloc). If we never barf/warn again, we'll hold onto this memory until // the interpreter exits. This is a one-time penalty, though so it's fine #define handle_deferred_errors(type) \ do{ \ if(pdl_pthread_##type##_msgs_len != 0) \ { \ pdl_pthread_##type##_msgs_len = 0; \ pdl_##type ("%s", pdl_pthread_##type##_msgs); \ free(pdl_pthread_##type##_msgs); \ pdl_pthread_##type##_msgs = NULL; \ } \ } while(0) handle_deferred_errors(warn); handle_deferred_errors(barf); } /* Function to remove threading magic (added by pdl_add_threading_magic) */ void pdl_rm_threading_magic(pdl *it) { pdl_magic_pthread *ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); /* Don't do anything if threading magic not found */ if( !ptr) return; /* Remove magic */ pdl__magic_rm(it, (pdl_magic *) ptr); /* Free magic */ free( ptr ); } /* Function to add threading magic (i.e. identify which PDL dimension should be pthreaded and how many pthreads to create Note: If nthdim and nthreads = -1 then any pthreading magic is removed */ void pdl_add_threading_magic(pdl *it,int nthdim,int nthreads) { pdl_magic_pthread *ptr; /* Remove threading magic if called with parms -1, -1 */ if( (nthdim == -1) && ( nthreads == -1 ) ){ pdl_rm_threading_magic(it); return; } ptr = malloc(sizeof(pdl_magic_pthread)); ptr->what = PDL_MAGIC_THREADING; ptr->vtable = NULL; ptr->next = NULL; ptr->nthdim = nthdim; ptr->nthreads = nthreads; pdl__magic_add(it,(pdl_magic *)ptr); } // Barf/warn function for deferred barf message handling during pthreading We // can't barf/warn during ptheading, because perl-level code isn't // threadsafe. This routine does nothing if we're in the main thread (allowing // the caller to barf normally, since there are not threading issues then). If // we're in a worker thread, this routine stores the message for main-thread // reporting later int pdl_pthread_barf_or_warn(const char* pat, int iswarn, va_list *args) { char** msgs; int* len; /* Don't do anything if we are in the main pthread */ if( !done_pdl_main_pthreadID_init || pthread_equal( pdl_main_pthreadID, pthread_self() ) ) return 0; if(iswarn) { msgs = &pdl_pthread_warn_msgs; len = &pdl_pthread_warn_msgs_len; } else { msgs = &pdl_pthread_barf_msgs; len = &pdl_pthread_barf_msgs_len; } // add the new complaint to the list { static pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER; pthread_mutex_lock( &mutex ); { /* In the chunk I'm adding I need to store the actual data and trailing newline. */ int extralen = vsnprintf(NULL, 0, pat, *args) + 1; /* 1 more for the trailing '\0'. (For windows, we first #undef realloc so that the system realloc function is used instead of the PerlMem_realloc macro. This currently works fine, though could conceivably require some tweaking in the future if it's found to cause any problem.) */ #ifdef WIN32 #undef realloc #endif /* FIXME: Common realloc mistake: 'msgs' nulled but not freed upon failure */ *msgs = realloc(*msgs, *len + extralen + 1); vsnprintf( *msgs + *len, extralen + 1, pat, *args); /* update the length-so-far. This does NOT include the trailing '\0' */ *len += extralen; /* add the newline to the end */ (*msgs)[*len-1] = '\n'; (*msgs)[*len ] = '\0'; } pthread_mutex_unlock( &mutex ); } if(iswarn) { /* Return 1, indicating we have handled the warn messages */ return(1); } /* Exit the current pthread. Since this was a barf call, and we should be halting execution */ pthread_exit(NULL); return 0; } #else /* Dummy versions */ void pdl_add_threading_magic(pdl *it,int nthdim,int nthreads) {} int pdl_magic_get_thread(pdl *it) {return 0;} void pdl_magic_thread_cast(pdl *it,void (*func)(pdl_trans *),pdl_trans *t, pdl_thread *thread) {} int pdl_magic_thread_nthreads(pdl *it,int *nthdim) {return 0;} int pdl_pthreads_enabled() {return 0;} int pdl_pthread_barf_or_warn(const char* pat, int iswarn, va_list *args){ return 0;} #endif /*************************** * * Delete magic * */ void pdl_delete_mmapped_data(pdl *p, Size_t param) { if(!p) {return;} if(!p->data) {return;} #ifdef USE_MMAP munmap(p->data, param); #else /* croak("internal error: trying to delete mmaped data on unsupported platform"); */ #endif p->data = 0; } static void *delete_mmapped_cast(pdl_magic *mag) { pdl_magic_deletedata *magp = (pdl_magic_deletedata *)mag; magp->func(magp->pdl, magp->param); return NULL; } struct pdl_magic_vtable deletedatamagic_vtable = { delete_mmapped_cast, NULL }; void pdl_add_deletedata_magic(pdl *it, void (*func)(pdl *, Size_t param), Size_t param) { pdl_magic_deletedata *ptr = malloc(sizeof(pdl_magic_deletedata)); ptr->what = PDL_MAGIC_DELETEDATA; ptr->vtable = &deletedatamagic_vtable; ptr->pdl = it; ptr->func = func; ptr->param = param; pdl__magic_add(it, (pdl_magic *)ptr); } PDL-2.018/Basic/Core/pdlmagic.h0000644060175006010010000000676012562522363014255 0ustar chmNone#ifndef _pdlmagic_H_ #define _pdlmagic_H_ #define PDL_ISMAGIC(it) ((it)->magic != 0) /* Magic stuff */ struct pdl_magic; /* If no copy, not copied with the pdl */ typedef struct pdl_magic_vtable { void *(*cast)(struct pdl_magic *); /* Cast the spell */ struct pdl_magic *(*copy)(struct pdl_magic *); /* void *(*cast_tr)(struct pdl_magic *,XXX); * int (*nth_tr)(struct pdl_magic *,XXX); */ } pdl_magic_vtable; #define PDL_MAGIC_MARKCHANGED 0x0001 #define PDL_MAGIC_MUTATEDPARENT 0x0002 #define PDL_MAGIC_THREADING 0x0004 #define PDL_MAGIC_DELETEDATA 0x0008 #define PDL_MAGIC_UNDESTROYABLE 0x4000 /* Someone is referring to this */ /* when magic removed, call pdl_destroy */ #define PDL_MAGIC_DELAYED 0x8000 #define PDL_MAGICSTART \ int what; /* when is this magic to be called */ \ pdl_magic_vtable *vtable; \ struct pdl_magic *next; \ pdl *pdl #define PDL_TRMAGICSTART \ int what; /* when is this magic to be called */ \ pdl_magic_vtable *vtable; \ struct pdl_magic *next; \ pdl_trans *tr typedef struct pdl_magic { PDL_MAGICSTART; } pdl_magic; typedef struct pdl_magic_perlfunc { PDL_MAGICSTART; SV *sv; /* sub{} or subname (perl_call_sv) */ } pdl_magic_perlfunc; typedef struct pdl_magic_fammut { PDL_MAGICSTART; pdl_trans *ftr; } pdl_magic_fammut; typedef struct pdl_magic_changetrans { PDL_MAGICSTART; pdl_trans *tr; } pdl_magic_changetrans; typedef struct pdl_magic_deletedata { PDL_MAGICSTART; void (*func)(pdl *p, Size_t param); Size_t param; } pdl_magic_deletedata; /* #define PDL_PTHREAD */ /* Defined by MakeMaker */ #ifdef PDL_PTHREAD /* This is a workaround to a perl CORE "feature" where they define a * macro PTHREAD_CREATE_JOINABLE with the same name as POSIX threads * which works as long as the implementation of POSIX threads also * uses macros. As is, the use of the same name space breaks for * win32 pthreads where the identifiers are enums and not #defines */ #ifdef PTHREAD_CREATE_JOINABLE #undef PTHREAD_CREATE_JOINABLE #endif #include typedef struct pdl_magic_pthread { PDL_MAGICSTART; int nthdim; int nthreads; pthread_key_t key; } pdl_magic_pthread; #endif /* - tr magics */ typedef struct pdl_trmagic { PDL_TRMAGICSTART; } pdl_trmagic; typedef struct pdl_trmagic_family { PDL_TRMAGICSTART; pdl *fprog,*tprog; pdl *fmut,*tmut; } pdl_trmagic_family; /* __ = Don't call from outside pdl if you don't know what you're doing */ void pdl__magic_add(pdl *,pdl_magic *); void pdl__magic_rm(pdl *,pdl_magic *); void pdl__magic_free(pdl *); int pdl__magic_isundestroyable(pdl *); void *pdl__call_magic(pdl *,int which); int pdl__ismagic(pdl *); pdl_magic *pdl__print_magic(pdl *it); pdl_magic *pdl_add_svmagic(pdl *,SV *); /* A kind of "dowhenidle" system */ void pdl_add_delayed_magic(pdl_magic *); void pdl_run_delayed_magic(); pdl_trans *pdl_find_mutatedtrans(pdl *it); /* Threading magic */ /* Deferred barfing and warning when pthreading */ int pdl_pthread_barf_or_warn(const char* pat, int iswarn, va_list *args); void pdl_add_threading_magic(pdl *,int nthdim,int nthreads); int pdl_magic_thread_nthreads(pdl *,int *nthdim); int pdl_magic_get_thread(pdl *); /* XXX -> only one thread can handle pdl at once */ void pdl_magic_thread_cast(pdl *,void (*func)(pdl_trans *),pdl_trans *t, pdl_thread *thread); int pdl_pthreads_enabled(void); /* Delete data magic */ void pdl_delete_mmapped_data(pdl *p, Size_t param) ; void pdl_add_deletedata_magic(pdl *it,void (*func)(pdl *, Size_t param), Size_t param); #endif /* _pdlmagic_H_ */ PDL-2.018/Basic/Core/pdlsections.g0000644060175006010010000001417413036512174015015 0ustar chmNone /*************************************************************** pdlsections.c ****************************************************************/ #define PDL_CORE /* For certain ifdefs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ /* Code for subsection handling - extraction/insertion. Works for arbitrary dimensionality of data. */ /* Compute offset of (x,y,z,...) position in row-major list */ PDL_Indx pdl_get_offset(PDL_Indx* pos, PDL_Indx* dims, PDL_Indx *incs, PDL_Indx offset, int ndims) { int i; PDL_Indx result; result = offset; for (i=0; iend || end>=dims[i]) croak("Invalid subsection specified"); count = count * (end-start+1); } return count; } /* Increrement a position pointer array by one row */ void pdl_row_plusplus ( PDL_Indx* pos, PDL_Indx* dims, int ndims ) { int i, noescape; i=1; noescape=1; while(noescape) { (pos[i])++; if (pos[i]==dims[i]) { /* Carry */ if (i>=(ndims)-1) { noescape = 0; /* Exit */ }else{ pos[i]=0; i++; } }else{ noescape = 0; /* Exit */ } } } /* Take the N-dimensional subsection of an N-dimensional array */ #ifdef FOOBAR void pdl_subsection( char *y, char*x, int datatype, PDL_Indx* sec, PDL_Indx* dims, PDL_Indx *incs, PDL_Indx offs, int* ndims) { /* Note dims, ndims are altered and returned to reflect the new section */ PDL_Indx *start,*end; int i,n1,n2,nrow,count,dsize; PDL_Indx n1,n2,nrow,count; /* Seperate section into start and end arrays - KISS! */ start = (PDL_Indx *) pdl_malloc( (*ndims)*sizeof(PDL_Indx) ); end = (PDL_Indx *) pdl_malloc( (*ndims)*sizeof(PDL_Indx) ); if (start == NULL || end == NULL) croak("Out of memory"); for(i=0;i<*ndims;i++){ start[i] = sec[2*i]; end[i] = sec[2*i+1]; } n1 = pdl_get_offset(start, dims, incs, offs, *ndims); /* Start pos */ n2 = pdl_get_offset(end, dims, incs, offs, *ndims); /* End pos */ dsize = pdl_howbig(datatype); /* Size of item */ nrow = end[0]-start[0]+1; /* Size of a row chunk */ count = 0; /* Transfer count */ while(n1<=n2) { memcpy( y+count*dsize, x+n1*dsize, nrow*dsize ); /* Copy row */ count += nrow; if (*ndims<2) break; pdl_row_plusplus( start, dims, *ndims ); /* Incr start[] one row */ n1 = pdl_get_offset(start, dims, incs, offs, *ndims); /* New pos */ } /* Calculate new dimensions */ for(i=0;i<*ndims;i++) dims[i] = sec[2*i+1]-sec[2*i]+1; /* Remove trailing degenerate unary dimensions */ while( (*ndims)>1 && dims[(*ndims)-1] == 1 ) (*ndims)--; /* Remove leading degenerate unary dimensions */ while( (*ndims)>1 && *dims == 1 ) { for(i=0;i<(*ndims)-1;i++) dims[i]=dims[i+1]; /* Shuffle down */ (*ndims)--; } } /* Insert one N-dimensional array in another */ void pdl_insertin( char*y, PDL_Indx* ydims, int nydims, char*x, PDL_Indx* xdims, int nxdims, int datatype, PDL_Indx* pos) { /* Note inserts x[] in y[] */ int i,dsize; PDL_Indx nyvals,nxvals,n1,n2,nrow,ntran; nyvals = 1; nxvals = 1; for(i=0; i=ydims[i]) croak("Position out of range"); } nxvals = 1; for(i=0; i ydims[0]) /* Edge overflow */ ntran = ydims[0]-pos[0]; dsize = pdl_howbig(datatype); while(n2=nyvals) /* Off Y image */ break; n2 += nrow; /* New pos in X */ } } #endif /* Return value at position (x,y,z...) */ PDL_Anyval pdl_at( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, PDL_Indx* incs, PDL_Indx offset, int ndims) { int i; PDL_Indx ioff; PDL_Anyval result = { -1, 0 }; for(i=0; i=dims[i]) croak("Position out of range"); } ioff = pdl_get_offset(pos, dims, incs, offset, ndims); GENERICLOOP (datatype) generic *xx = (generic *) x; result.type = datatype; result.value.generic_ppsym = xx[ioff]; ENDGENERICLOOP return result; } /* Set value at position (x,y,z...) */ void pdl_set( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, PDL_Indx* incs, PDL_Indx offs, int ndims, PDL_Anyval value){ int i; PDL_Indx ioff; for(i=0; i=dims[i]) croak("Position out of range"); } ioff = pdl_get_offset(pos, dims, incs, offs, ndims); GENERICLOOP (datatype) generic *xx = (generic *) x; ANYVAL_TO_CTYPE(xx[ioff], generic, value); ENDGENERICLOOP } PDL-2.018/Basic/Core/pdlsimple.h.PL0000644060175006010010000000335013101130663014754 0ustar chmNone#!/usr/local/bin/perl use Config; use File::Basename qw(&basename &dirname); require './Types.pm'; my $PDL_DATATYPES = PDL::Types::datatypes_header(); # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; # In this section, perl variables will be expanded during extraction. # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; #ifndef __PDL_H /* These are kept automaticallu in sync with pdl.h during perl build */ $PDL_DATATYPES #endif /* Define a simple pdl C data structure which maps onto passed piddles for passing with callext(). Note it is up to the user at the perl level to get the datatype right. Anything more sophisticated probably ought to go through PP anyway (which is fairly trivial). */ struct pdlsimple { int datatype; /* whether byte/int/float etc. */ void *data; /* Generic pointer to the data block */ PDL_Indx nvals; /* Number of data values */ PDL_Indx *dims; /* Array of data dimensions */ PDL_Long ndims; /* Number of data dimensions */ }; typedef struct pdlsimple pdlsimple; !GROK!THIS! PDL-2.018/Basic/Core/pdltest.c0000644060175006010010000000141712562522363014141 0ustar chmNone /* A small test program for the new create / delete routines */ int main() { pdl *bar; pdl *foo = pdl_create(PDL_PERM); int inds[2] = {1,1}; pdl_dump(foo); pdl_reallocdims(foo,2); foo->dims[0] = 5; foo->dims[1] = 6; pdl_reallocphysdata(foo); pdl_dump(foo); bar = pdl_createtrans(foo, pdl_affine_rectslice_transvtable); pdl_dump(bar); pdl_trans_affine_rectslice *trans = ((pdl_trans_affine_rectslice *)(foo->trans)); trans->starts[0] = 1; trans->ends[0] = 3; trans->starts[1] = 2; trans->ends[1] = 4; trans->steps[1] = 2; pdl_transchanged(bar); pdl_dump(bar); pdl_make_physical_affine(bar); pdl_dump(bar); pdl_make_physical(bar); pdl_dump(bar); pdl_set(bar,2.0,inds); pdl_changed(bar); pdl_dump(foo); pdl_make_physical_affine(foo); } PDL-2.018/Basic/Core/pdlthread.c0000644060175006010010000005707013036512174014433 0ustar chmNone/* XXX NOTE THAT IT IS NOT SAFE TO USE ->pdls MEMBER OUTSIDE INITTHREADSTRUCT! */ #define PDL_CORE /* For certain ifdefs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ #define MAX2(a,b) if((b)>(a)) a=b; /**** Convenience routines for moving around collections **** of indices and PDL pointers. **** (Note that copy_int_array is confusingly named sicne it **** doesn't copy ints, it copies PDL_Indx's.) ****/ static PDL_Indx *copy_int_array (PDL_Indx *from, int size) { int *to; Newx (to, size, int); return (PDL_Indx *) CopyD (from, to, size, int); } static pdl **copy_pdl_array (pdl **from, int size) { pdl **to; Newx (to, size, pdl*); return (pdl **) CopyD (from, to, size, pdl*); } /****************************** * dump_thread and helpers -- debugging routine used for * describing internal state */ static void print_iarr(PDL_Indx *iarr, int n) { int i; printf("("); for (i=0;ieinfo) { psp; printf("Funcname: %s\n",thread->einfo->funcname); psp; printf("Parameters: "); for (i=0;ieinfo->nparamnames;i++) printf("%s ",thread->einfo->paramnames[i]); printf("\n"); } psp; printf("Flags: %d, Ndims: %d, Nimplicit: %d, Npdls: %d, Nextra: %d\n", thread->gflags,thread->ndims,thread->nimpl,thread->npdls,thread->nextra); psp; printf("Dims: "); print_iarr(thread->dims,thread->ndims); printf("\n"); psp; printf("Inds: "); print_iarr(thread->inds,thread->ndims); printf("\n"); psp; printf("Offs: "); print_iarr(thread->offs,thread->npdls); printf("\n"); psp; printf("Incs: "); print_iarr(thread->incs,thread->ndims); printf("\n"); psp; printf("Realdims: "); print_iarr(thread->realdims,thread->npdls); printf("\n"); psp; printf("Pdls: ("); for (i=0;inpdls;i++) printf("%s%p",(i?" ":""),(void*)(thread->pdls[i])); printf(")\n"); psp; printf("Per pdl flags: ("); for (i=0;inpdls;i++) printf("%s%d",(i?" ":""),thread->flags[i]); printf(")\n"); } /******* * pdl_get_threadoffsp - get the pthread-specific offset arrays from a * PDL (TODO: improve function docs) * Input: thread structure * Outputs: Pointer to pthread-specific offset array (returned by function) */ PDL_Indx *pdl_get_threadoffsp(pdl_thread *thread ) { if(thread->gflags & PDL_THREAD_MAGICKED) { int thr = pdl_magic_get_thread(thread->pdls[thread->mag_nthpdl]); return thread->offs + thr * thread->npdls; } /* The non-multithreaded case: return just the usual offsets */ return thread->offs; } /* Function to get the pthread-specific offset, indexes and pthread number for the supplied thread structure Input: thread structure Outputs: Pointer to pthread-specific offset array (returned by function) Pointer to pthread-specific index array (ind Pointer supplied and modified by function) Pthread index for the current pthread ( nthr supplied and modified by function) */ PDL_Indx* pdl_get_threadoffsp_int(pdl_thread *thread, int *nthr, PDL_Indx **inds) { if(thread->gflags & PDL_THREAD_MAGICKED) { int thr = pdl_magic_get_thread(thread->pdls[thread->mag_nthpdl]); *nthr = thr; *inds = thread->inds + thr * thread->ndims; return thread->offs + thr * thread->npdls; } *nthr = 0; /* The non-multithreaded case: return just the usual offsets */ *inds = thread->inds; return thread->offs; } void pdl_thread_copy(pdl_thread *from,pdl_thread *to) { #ifdef PDL_THREAD_DEBUG to->magicno = from->magicno; #endif to->gflags = from->gflags; to->einfo = from->einfo; to->ndims = from->ndims; to->nimpl = from->nimpl; to->npdls = from->npdls; to->inds = copy_int_array(from->inds,to->ndims); to->dims = copy_int_array(from->dims,to->ndims); to->offs = copy_int_array(from->offs,to->npdls); to->incs = copy_int_array(from->incs,to->npdls*to->ndims); to->realdims = from->realdims; to->flags = savepvn(from->flags,to->npdls); to->pdls = copy_pdl_array(from->pdls,to->npdls); /* XX MEMLEAK */ to->mag_nthpdl = from->mag_nth; to->mag_nthpdl = from->mag_nthpdl; } void pdl_freethreadloop(pdl_thread *thread) { PDLDEBUG_f(printf("Freethreadloop(%p, %p %p %p %p %p %p)\n", (void*)thread, (void*)(thread->inds), (void*)(thread->dims), (void*)(thread->offs), (void*)(thread->incs), (void*)(thread->flags), (void*)(thread->pdls));) if(!thread->inds) {return;} Safefree(thread->inds); Safefree(thread->dims); Safefree(thread->offs); Safefree(thread->incs); Safefree(thread->flags); Safefree(thread->pdls); pdl_clearthreadstruct(thread); } void pdl_clearthreadstruct(pdl_thread *it) { PDLDEBUG_f(printf("Clearthreadloop(%p)\n", (void*)it);) it->einfo = 0;it->inds = 0;it->dims = 0; it->ndims = it->nimpl = it->npdls = 0; it->offs = 0; it->pdls = 0;it->incs = 0; it->realdims=0; it->flags=0; it->gflags=0; /* unsets PDL_THREAD_INITIALIZED among others */ #ifdef PDL_THREAD_DEBUG PDL_THR_CLRMAGIC(it); #endif } /* Function to auto-add pthreading magic (i.e. hints for multiple processor threads ) to the pdls, based on the target number of pthreads and the pdl-threaded dimensions . Number of pthreads is limited to a even division of the size of the threaded dimension. (e.g. if threaded dim of size 10 and the target number of pthreads is 2, 10/2 = 5 even, so the two pthreads will be created to process. However if thread dim is size 9 and target number of pthreads is 2, 9 can't be divided by 2, so no extra pthreads will be created. ) noPthreadFlag is a flag indicating that the pdl thread that called this function is not multiple processor threading safe, so no pthreading magic will be added */ void pdl_autopthreadmagic( pdl **pdls, int npdls, PDL_Indx* realdims, PDL_Indx* creating, int noPthreadFlag ){ int j, nthrd, totalDims, *nthreadedDims, **threadedDims; PDL_Indx **threadedDimSizes; PDL_Indx largest_nvals = 0; /* The largest PDL size for all the pdls involvled */ int t; /* Thread index for each pdl */ int tdimStart; /* Start of the threaded dims for each pdl */ int k; /* threadedDims array index for each pdl */ int nthreadDim; /* Number of thread dims for the current pdl */ int maxPthreadPDL; /* PDL that has the max (or right at the target) num pthreads */ int maxPthreadDim; /* Threaded dim number that has the max num pthreads */ int maxPthread = 0; /* Maximum achievable pthread */ int target_pthread = pdl_autopthread_targ; pdl_autopthread_actual = 0; /* Initialize the global variable indicating actual number of pthreads */ /* Don't do anything if auto_pthreading is turned off (i.e. equal zero) */ if( !target_pthread ) return; /* Remove any existing threading magic */ for(j=0; jmagic && (pdl_magic_thread_nthreads(pdls[j],&nthrd))) { pdl_add_threading_magic(pdls[j], -1, -1); } } if( noPthreadFlag ) return; /* Don't go further if the current pdl function isn't thread-safe */ /* Find the largest nvals */ for(j=0; jnvals > largest_nvals ){ largest_nvals = pdls[j]->nvals; } } /* See if the largest nvals is above the auto_pthread threadshold */ largest_nvals = largest_nvals>>20; /* Convert to MBytes */ /* Don't do anything if we are lower than the threshold */ if( largest_nvals < pdl_autopthread_size ) return; /* Build int arrays of threaded dim numbers and sizes for each pdl */ nthreadedDims = (int*) malloc(sizeof(int) * (npdls)); threadedDims = (int**) malloc(sizeof(int *) * (npdls)); threadedDimSizes = (PDL_Indx**) malloc(sizeof(PDL_Indx *) * (npdls)); /* Find total number of dims and allocate */ totalDims = 0; for(j=0; jndims); threadedDimSizes[j] = (PDL_Indx*) malloc(sizeof(PDL_Indx) * pdls[j]->ndims); } for(j=0; jndims; t++, k++ ){ threadedDimSizes[j][k] = pdls[j]->dims[t]; threadedDims[j][k] = t; nthreadDim++; } nthreadedDims[j] = nthreadDim; } /* Go thru each theaded dim and see how many pthreads we can create closest to the maximum target pthreads */ for(j=0; j 0) && (remainder > 0) ){ pthreadActual--; remainder = threadedDimSizes[j][k] % pthreadActual; } if( pthreadActual > maxPthread ){ /* Record this dim if it is the max */ maxPthread = pthreadActual; maxPthreadPDL = j; maxPthreadDim = threadedDims[j][k]; } /* Don't go any further if target pthread achieved */ if( pthreadActual == target_pthread ) break; } /* Don't go any further if target pthread achieved */ if( maxPthread == target_pthread ) break; } /* for(j=0; j 1 ){ pdl_add_threading_magic(pdls[maxPthreadPDL], maxPthreadDim, maxPthread); pdl_autopthread_actual = maxPthread; /* Set the global variable indicating actual number of pthreads */ } /* Free the stuff we allocated */ for(j=0; j copied * realdims is static and is NOT copied and NOT freed!!! * creating is only used inside this routine. * errorinfo is assumed static. * usevaffine is assumed static. (uses if exists) * * Only the first thread-magicked pdl is taken into account. * * noPthreadFlag is a flag to indicate the pdl thread is not pthreading safe * (i.e. don't attempt to create multiple posix threads to execute) */ void pdl_initthreadstruct(int nobl, pdl **pdls,PDL_Indx *realdims,PDL_Indx *creating,int npdls, pdl_errorinfo *info,pdl_thread *thread, char *flags, int noPthreadFlag ) { int i; int j; int ndims=0; int nth; int mx; int nids; int nimpl; int nthid; int mydim; int *nthreadids; int nthr = 0; int nthrd; PDLDEBUG_f(printf("Initthreadloop(%p)\n", (void*)thread);) #ifdef PDL_THREAD_DEBUG /* the following is a fix for a problem in the current core logic * see comments in pdl_make_physical in pdlapi.c * the if clause detects if this thread has previously been initialized * if yes free the stuff that was allocated in the last run * just returning is not! good enough (I tried it) * CS */ if (thread->magicno == PDL_THR_MAGICNO && thread->gflags & PDL_THREAD_INITIALIZED) { PDLDEBUG_f(printf("REINITIALIZING already initialized thread\n");) PDLDEBUG_f(dump_thread(thread);) /* return; */ /* try again, should (!?) work */ if (thread->inds) Safefree(thread->inds); if (thread->dims) Safefree(thread->dims); if (thread->offs) Safefree(thread->offs); if (thread->incs) Safefree(thread->incs); if (thread->flags) Safefree(thread->flags); if (thread->pdls) Safefree(thread->pdls); PDLDEBUG_f(pdl_warn("trying to reinitialize already initialized " "thread (mem-leak!); freeing...");) } PDL_THR_SETMAGIC(thread); #endif thread->gflags = 0; thread->npdls = npdls; thread->pdls = copy_pdl_array(pdls,npdls); thread->realdims = realdims; thread->ndims = 0; thread->mag_nth = -1; thread->mag_nthpdl = -1; thread->mag_nthr = -1; /* Accumulate the maximum number of thread dims across the collection of PDLs */ nids=mx=0; for(j=0; jnthreadids); MAX2(mx,pdls[j]->threadids[0] - realdims[j]); } nthreadids = pdl_malloc(sizeof(int)*nids); ndims += mx; nimpl = mx; thread->nimpl = nimpl; //printf("In pdl_initthreadstruct for func %s\n", info->funcname); pdl_autopthreadmagic(pdls, npdls, realdims, creating, noPthreadFlag); for(j=0; jmagic && (nthr = pdl_magic_thread_nthreads(pdls[j],&nthrd))) { thread->mag_nthpdl = j; thread->mag_nth = nthrd - realdims[j]; thread->mag_nthr = nthr; if(thread->mag_nth < 0) { pdl_croak_param(info,j,"Cannot magick non-threaded dims \n\t"); } } for(i=0; inthreadids <= nids) { MAX2(mx, pdls[j]->threadids[i+1] - pdls[j]->threadids[i]); } ndims += mx; nthreadids[i] = mx; } } if(nthr) { thread->gflags |= PDL_THREAD_MAGICKED; } if(ndims < nobl) { /* If too few, add enough implicit dims */ thread->nextra = nobl - ndims; ndims += thread->nextra; } else { thread->nextra = 0; } thread->ndims = ndims; thread->nimpl = nimpl; Newx(thread->inds, thread->ndims * (nthr>0 ? nthr : 1), PDL_Indx); /* Create space for pthread-specific inds (i.e. copy for each pthread)*/ if(thread->inds == NULL) croak("Failed to allocate memory for thread->inds in pdlthread.c"); Newx(thread->dims, thread->ndims, PDL_Indx); if(thread->dims == NULL) croak("Failed to allocate memory for thread->dims in pdlthread.c"); Newx(thread->offs, thread->npdls * (nthr>0 ? nthr : 1), PDL_Indx); /* Create space for pthread-specific offs */ if(thread->offs == NULL) croak("Failed to allocate memory for thread->offs in pdlthread.c"); Newx(thread->incs, thread->ndims * npdls, PDL_Indx); if(thread->incs == NULL) croak("Failed to allocate memory for thread->incs in pdlthread.c"); Newx(thread->flags, npdls, char); if(thread->flags == NULL) croak("Failed to allocate memory for thread->flags in pdlthread.c"); nth=0; /* Index to dimensions */ /* populate the per_pdl_flags */ for (i=0;ioffs[i] = 0; /* initialize offsets */ thread->flags[i] = 0; if (PDL_VAFFOK(pdls[i]) && VAFFINE_FLAG_OK(flags,i)) thread->flags[i] |= PDL_THREAD_VAFFINE_OK; } flags = thread->flags; /* shortcut for the remainder */ /* Make implicit inds */ for(i=0; idims[nth] = 1; // Start with a size of 1 for this thread for(j=0; jnpdls; j++) { // Now loop over the PDLs to be merged thread->incs[nth*npdls+j] = 0; if(creating[j]) continue; // If jth PDL is null, don't bother trying to match if(thread->pdls[j]->threadids[0]- // If we're off the end of the currend PDLs dimlist, thread->realdims[j] <= i) // then just skip it. continue; if(pdls[j]->dims[i+realdims[j]] != 1) { // If the current dim in the current PDL is not 1, if(thread->dims[nth] != 1) { // ... and the current planned size isn't 1, if(thread->dims[nth] != pdls[j]->dims[i+realdims[j]]) { // ... then check to make sure they're the same. /* Mismatch -- print a useful error message */ /* This probably uses a lot more lines than necessary */ int ii,jj,maxrealdims; char buf0[BUFSIZ]; char *s; buf0[0] = '\0'; s = buf0+strlen(buf0); sprintf(s," Mismatched implicit thread dimension %d: size %"IND_FLAG" vs. %"IND_FLAG"\nThere are %d PDLs in the expression; %d thread dim%s.\n",i,thread->dims[nth],pdls[j]->dims[i+realdims[j]],thread->npdls,nimpl,(nimpl==1)?"":"s"); s += strlen(s); for(ii=maxrealdims=0; iinpdls; ii++) if(thread->realdims[ii]>maxrealdims) maxrealdims=thread->realdims[ii]; sprintf(s, " PDL IN EXPR. "); s += strlen(s); if(maxrealdims > 0) { char format[80]; sprintf(format,"%%%ds",8 * maxrealdims + 3); sprintf(s,format,"ACTIVE DIMS | "); s += strlen(s); } sprintf(s,"THREAD DIMS\n"); s += strlen(s); for(ii=0; iinpdls; ii++) { sprintf(s," #%3d (%s",ii,creating[ii]?"null)\n":"normal): "); s += strlen(s); if(creating[ii]) continue; if(maxrealdims == 1) { sprintf(s," "); s += strlen(s); } for(jj=0; jj< maxrealdims - thread->realdims[ii]; jj++) { sprintf(s,"%8s"," "); s += strlen(s); } for(jj=0; jj< thread->realdims[ii]; jj++) { sprintf(s,"%8ld",(long)(pdls[ii]->dims[jj])); s += strlen(s); } if(maxrealdims) { sprintf(s," | "); s += strlen(s); } for(jj=0; jjrealdims[ii] < pdls[ii]->ndims; jj++) { sprintf(s,"%8ld",(long)(pdls[ii]->dims[jj+thread->realdims[ii]])); s += strlen(s); } sprintf(s,"\n"); s += strlen(s); } /* End of helpful error message -- now barf */ pdl_croak_param(info,j,"%s \n..",buf0); } /* If we're still here, they're the same -- OK! */ } else { // current planned size is 1 -- mod it to match this PDL thread->dims[nth] = pdls[j]->dims[i+realdims[j]]; } thread->incs[nth*npdls+j] = // Update the corresponding data stride PDL_TREPRINC(pdls[j],flags[j],i+realdims[j]); // from the PDL or from its vafftrans if relevant. } } nth++; } /* Go through everything again and make the real things */ for(nthid=0; nthiddims[nth] = 1; for(j=0; jnpdls; j++) { thread->incs[nth*npdls+j] = 0; if(creating[j]) continue; if(thread->pdls[j]->nthreadids < nthid) continue; if(thread->pdls[j]->threadids[nthid+1]- thread->pdls[j]->threadids[nthid] <= i) continue; mydim = i+thread->pdls[j]->threadids[nthid]; if(pdls[j]->dims[mydim] != 1) { if(thread->dims[nth] != 1) { if(thread->dims[nth] != pdls[j]->dims[mydim]) { pdl_croak_param(info,j,"Mismatched Implicit thread dimension %d: should be %d, is %d", i, thread->dims[nth], pdls[j]->dims[i+thread->realdims[j]]); } } else { thread->dims[nth] = pdls[j]->dims[mydim]; } thread->incs[nth*npdls+j] = PDL_TREPRINC(pdls[j],flags[j],mydim); } } nth++; } } /* Make sure that we have the obligatory number of threaddims */ for(; nthdims[nth]=1; for(j=0; jincs[nth*npdls+j] = 0; } /* If threading, make the true offsets and dims.. */ if(nthr > 0) { int n1 = thread->dims[thread->mag_nth] / nthr; int n2 = thread->dims[thread->mag_nth] % nthr; if(n2) { die("Cannot magick-thread with non-divisible n!"); } thread->dims[thread->mag_nth] = n1; } thread->gflags |= PDL_THREAD_INITIALIZED; PDLDEBUG_f(dump_thread(thread);) } void pdl_thread_create_parameter(pdl_thread *thread,int j,PDL_Indx *dims, int temp) { int i; int td = temp ? 0 : thread->nimpl; if(!temp && thread->nimpl != thread->ndims - thread->nextra) { pdl_croak_param(thread->einfo,j, "Trying to create parameter while explicitly threading.\ See the manual for why this is impossible"); } pdl_reallocdims(thread->pdls[j], thread->realdims[j] + td); for(i=0; irealdims[j]; i++) thread->pdls[j]->dims[i] = dims[i]; if (!temp) for(i=0; inimpl; i++) thread->pdls[j]->dims[i+thread->realdims[j]] = thread->dims[i] * ((i == thread->mag_nth && thread->mag_nthr > 0) ? thread->mag_nthr : 1); thread->pdls[j]->threadids[0] = td + thread->realdims[j]; pdl_resize_defaultincs(thread->pdls[j]); for(i=0; inimpl; i++) { thread->incs[thread->npdls*i + j] = temp ? 0 : PDL_REPRINC(thread->pdls[j],i+thread->realdims[j]); } } int pdl_startthreadloop(pdl_thread *thread,void (*func)(pdl_trans *), pdl_trans *t) { int i,j; PDL_Indx *offsp; int nthr; PDL_Indx *inds; if( (thread->gflags & (PDL_THREAD_MAGICKED | PDL_THREAD_MAGICK_BUSY)) == PDL_THREAD_MAGICKED ) { /* If no function supplied (i.e. being called from PDL::thread_over), don't run in parallel */ if(!func) { thread->gflags &= ~PDL_THREAD_MAGICKED; /* Cancel thread_magicked */ } else{ thread->gflags |= PDL_THREAD_MAGICK_BUSY; /* Do the threadloop magically (i.e. in parallel) */ pdl_magic_thread_cast(thread->pdls[thread->mag_nthpdl], func,t, thread); thread->gflags &= ~PDL_THREAD_MAGICK_BUSY; return 1; /* DON'T DO THREADLOOP AGAIN */ } } offsp = pdl_get_threadoffsp_int(thread,&nthr, &inds); for(i=0; indims; i++) inds[i] = 0; for(j=0; jnpdls; j++) offsp[j] = PDL_TREPROFFS(thread->pdls[j],thread->flags[j]) + (!nthr?0: nthr * thread->dims[thread->mag_nth] * thread->incs[thread->mag_nth*thread->npdls + j]); return 0; } /* This will have to be macroized */ int pdl_iterthreadloop(pdl_thread *thread,int nth) { int i,j; int stop = 0; int stopdim; PDL_Indx *offsp; int nthr; PDL_Indx *inds; offsp = pdl_get_threadoffsp_int(thread,&nthr, &inds); for(j=0; jnpdls; j++) offsp[j] = PDL_TREPROFFS(thread->pdls[j],thread->flags[j]); for(i=nth; indims; i++) { inds[i] ++; if( inds[i] >= thread->dims[i]) inds[i] = 0; else { stopdim = i; stop = 1; break; } } if(stop) goto calc_offs; return 0; calc_offs: for(j=0; jnpdls; j++) { offsp[j] = PDL_TREPROFFS(thread->pdls[j],thread->flags[j]) + (!nthr?0: nthr * thread->dims[thread->mag_nth] * thread->incs[thread->mag_nth*thread->npdls + j]); ; for(i=nth; indims; i++) { offsp[j] += thread->incs[i*thread->npdls+j] * inds[i]; } } return stopdim+1; } void pdl_croak_param(pdl_errorinfo *info,int paramIndex, char *pat, ...) { // I barf a string such as "PDL: function(a,b,c): Parameter 'b' errormessage" char message [4096] = {'\0'}; int i; va_list args; #define msgptr_advance() \ do { \ int N = strlen(msgptr); \ msgptr += N; \ remaining -= N; \ } while(0) char* msgptr = message; int remaining = sizeof(message); if(info) { if(paramIndex < 0 || paramIndex >= info->nparamnames) { strcat(msgptr, "ERROR: UNKNOWN PARAMETER"); msgptr_advance(); } else { snprintf(msgptr, remaining, "PDL: %s(", info->funcname); msgptr_advance(); for(i=0; inparamnames; i++) { snprintf(msgptr, remaining, "%s", info->paramnames[i]); msgptr_advance(); if(i < info->nparamnames-1) { snprintf(msgptr, remaining, ","); msgptr_advance(); } } snprintf(msgptr, remaining, "): Parameter '%s':\n", info->paramnames[paramIndex]); msgptr_advance(); } } va_start(args,pat); vsnprintf(msgptr, remaining, pat, args); va_end(args); pdl_barf(message); } PDL-2.018/Basic/Core/pdlthread.h0000644060175006010010000000510412562522363014433 0ustar chmNone #ifndef __PDLTHREAD_H #define __PDLTHREAD_H typedef struct pdl_errorinfo { char *funcname; char **paramnames; int nparamnames; } pdl_errorinfo; /* comment out unless debugging Note that full recompile will be needed since this switch changes the pdl_thread struct */ #define PDL_THREAD_DEBUG #define PDL_THREAD_MAGICKED 0x0001 #define PDL_THREAD_MAGICK_BUSY 0x0002 #define PDL_THREAD_INITIALIZED 0x0004 #ifdef PDL_THREAD_DEBUG #define PDL_THR_MAGICNO 0x92314764 #define PDL_THR_SETMAGIC(it) it->magicno = PDL_THR_MAGICNO #define PDL_THR_CLRMAGIC(it) (it)->magicno = 0x99876134 #else #define PDL_THR_CLRMAGIC(it) (void)0 #endif /* XXX To avoid mallocs, these should also have "default" values */ typedef struct pdl_thread { pdl_errorinfo *einfo; #ifdef PDL_THREAD_DEBUG int magicno; #endif int gflags; /* Flags about this struct */ int ndims; /* Number of dimensions threaded over */ int nimpl; /* Number of these that are implicit */ int npdls; /* Number of pdls involved */ int nextra; PDL_Indx *inds; /* Indices for each of the dimensions */ PDL_Indx *dims; /* Dimensions of each dimension */ PDL_Indx *offs; /* Offsets for each of the pdls */ PDL_Indx *incs; /* npdls * ndims array of increments. Fast because of constant indices for first loops */ PDL_Indx *realdims; /* realdims for each pdl (e.g., specified by PP signature) */ pdl **pdls; char *flags; /* per pdl flags */ int mag_nth; /* magicked thread dim */ int mag_nthpdl; /* magicked piddle */ int mag_nthr; /* number of threads */ } pdl_thread; /* Thread per pdl flags */ #define PDL_THREAD_VAFFINE_OK 0x01 #define PDL_TVAFFOK(flag) (flag & PDL_THREAD_VAFFINE_OK) #define PDL_TREPRINC(pdl,flag,which) (PDL_TVAFFOK(flag) ? \ pdl->vafftrans->incs[which] : pdl->dimincs[which]) #define PDL_TREPROFFS(pdl,flag) (PDL_TVAFFOK(flag) ? pdl->vafftrans->offs : 0) /* No extra vars; not sure about the NULL arg, means no per pdl args */ #define PDL_THREADINIT(thread,pdls,realdims,creating,npdls,info) \ PDL->initthreadstruct(0,pdls,realdims,creating,npdls,info,&thread;\ NULL) #define PDL_THREAD_DECLS(thread) #define PDL_THREADCREATEPAR(thread,ind,dims,temp) \ PDL->thread_create_parameter(&thread,ind,dims,temp) #define PDL_THREADSTART(thread) PDL->startthreadloop(&thread) #define PDL_THREADITER(thread,ptrs) PDL->iterthreadloop(&thread,0,NULL) #define PDL_THREAD_INITP(thread,which,ptr) /* Nothing */ #define PDL_THREAD_P(thread,which,ptr) ((ptr)+(thread).offs[ind]) #define PDL_THREAD_UPDP(thread,which,ptr) /* Nothing */ /* __PDLTHREAD_H */ #endif PDL-2.018/Basic/Core/ppport.h0000644060175006010010000046204212562522363014020 0ustar chmNone#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.14 Automatically created by Devel::PPPort running under perl 5.010000. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.14 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.10.0. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2008, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.14; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| CLASS|||n CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSV||| Gv_AMupdate||| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeUTF8||5.011000| HeVAL||5.004000| HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LVRET||| MARK||| MULTICALL||5.011000| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERL_ABS|5.008001||p PERL_BCDVERSION|5.011000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.011000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.011000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_compiling|5.004050||p PL_copline|5.011000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_expect|5.011000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_last_in_gv|||n PL_laststatval|5.005000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofs_sv|||n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p POP_MULTICALL||5.011000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.011000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg|5.007002||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.011000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _pMY_CXT|5.007003||p aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.011000||p aTHXR|5.011000||p aTHX_|5.006000||p aTHX|5.006000||p add_data|||n addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_i_ncmp||| amagic_ncmp||| any_dup||| ao||| append_elem||| append_list||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fake||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| boot_core_xsutils||| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_anoncode||| ck_bitop||| ck_concat||| ck_defined||| ck_delete||| ck_die||| ck_each||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lengthconst||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_readline||| ck_repeat||| ck_require||| ck_retarget||| ck_return||| ck_rfun||| ck_rvconst||| ck_sassign||| ck_select||| ck_shift||| ck_sort||| ck_spair||| ck_split||| ck_subr||| ck_substr||| ck_svconst||| ck_trunc||| ck_unpack||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init_zero|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| closest_cop||| convert||| cop_free||| cr_textfilter||| create_eval_scope||| croak_nocontext|||vn croak|||v csighandler||5.009003|n curmad||| custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto_len||| cv_ckproto||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_undef||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.011000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000| deprecate_old||| deprecate||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_where||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_chop||| do_close||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_kv||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs||5.006000| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| fd_on_nosuid_fs||| feature_is_enabled||| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_script||| find_uninit_var||| first_symbol|||n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_arena||| get_aux_mg||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags||5.009005| get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_2pv||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags||5.009002| gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs||5.009003| gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.011000| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_exists_ent||5.004000| hv_exists||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush||| ingroup||| init_argv_symbols||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr||| intro_my||| intuit_method||| intuit_more||| invert||| io_close||| isALNUM||| isALPHA||| isDIGIT||| isLOWER||| isSPACE||| isUPPER||| is_an_int||| is_gv_magical_sv||| is_gv_magical||| is_handle_constructor|||n is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.006000| is_uni_alnumc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.006000| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000| is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003| is_utf8_string_loc||5.008001| is_utf8_string||5.006001| is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword||| leave_scope||| lex_end||| lex_start||| linklist||| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.011000||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.011000||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhint||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall||| magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| magicname||| make_matcher||| make_trie_failtable||| make_trie||| malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mess_alloc||| mess_nocontext|||vn mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find||| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_get_linear_isa_c3||| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mul128||| mulexp10|||n my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat||| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf||5.009003|vn my_stat||| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n my||| need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type||5.009005| newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.011000||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.011000||p newSVpvn|5.004050||p newSVpvs_flags|5.011000||p newSVpvs_share||5.009003| newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.009003| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr||| no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n offer_nice_chunk||| oopsAV||| oopsCV||| oopsHV||| op_clear||| op_const_sv||| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_null||5.007002| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_xmldump||| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package||| packlist||5.008001| pad_add_anon||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||5.011000| pad_swipe||| pad_tidy||| pad_undef||| parse_body||| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmflag||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prepend_elem||| prepend_madprops||| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display||5.006000| pv_escape||5.009004| pv_pretty||5.009004| pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch||| refcounted_he_free||| refcounted_he_new||| refcounted_he_value||| refkids||| refto||| ref||5.011000| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_stringify||5.009005| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy||| report_evil_fh||| report_uninit||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hek_flags|||n save_helem||5.004050| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||| save_padsv||5.007001| save_pptr||| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| scope||| screaminstr||5.005000| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| setenv_getix||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.011000| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv||| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.004050||p sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup||| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc||| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.011000|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swap_match_buff||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vdie_common||| vdie_croak_common||| vdie||| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| write_no_mem||| write_to_stderr||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs||| xmldump_sub||| xmldump_vindent||| yyerror||| yylex||| yyparse||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (\$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif # define NUM2PTR(any,d) (any)(PTRV)(d) # define PTR2IV(p) INT2PTR(IV,p) # define PTR2UV(p) INT2PTR(UV,p) # define PTR2NV(p) NUM2PTR(NV,p) # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif /* !INT2PTR */ #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_laststatval laststatval # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting /* Replace: 0 */ #endif /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters * Do not use this variable. It is internal to the perl parser * and may change or even be removed in the future. Note that * as of perl 5.9.5 you cannot assign to this variable anymore. */ /* TODO: cannot assign to these vars; is it worth fixing? */ #if (PERL_BCDVERSION >= 0x5009005) # define PL_expect (PL_parser ? PL_parser->expect : 0) # define PL_copline (PL_parser ? PL_parser->copline : 0) # define PL_rsfp (PL_parser ? PL_parser->rsfp : (PerlIO *) 0) # define PL_rsfp_filters (PL_parser ? PL_parser->rsfp_filters : (AV *) 0) #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif /* Replace: 0 */ /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char * s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char * s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(s, len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval >= (int)len) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ PDL-2.018/Basic/Core/typemap0000644060175006010010000000144313036512174013713 0ustar chmNoneTYPEMAP pdl* T_PDL pdl * T_PDL pdl_trans * T_PDLTRANS pdl_trans* T_PDLTRANS Logical T_IV PDL_Indx T_IV float T_NV PDL_Anyval T_PDL_ANYVAL INPUT T_PDL $var = SvPDLV($arg); T_PDL_ANYVAL if (!SvOK($arg)) { $var.type = -1; $var.value.B = 0; } else if (SvIOK($arg)) { \#if IVSIZE == 8 $var.type = PDL_LL; $var.value.Q = (PDL_LongLong) SvIV($arg); \#else $var.type = PDL_L; $var.value.L = (PDL_Long) SvIV($arg); \#endif } else { $var.type = PDL_D; $var.value.D = (PDL_Double) SvNV($arg); } T_PDLTRANS if(sv_isa($arg,\"PDL::Trans\")) $var = INT2PTR(pdl_trans *,SvIV(SvRV($arg))); else croak(\"$var is not of type PDL::Trans\") OUTPUT T_PDL SetSV_PDL($arg,$var); T_PDL_ANYVAL ANYVAL_TO_SV($arg, $var) T_PDLTRANS sv_setref_pv($arg, \"PDL::Trans\", (void*)$var); PDL-2.018/Basic/Core/typemap.pdl0000644060175006010010000000145613036512174014475 0ustar chmNoneTYPEMAP pdl* T_PDL pdl * T_PDL pdl_trans * T_PDLTRANS pdl_trans* T_PDLTRANS Logical T_IV PDL_Indx T_IV float T_NV PDL_Anyval T_PDL_ANYVAL INPUT T_PDL $var = PDL->SvPDLV($arg); T_PDL_ANYVAL if (!SvOK($arg)) { $var.type = -1; $var.value.B = 0; } else if (SvIOK($arg)) { \#if IVSIZE == 8 $var.type = PDL_LL; $var.value.Q = (PDL_LongLong) SvIV($arg); \#else $var.type = PDL_L; $var.value.L = (PDL_Long) SvIV($arg); \#endif } else { $var.type = PDL_D; $var.value.D = (PDL_Double) SvNV($arg); } T_PDLTRANS if(sv_isa($arg,\"PDL::Trans\")) $var = INT2PTR(pdl_trans *,SvIV(SvRV($arg))); else croak(\"$var is not of type PDL::Trans\"); OUTPUT T_PDL PDL->SetSV_PDL($arg,$var); T_PDL_ANYVAL ANYVAL_TO_SV($arg, $var) T_PDLTRANS sv_setref_pv($arg, \"PDL::Trans\", (void*)$var); PDL-2.018/Basic/Core/Types.pm.PL0000644060175006010010000005144313036512174014272 0ustar chmNone# # this script is executed directly from the top-level Makefile.PL # (ie before the standard "loop through the directories" behaviour # of the WriteMakefile() call in that file) # use strict; use Config; use File::Basename qw(&basename &dirname); # Figure out the 4 byte integer type on this machine sub packtypeof_PDL_Indx { if ($Config{'ivsize'} == 8) { return 'q*'; } elsif ($Config{'ivsize'} == 4 ) { return 'l*'; } else { die "Types.pm.PL: packtype for ivsize==$Config{'ivsize'} not handled\n"; } } sub typeof_PDL_Indx { warn "Types.pm.PL: using typedef $Config{'ivtype'} PDL_Indx\n"; return $Config{'ivtype'} } sub typeof_PDL_Long { return 'int' if $Config{'intsize'}==4; return 'long' if $Config{'longsize'}==4; die "Can not find an integer datatype of size 4 bytes!!!\n"; } sub typeof_PDL_i64 { return $Config{i64type} or die "Can not find an integer 64 bit type"; } my $bvalflag = 0; for (@ARGV) { if(/^BADVALS=(.*)$/) { $bvalflag = $1; } } # Data types *must* be listed in order of complexity!! # this is critical for type conversions!!! # my @types = ( { identifier => 'B', pdlctype => 'PDL_Byte',# to be defined in pdl.h realctype => 'unsigned char', ppforcetype => 'byte', # for some types different from ctype usenan => 0, # do we need NaN handling for this type? packtype => 'C*', # the perl pack type defaultbadval => 'UCHAR_MAX', }, { identifier => 'S', pdlctype => 'PDL_Short', realctype => 'short', ppforcetype => 'short', usenan => 0, packtype => 's*', defaultbadval => 'SHRT_MIN', }, { identifier => 'US', onecharident => 'U', # only needed if different from identifier pdlctype => 'PDL_Ushort', realctype => 'unsigned short', ppforcetype => 'ushort', usenan => 0, packtype => 'S*', defaultbadval => 'USHRT_MAX', }, { identifier => 'L', pdlctype => 'PDL_Long', realctype => &typeof_PDL_Long, ppforcetype => 'int', usenan => 0, packtype => 'l*', defaultbadval => 'INT_MIN', }, # # The PDL_Indx type will be either the same as PDL_Long or, probably, # the same as PDL_LongLong depending on the platform. Will need to # determine the actual type at build time. { identifier => 'IND', onecharident => 'N', # only needed if different from identifier pdlctype => 'PDL_Indx', realctype => &typeof_PDL_Indx, ppforcetype => 'indx', usenan => 0, packtype => &packtypeof_PDL_Indx, defaultbadval => 'LONG_MIN', }, # # # note that the I/O routines have *not* been updated to be aware of # such a type yet # { identifier => 'LL', onecharident => 'Q', # only needed if different from identifier pdlctype => 'PDL_LongLong', realctype => &typeof_PDL_i64, ppforcetype => 'longlong', usenan => 0, packtype => 'q*', defaultbadval => 'LONG_MIN', # this is far from optimal # but LLONG_MIN/LLONG_MAX are probably # nonportable # on the other hand 2^63 should be the # value of of llong_max which we should be # able to compute at runtime ?! }, # IMPORTANT: # PDL_F *must* be the first non-integer type in this list # as there are many places in the code (.c/.xs/.pm/.pd) # with tests like this: # if (piddletype < PDL_F) { ... } { identifier => 'F', pdlctype => 'PDL_Float', realctype => 'float', ppforcetype => 'float', usenan => 1, packtype => 'f*', defaultbadval => '-FLT_MAX', }, { identifier => 'D', pdlctype => 'PDL_Double', realctype => 'double', ppforcetype => 'double', usenan => 1, packtype => 'd*', defaultbadval => '-DBL_MAX', }, ); sub checktypehas { my ($key,@types) = @_; for my $type (@types) { die "type is not a HASH ref" unless ref $type eq 'HASH'; die "type hash doesn't have a key '$key'" unless exists $type->{$key}; } } sub gentypevars { my @types = @_; checktypehas 'identifier', @types; my @ret = map {"\$PDL_$_->{identifier}"} @types; return wantarray ? @ret : $ret[0]; } sub genexports { my @types = @_; return join ' ', gentypevars @types; } sub gentypenames { my @types = @_; checktypehas 'identifier', @types; my @ret = map {"PDL_$_->{identifier}"} @types; return wantarray ? @ret : $ret[0]; } sub genpacktypes { my @types = @_; checktypehas 'packtype', @types; my @ret = map {"$_->{packtype}"} @types; return wantarray ? @ret : $ret[0]; } sub convertfunc { my ($type) = @_; return $type->{'convertfunc'} if exists $type->{'convertfunc'}; checktypehas 'pdlctype', $type; my $cfunc = $type->{pdlctype}; $cfunc =~ s/PDL_//; return lc $cfunc; } sub gentypehashentry ($$) { my ($type,$num) = @_; for my $field (qw/identifier pdlctype realctype ppforcetype usenan defaultbadval/) {checktypehas $field, $type} my $newhash = { ctype => $type->{pdlctype}, realctype => $type->{realctype}, ppsym => $type->{onecharident} || $type->{identifier}, ppforcetype => $type->{ppforcetype}, convertfunc => &convertfunc($type), sym => &gentypenames($type), numval => $num, usenan => $type->{usenan}, ioname => &convertfunc($type), # same as the name of the # convertfunc defbval => $type->{defaultbadval}, }; return $newhash; } sub gentypehashcode { my @types = @_; use Data::Dumper; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 1; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Pad = "\t\t"; my $i = 0; my $perlcode = ''; $perlcode .= "%PDL::Types::typehash = (\n"; for my $type (@types) { print STDOUT "making ".gentypenames($type)."...\n"; $perlcode .= "\t".gentypenames($type)." =>\n"; $perlcode .= Data::Dumper::Dumper(gentypehashentry($type, $i++)); $perlcode .= "\t\t,\n"; } $perlcode .= "); # end typehash definition\n"; return $perlcode; } # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file\n"; chmod 0644, $file; # in the following we generate the type dependent # parts of Types.pm # all the required info is extracted from the @types # array defined above # the guts how this is done is encapsulated in the subroutines # that follow the definition of @types # set up some variables that we will use below my $typeexports = genexports @types; my $ntypesm1 = @types - 1; # number of types - 1 my $typevars = join ', ',gentypevars @types; my $packtypes = join ' ', genpacktypes @types; my $typenames = join ' ', gentypenames @types; print OUT <<'!NO!SUBS!'; ### Generated from Types.pm.PL automatically - do not modify! ### package PDL::Types; require Exporter; use Carp; !NO!SUBS! print OUT qq{ \@EXPORT = qw( $typeexports \@pack \%typehash ); }; print OUT <<'!NO!SUBS!'; @EXPORT_OK = (@EXPORT, qw/types ppdefs typesrtkeys mapfld typefld/); %EXPORT_TAGS = ( All=>[@EXPORT,qw/types ppdefs typesrtkeys mapfld typefld/], ); @ISA = qw( Exporter ); !NO!SUBS! print OUT qq{ # Data types/sizes (bytes) [must be in order of complexity] # Enum ( $typevars ) = (0..$ntypesm1); # Corresponding pack types \@pack= qw/$packtypes/; \@names= qw/$typenames/; }; # generate the typehash output print OUT gentypehashcode @types; print OUT <<'!NO!SUBS!'; # Cross-reference by common names %PDL::Types::typenames = (); for my $k(keys %PDL::Types::typehash) { my $n = $PDL::Types::typehash{$k}->{'numval'}; $PDL::Types::typenames{$k} = $n; $PDL::Types::typenames{$n} = $n; $PDL::Types::typenames{$PDL::Types::typehash{$k}->{ioname}} = $n; $PDL::Types::typenames{$PDL::Types::typehash{$k}->{ctype}} = $n; } =head1 NAME PDL::Types - define fundamental PDL Datatypes =head1 SYNOPSIS use PDL::Types; $pdl = ushort( 2.0, 3.0 ); print "The actual c type used to store ushort's is '" . $pdl->type->realctype() . "'\n"; The actual c type used to store ushort's is 'unsigned short' =head1 DESCRIPTION Internal module - holds all the PDL Type info. The type info can be accessed easily using the C object returned by the L method. Skip to the end of this document to find out how to change the set of types supported by PDL. =head1 Support functions A number of functions are available for module writers to get/process type information. These are used in various places (e.g. C, C) to generate the appropriate type loops, etc. =head2 typesrtkeys return array of keys of typehash sorted in order of type complexity =cut sub typesrtkeys { return sort {$typehash{$a}->{numval} <=> $typehash{$b}->{numval}} keys %typehash; } =head2 ppdefs return array of pp symbols for all known types =cut sub ppdefs { return map {$typehash{$_}->{ppsym}} typesrtkeys; } =head2 typefld return specified field (C<$fld>) for specified type (C<$type>) by querying type hash =cut sub typefld { my ($type,$fld) = @_; croak "unknown type $type" unless exists $typehash{$type}; croak "unknown field $fld in type $type" unless exists $typehash{$type}->{$fld}; return $typehash{$type}->{$fld}; } =head2 mapfld (in_value, in_key, out_key) Map a given source field to the corresponding target field by querying the type hash. This gives you a way to say, "Find the type whose C<$in_key> is equal to C<$value>, and return that type's value for C<$out_key>. For example: # Does byte type use nan? $uses_nan = PDL::Types::mapfld(byte => 'ppforcetype', 'usenan'); # Equivalent: $uses_nan = byte->usenan; # What is the actual C type for the value that we call 'long'? $type_name = PDL::Types::mapfld(long => 'convertfunc', 'realctype'); # Equivalent: $type_name = long->realctype; As you can see, the equivalent examples are much shorter and legible, so you should only use mapfld if you were given the type index (in which case the actual type is not immediately obvious): $type_index = 4; $type_name = PDL::Types::mapfld($type_index => numval, 'realctype'); =cut sub mapfld { my ($type,$src,$trg) = @_; my @keys = grep {$typehash{$_}->{$src} eq $type} typesrtkeys; return @keys > 0 ? $typehash{$keys[0]}->{$trg} : undef; } =head2 typesynonyms =for ref return type related synonym definitions to be included in pdl.h . This routine must be updated to include new types as required. Mostly the automatic updating should take care of the vital things. =cut sub typesynonyms { my $add = join "\n", map {"#define PDL_".typefld($_,'ppsym')." ".typefld($_,'sym')} grep {"PDL_".typefld($_,'ppsym') ne typefld($_,'sym')} typesrtkeys; print "adding...\n$add\n"; return "$add\n"; } =head2 datatypes_header =for ref return C header text for F and F. =cut sub datatypes_header { require Config; $PDL_Indx_type = $Config::Config{'ivtype'}; warn "Using new 64bit index support\n" if $Config::Config{'ivsize'}==8; my $anyval_union = ''; my $enum = 'PDL_INVALID=-1, '; my $typedefs = ''; for (sort { $typehash{$a}{'numval'}<=>$typehash{$b}{'numval'} } keys %typehash) { $enum .= $typehash{$_}{'sym'}.", "; $anyval_union .= " $typehash{$_}{'ctype'} $typehash{$_}{'ppsym'};\n"; $typedefs .= "typedef $typehash{$_}{'realctype'} $typehash{$_}{'ctype'};\n"; } chop $enum; chop $enum; $typedefs .= "typedef struct {\n pdl_datatypes type;\n union {\n"; $typedefs .= $anyval_union; $typedefs .= " } value;\n} PDL_Anyval;\n"; my $indx_type = typefld('PDL_IND','realctype'); $typedefs .= '#define IND_FLAG '; if ($indx_type eq 'long'){ $typedefs .= qq|"ld"|; } elsif ($indx_type eq 'long long'){ $typedefs .= qq|"lld"|; } else { $typedefs .= qq|"d"|; } $typedefs .= "\n\n"; my $PDL_DATATYPES = <<"EOD"; /*****************************************************************************/ /*** This section of .h file generated automatically by ***/ /*** PDL::Types::datatypes_header() - don't edit manually ***/ /* Data types/sizes [must be in order of complexity] */ typedef enum { $enum } pdl_datatypes; /* Define the pdl data types */ $typedefs /* typedef $PDL_Indx_type PDL_Indx; */ /*****************************************************************************/ EOD $PDL_DATATYPES .= "\n".typesynonyms()."\n"; $PDL_DATATYPES; } =head1 PDL::Type OBJECTS This module declares one class - C - objects of this class are returned by the L method of a piddle. It has several methods, listed below, which provide an easy way to access type information: Additionally, comparison and stringification are overloaded so that you can compare and print type objects, e.g. $nofloat = 1 if $pdl->type < float; die "must be double" if $type != double; For further examples check again the L method. =over 4 =item enum Returns the number representing this datatype (see L). =item symbol Returns one of 'PDL_B', 'PDL_S', 'PDL_US', 'PDL_L', 'PDL_IND', 'PDL_LL', 'PDL_F' or 'PDL_D'. =item ctype Returns the macro used to represent this type in C code (eg 'PDL_Long'). =item ppsym The letter used to represent this type in PP code code (eg 'U' for L). =item realctype The actual C type used to store this type. =item shortctype The value returned by C without the 'PDL_' prefix. =item badvalue The special numerical value used to represent bad values for this type. See L for more details. =cut !NO!SUBS! =pod You happen to be reading this on CPAN, but if you were reading this on your own machine and your PDL did not have support for bad values, you would see a small paragraph saying: =cut unless ($bvalflag) { print OUT << '!NO!SUBS!'; =pod You do not have bad value support enabled, so this returns undef. =cut !NO!SUBS! } print OUT <<'!NO!SUBS!'; =item orig_badvalue The default special numerical value used to represent bad values for this type. (You can change the value that represents bad values for each type during runtime.) See the L for more details. =cut !NO!SUBS! =pod You happen to be reading this on CPAN, but if you were reading this on your own machine and your PDL did not have support for bad values, you would see a small paragraph saying: =cut unless ($bvalflag) { print OUT << '!NO!SUBS!'; =pod You do not have bad value support enabled, so this returns undef. =cut !NO!SUBS! } print OUT <<'!NO!SUBS!'; =back =cut { package PDL::Type; sub new { my($type,$val) = @_; if("PDL::Type" eq ref $val) { return bless [@$val],$type; } if(ref $val and $val->isa(PDL)) { if($val->getndims != 0) { PDL::Core::barf( "Can't make a type out of non-scalar piddle $val!"); } $val = $val->at; } PDL::Core::barf("Can't make a type out of non-scalar $val!". (ref $val)."!") if ref $val; if(length($PDL::Types::typenames{$val})) { $val =~ s/^\s*//o; $val =~ s/\s*$//o; return bless [$PDL::Types::typenames{$val}],$type; } else { die("Unknown type string '$val' (should be one of ". join(",",map { $PDL::Types::typehash{$_}->{ioname} } @names). ")\n"); } } sub enum { return $_[0]->[0]; } sub symbol { return $PDL::Types::names[ $_[0]->enum ]; } sub PDL::Types::types { # return all known types as type objects map { new PDL::Type PDL::Types::typefld($_,'numval') } PDL::Types::typesrtkeys(); } !NO!SUBS! foreach my $name ( qw( ctype ppsym realctype ppforcetype convertfunc sym numval usenan ioname defbval) ) { print OUT << "EOS"; sub $name { return \$PDL::Types::typehash{\$_[0]->symbol}->{$name}; } EOS } ## add the code for returning the bad value for a particular ## type. Up to (and including) 2.3.4, this code was actually in ## Basic/Bad/bad.pd. ## if ( $bvalflag ) { print OUT <<'!NO!SUBS!'; no strict 'refs'; sub badvalue { my ( $self, $val ) = @_; my $name = "PDL::_badvalue_int" . $self->enum(); if ( defined $val ) { return &{$name}( $val )->sclr; } else { return &{$name}( undef )->sclr; } } sub orig_badvalue { my $self = shift; my $name = "PDL::_default_badvalue_int" . $self->enum(); return &{$name}()->sclr; } use strict 'refs'; !NO!SUBS! } else { print OUT qq{ sub badvalue { return undef; } sub orig_badvalue { return undef; } }; } # if: $bvalflag print OUT <<'!NO!SUBS!'; sub shortctype { my $txt = $_[0]->ctype; $txt =~ s/PDL_//; return $txt; } # make life a bit easier use overload ( "\"\"" => sub { lc $_[0]->shortctype }, "eq" => sub { my($self, $other, $swap) = @_; return ("$self" eq $other); }, "cmp" => sub { my($self, $other, $swap) = @_; return ($swap ? $other cmp "$self" : "$self" cmp $other); }, "<=>" => sub { $_[2] ? $_[1]->enum <=> $_[0]->enum : $_[0]->enum <=> $_[1]->enum }, ); } # package: PDL::Type # Return 1; __END__ =head1 Adding/removing types You can change the types that PDL knows about by editing entries in the definition of the variable C<@types> that appears close to the top of the file F (i.e. the file from which this module was generated). =head2 Format of a type entry Each entry in the C<@types> array is a hash reference. Here is an example taken from the actual code that defines the C type: { identifier => 'US', onecharident => 'U', # only needed if different from identifier pdlctype => 'PDL_Ushort', realctype => 'unsigned short', ppforcetype => 'ushort', usenan => 0, packtype => 'S*', }, Before we start to explain the fields please take this important message on board: I. This is critical to ensure that PDL's type conversion works correctly. Basically, a less complex type will be converted to a more complex type as required. =head2 Fields in a type entry Each type entry has a number of required and optional entry. A list of all the entries: =over =item * identifier I. A short sequence of upercase letters that identifies this type uniquely. More than three characters is probably overkill. =item * onecharident I. Only required if the C has more than one character. This should be a unique uppercase character that will be used to reference this type in PP macro expressions of the C type. If you don't know what I am talking about read the PP manpage or ask on the mailing list. =item * pdlctype I. The C name that will be used to access this type from C code. =item * realctype I. The C compiler type that is used to implement this type. For portability reasons this one might be platform dependent. =item * ppforcetype I. The type name used in PP signatures to refer to this type. =item * usenan I. Flag that signals if this type has to deal with NaN issues. Generally only required for floating point types. =item * packtype I. The Perl pack type used to pack Perl values into the machine representation for this type. For details see C. =back Also have a look at the entries at the top of F. The syntax is not written into stone yet and might change as the concept matures. =head2 Other things you need to do You need to check modules that do I/O (generally in the F part of the directory tree). In the future we might add fields to type entries to automate this. This requires changes to those IO modules first though. You should also make sure that any type macros in PP files (i.e. C<$TBSULFD...>) are updated to reflect the new type. PDL::PP::Dump has a mode to check for type macros requiring updating. Do something like find . -name \*.pd -exec perl -Mblib=. -M'PDL::PP::Dump=typecheck' {} \; from the PDL root directory I updating F to check for such places. =cut !NO!SUBS! PDL-2.018/Basic/default.perldlrc0000644060175006010010000000251312562522364014602 0ustar chmNone # default.perldlrc # Default startup for perldl shell. # Note: any $HOME/.perldlrc file overrides this use PDL; use PDL::Dbg; # Enable useful commands use PDL::Constants qw(PI E); # add PI and E constants #use PDL::Lite; # Alternative to above for hard-core freaks # These are some PDL::Core parameters that you may wish # to set in an interactive PDL session: # # $PDL::debug When true, PDL debugging information is printed. # $PDL::verbose When true, PDL functions provide chatty information. # $PDL::use_commas Whether to insert commas when printing pdls # $PDL::floatformat The default print format for floats # $PDL::doubleformat The default print format for doubles # $PDL::undefval The value to use instead of "undef" when creating pdls. # $PDL::toolongtoprint The maximal size pdls to print (defaults to 10000 elements) # PDL waffle options (and pacify -w) BEGIN{ $PDL::debug = $PDL::debug = 0; $PDL::verbose = $PDL::verbose = 1; $PDL::toolongtoprint = $PDL::toolongtoprint = 10000; $PDL::IO::FlexRaw::writeflexhdr = 1; } if ( $PERLDL::TERM->ReadLine() =~ /::Perl$/ ) { if ( defined $readline::rl_MaxHistorySize ) { $readline::rl_MaxHistorySize = $PERLDL::HISTFILESIZE if defined $PERLDL::HISTFILESIZE; } } use PDL::Doc::Perldl; # online docs module 1; PDL-2.018/Basic/Gen/0000755060175006010010000000000013110402046012115 5ustar chmNonePDL-2.018/Basic/Gen/Inline/0000755060175006010010000000000013110402045013332 5ustar chmNonePDL-2.018/Basic/Gen/Inline/Makefile.PL0000644060175006010010000000035412562522363015326 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Inline', VERSION_FROM => 'Pdlpp.pm', PREREQ_PM => {'Inline' => 0.43}, PM => { map {($_ => '$(INST_LIBDIR)/Inline/'.$_)} <*.pm> }, ); PDL-2.018/Basic/Gen/Inline/MakePdlppInstallable.pm0000644060175006010010000000523012562522363017740 0ustar chmNonepackage Inline::MakePdlppInstallable; # just a dummy package package # have to break this up so the # CPAN indexer doesn't barf Inline; #============================================================================== # override the original Inline::install method # to allow Inline::Pdlpp code to be installed # # this is a hack ! # # we put the modified function into its own little file # to keep the runtime impact at a minimum # # use as follows in modules containing inlined PDL::PP code: # # use Inline::MakePdlppInstallable; # use Inline Pdlpp => .... # # hopefully Inline will establishe a proper mechanism soon # to allow installation of non-C modules -- at least Brian Ingerson # promised to put it on the TODO list #============================================================================== # copied verbatim from Inline 0.43 apart from language_id check below sub install { my ($module, $DIRECTORY); my $o = shift; # print STDERR "in redefined Inline::install\n"; croak M64_install_not_c($o->{API}{language_id}) unless uc($o->{API}{language_id}) eq 'C' || uc($o->{API}{language_id}) eq 'PDLPP'; # also allow Pdlpp ! croak M36_usage_install_main() if ($o->{API}{pkg} eq 'main'); croak M37_usage_install_auto() if $o->{CONFIG}{AUTONAME}; croak M38_usage_install_name() unless $o->{CONFIG}{NAME}; croak M39_usage_install_version() unless $o->{CONFIG}{VERSION}; croak M40_usage_install_badname($o->{CONFIG}{NAME}, $o->{API}{pkg}) unless $o->{CONFIG}{NAME} eq $o->{API}{pkg}; # $o->{CONFIG}{NAME} =~ /^$o->{API}{pkg}::\w(\w|::)+$/ # ); my ($mod_name, $mod_ver, $ext_name, $ext_ver) = ($o->{API}{pkg}, $ARGV[0], @{$o->{CONFIG}}{qw(NAME VERSION)}); croak M41_usage_install_version_mismatch($mod_name, $mod_ver, $ext_name, $ext_ver) unless ($mod_ver eq $ext_ver); $o->{INLINE}{INST_ARCHLIB} = $ARGV[1]; $o->{API}{version} = $o->{CONFIG}{VERSION}; $o->{API}{module} = $o->{CONFIG}{NAME}; my @modparts = split(/::/,$o->{API}{module}); $o->{API}{modfname} = $modparts[-1]; $o->{API}{modpname} = join('/',@modparts); $o->{API}{suffix} = $o->{INLINE}{ILSM_suffix}; $o->{API}{build_dir} = ( $o->{INLINE}{DIRECTORY} . '/build/' . $o->{API}{modpname} ); $o->{API}{directory} = $o->{INLINE}{DIRECTORY}; my $cwd = Cwd::cwd(); $o->{API}{install_lib} = "$cwd/$o->{INLINE}{INST_ARCHLIB}"; $o->{API}{location} = "$o->{API}{install_lib}/auto/" . "$o->{API}{modpname}/$o->{API}{modfname}.$o->{INLINE}{ILSM_suffix}"; unshift @::INC, $o->{API}{install_lib}; $o->{INLINE}{object_ready} = 0; } 1; PDL-2.018/Basic/Gen/Inline/Pdlpp.pm0000644060175006010010000003341513036512174014771 0ustar chmNonepackage Inline::Pdlpp; use strict; use warnings; use Config; use Data::Dumper; use Carp; use Cwd qw(cwd abs_path); use PDL::Core::Dev; $Inline::Pdlpp::VERSION = '0.4'; use base qw(Inline::C); #============================================================================== # Register this module as an Inline language support module #============================================================================== sub register { return { language => 'Pdlpp', aliases => ['pdlpp','PDLPP'], type => 'compiled', suffix => $Config{dlext}, }; } # handle BLESS, INTERNAL, NOISY - pass everything else up to Inline::C sub validate { my $o = shift; $o->{ILSM} ||= {}; $o->{ILSM}{XS} ||= {}; # Shouldn't use internal linking for Inline stuff, normally $o->{ILSM}{INTERNAL} = 0 unless defined $o->{ILSM}{INTERNAL}; $o->{ILSM}{MAKEFILE} ||= {}; if (not $o->UNTAINT) { my $w = abs_path(PDL::Core::Dev::whereami_any()); $o->{ILSM}{MAKEFILE}{INC} = qq{"-I$w/Core"}; } $o->{ILSM}{AUTO_INCLUDE} ||= ' '; # not '' as Inline::C does ||= my @pass_along; while (@_) { my ($key, $value) = (shift, shift); if ($key eq 'INTERNAL' or $key eq 'BLESS' ) { $o->{ILSM}{$key} = $value; next; } if ($key eq 'NOISY') { $o->{CONFIG}{BUILD_NOISY} = $value; next; } push @pass_along, $key, $value; } $o->SUPER::validate(@pass_along); } sub add_list { goto &Inline::C::add_list } sub add_string { goto &Inline::C::add_string } sub add_text { goto &Inline::C::add_text } #============================================================================== # Parse and compile C code #============================================================================== sub build { my $o = shift; # $o->parse; # no parsing in pdlpp $o->get_maps; # get the typemaps $o->write_PD; # $o->write_Inline_headers; # shouldn't need this one either $o->write_Makefile_PL; $o->compile; } #============================================================================== # Return a small report about the C code.. #============================================================================== sub info { my $o = shift; my $txt = <pd_generate . "\n*** end PP file ****\n"; } sub config { my $o = shift; } #============================================================================== # Write the PDL::PP code into a PD file #============================================================================== sub write_PD { my $o = shift; my $modfname = $o->{API}{modfname}; my $module = $o->{API}{module}; $o->mkpath($o->{API}{build_dir}); open my $fh, ">", "$o->{API}{build_dir}/$modfname.pd" or croak $!; print $fh $o->pd_generate; close $fh; } #============================================================================== # Generate the PDL::PP code (piece together a few snippets) #============================================================================== sub pd_generate { my $o = shift; return join "\n", ($o->pd_includes, $o->pd_code, $o->pd_boot, $o->pd_bless, $o->pd_done, ); } sub pd_includes { my $o = shift; return << "END"; pp_addhdr << 'EOH'; $o->{ILSM}{AUTO_INCLUDE} EOH END } sub pd_code { my $o = shift; return $o->{API}{code}; } sub pd_boot { my $o = shift; if (defined $o->{ILSM}{XS}{BOOT} and $o->{ILSM}{XS}{BOOT}) { return <{ILSM}{XS}{BOOT} EOB END } return ''; } sub pd_bless { my $o = shift; if (defined $o->{ILSM}{BLESS} and $o->{ILSM}{BLESS}) { return <{ILSM}{BLESS}; END } return ''; } sub pd_done { return <SUPER::get_maps; my $w = abs_path(PDL::Core::Dev::whereami_any()); push @{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, "$w/Core/typemap.pdl"; } #============================================================================== # Generate the Makefile.PL #============================================================================== sub write_Makefile_PL { my $o = shift; my ($modfname,$module,$pkg) = @{$o->{API}}{qw(modfname module pkg)}; my $coredev_suffix = $o->{ILSM}{INTERNAL} ? '_int' : ''; my @pack = [ "$modfname.pd", $modfname, $module ]; my $stdargs_func = $o->{ILSM}{INTERNAL} ? \&pdlpp_stdargs_int : \&pdlpp_stdargs; my %hash = $stdargs_func->(@pack); delete $hash{VERSION_FROM}; my %options = ( %hash, VERSION => $o->{API}{version} || "0.00", %{$o->{ILSM}{MAKEFILE}}, NAME => $o->{API}{module}, INSTALLSITEARCH => $o->{API}{install_lib}, INSTALLDIRS => 'site', INSTALLSITELIB => $o->{API}{install_lib}, MAN3PODS => {}, PM => {}, ); open my $fh, ">", "$o->{API}{build_dir}/Makefile.PL" or croak; print $fh <SUPER::compile; } sub fix_make { } # our Makefile.PL doesn't need this 1; __END__ =head1 NAME Inline::Pdlpp - Write PDL Subroutines inline with PDL::PP =head1 DESCRIPTION C is a module that allows you to write PDL subroutines in the PDL::PP style. The big benefit compared to plain C is that you can write these definitions inline in any old perl script (without the normal hassle of creating Makefiles, building, etc). Since version 0.30 the Inline module supports multiple programming languages and each language has its own support module. This document describes how to use Inline with PDL::PP (or rather, it will once these docs are complete C<;)>. For more information on Inline in general, see L. Some example scripts demonstrating C usage can be found in the F directory. C is a subclass of L. Most Kudos goes to Brian I. =head1 Usage You never actually use C directly. It is just a support module for using C with C. So the usage is always: use Inline Pdlpp => ...; or bind Inline Pdlpp => ...; =head1 Examples Pending availability of full docs a few quick examples that illustrate typical usage. =head2 A simple example # example script inlpp.pl use PDL; # must be called before (!) 'use Inline Pdlpp' calls use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $a = sequence 10; print $a->inc,"\n"; print $a->inc->dummy(1,10)->tcumul,"\n"; __DATA__ __Pdlpp__ pp_def('inc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); pp_def('tcumul', Pars => 'in(n);[o] mul()', Code => '$mul() = 1; loop(n) %{ $mul() *= $in(); %}', ); # end example script If you call this script it should generate output similar to this: prompt> perl inlpp.pl Inline running PDL::PP version 2.2... [1 2 3 4 5 6 7 8 9 10] [3628800 3628800 3628800 3628800 3628800 3628800 3628800 3628800 3628800 3628800] Usage of C in general is similar to C. In the absence of full docs for C you might want to compare L. =head2 Code that uses external libraries, etc The script below is somewhat more complicated in that it uses code from an external library (here from Numerical Recipes). All the relevant information regarding include files, libraries and boot code is specified in a config call to C. For more experienced Perl hackers it might be helpful to know that the format is similar to that used with L. The keywords are largely equivalent to those used with C. Please see below for further details on the usage of C, C, C and C. use PDL; # this must be called before (!) 'use Inline Pdlpp' calls use Inline Pdlpp => Config => INC => "-I$ENV{HOME}/include", LIBS => "-L$ENV{HOME}/lib -lnr -lm", # code to be included in the generated XS AUTO_INCLUDE => <<'EOINC', #include #include "nr.h" /* for poidev */ #include "nrutil.h" /* for err_handler */ static void nr_barf(char *err_txt) { fprintf(stderr,"Now calling croak...\n"); croak("NR runtime error: %s",err_txt); } EOINC # install our error handler when loading the Inline::Pdlpp code BOOT => 'set_nr_err_handler(nr_barf);'; use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $a = zeroes(10) + 30;; print $a->poidev(5),"\n"; __DATA__ __Pdlpp__ pp_def('poidev', Pars => 'xm(); [o] pd()', GenericTypes => [L,F,D], OtherPars => 'long idum', Code => '$pd() = poidev((float) $xm(), &$COMP(idum));', ); =head1 Pdlpp Configuration Options For information on how to specify Inline configuration options, see L. This section describes each of the configuration options available for Pdlpp. Most of the options correspond either to MakeMaker or XS options of the same name. See L and L. =head2 AUTO_INCLUDE Specifies extra statements to automatically included. They will be added onto the defaults. A newline char will be automatically added. Does essentially the same as a call to C. For short bits of code C is probably syntactically nicer. use Inline Pdlpp => Config => AUTO_INCLUDE => '#include "yourheader.h"'; =head2 BLESS Same as C command. Specifies the package (i.e. class) to which your new Ied methods will be added. Defaults to C if omitted. use Inline Pdlpp => Config => BLESS => 'PDL::Complex'; =head2 BOOT Specifies C code to be executed in the XS BOOT section. Corresponds to the XS parameter. Does the same as the C command. Often used to execute code only once at load time of the module, e.g. a library initialization call. =head2 CC Specify which compiler to use. =head2 CCFLAGS Specify extra compiler flags. =head2 INC Specifies an include path to use. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => INC => '-I/inc/path'; =head2 LD Specify which linker to use. =head2 LDDLFLAGS Specify which linker flags to use. NOTE: These flags will completely override the existing flags, instead of just adding to them. So if you need to use those too, you must respecify them here. =head2 LIBS Specifies external libraries that should be linked into your code. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => LIBS => '-lyourlib'; or use Inline Pdlpp => Config => LIBS => '-L/your/path -lyourlib'; =head2 MAKE Specify the name of the 'make' utility to use. =head2 MYEXTLIB Specifies a user compiled object that should be linked in. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => MYEXTLIB => '/your/path/yourmodule.so'; =head2 OPTIMIZE This controls the MakeMaker OPTIMIZE setting. By setting this value to '-g', you can turn on debugging support for your Inline extensions. This will allow you to be able to set breakpoints in your C code using a debugger like gdb. =head2 TYPEMAPS Specifies extra typemap files to use. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => TYPEMAPS => '/your/path/typemap'; =head2 NOISY Show the output of any compilations going on behind the scenes. Turns on C in L. =head1 BUGS =head2 Cing inline scripts Beware that there is a problem when you use the __DATA__ keyword style of Inline definition and want to C your script containing inlined code. For example # myscript.pl contains inlined code # in the __DATA__ section perl -e 'do "myscript.pl";' One or more DATA sections were not processed by Inline. According to Brian Ingerson (of Inline fame) the workaround is to include an Cinit> call in your script, e.g. use PDL; use Inline Pdlpp; Inline->init; # perl code __DATA__ __Pdlpp__ # pp code =head2 C and C There is currently an undesired interaction between L and C. Since PP code generally contains expressions of the type C<$var()> (to access piddles, etc) L recognizes those incorrectly as slice expressions and does its substitutions. For the moment (until hopefully the parser can deal with that) it is best to explicitly switch L off before the section of inlined Pdlpp code. For example: use PDL::NiceSlice; use Inline::Pdlpp; $a = sequence 10; $a(0:3)++; $a->inc; no PDL::NiceSlice; __DATA__ __C__ ppdef (...); # your full pp definition here =head1 ACKNOWLEDGEMENTS Brian Ingerson for creating the Inline infrastructure. =head1 AUTHOR Christian Soeller =head1 SEE ALSO L L L L =head1 COPYRIGHT Copyright (c) 2001. Christian Soeller. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as PDL itself. See http://pdl.perl.org =cut PDL-2.018/Basic/Gen/Makefile.PL0000644060175006010010000000332712562522363014113 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; my @pms = map {($_ => '$(INST_LIBDIR)/'.$_)} (<*.pm>, , 'PP/Dump.pm'); push @pms, ('pptemplate.pod' => '$(INST_LIBDIR)/pptemplate.pod'); undef &MY::postamble; # suppress warning *MY::postamble = sub { <<'EOF'; PP/Dump.pm: PP/dump.pp $(PERL) PP$(DFSEP)dump.pp > PP$(DFSEP)Dump.pm.tmp $(MV) PP$(DFSEP)Dump.pm.tmp PP$(DFSEP)Dump.pm pptemplate.pod: pptemplate $(PERLRUN) -MPod::Select -e "podselect('pptemplate');" > pptemplate.pod EOF }; #EU::MM's processPL() is continually broken on Win32 ... hence: ## Fix appears to be necessary on all MM platforms now, to avoid circular references :-( -- CED 9-July-2008 undef &MY::processPL; *MY::processPL = sub { package MY; my ($self) = @_; return $self->SUPER::processPL if 0; ## unless $^O =~ /MSWin32/i && $Config{make} =~ /\b[dn]make/i; return "" unless $self->{PL_FILES}; my @m; my $alltarget = $ExtUtils::MakeMaker::VERSION >= 7.05_06 ? 'pure_nolink' : 'all'; my $colon = $Config::Config{make} =~ /\bdmake/i ? ':' : '::'; foreach my $plfile (sort keys %{$self->{PL_FILES}}) { my $list = ref($self->{PL_FILES}->{$plfile}) ? $self->{PL_FILES}->{$plfile} : [$self->{PL_FILES}->{$plfile}]; foreach my $target (@$list) { push @m, "\n$alltarget :: $target\n\t\$(NOECHO) \$(NOOP)\n", "\n$target $colon\n\t\$(PERLRUNINST) $plfile $target\n"; } } join "", @m; }; WriteMakefile(NAME => "PDL::PP", PM => {@pms}, 'EXE_FILES' => ['pptemplate'], clean => {FILES => "PP/Dump.pm PP/Dump.pm.tmp pptemplate.pod"}, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Basic/Gen/PP/0000755060175006010010000000000013110402046012434 5ustar chmNonePDL-2.018/Basic/Gen/PP/CType.pm0000644060175006010010000001010012562522363014025 0ustar chmNone# Represent any C type. # Type contains the size of arrays, which is either constant # or resolved (into an object) from resolveobj. package C::Type; use Carp; # new C::Type(resolveobj,str) sub new { my $this = bless {},shift; $this->{Resolve} = shift; if(@_) { $this->parsefrom(shift); } return $this; } sub stripptrs { my($this,$str) = @_; if($str =~ /^\s*\w+\s*$/) { $str =~ s/\s//g; $this->{ProtoName} = $str; return []; } else { # Now, recall the different C syntaxes. First priority is a pointer: my $decl; if($str =~ /^\s*\*(.*)$/) { $decl = $this->stripptrs($1); unshift @$decl,"PTR"; } elsif($str =~ /^\s*\(.*\)\s*$/) { # XXX Should try to see if a funccall. return $this->stripptrs($1); } elsif($str =~ /^(.*)\[([^]]+)\]\s*$/) { my $siz = $2; print "ARR($str): ($siz)\n" if $::PP_VERBOSE; $decl = $this->stripptrs($1); unshift @$decl,"ARR($siz)"; print "ARR($str): ($siz)\n" if $::PP_VERBOSE; } else { die("Invalid C type '$str'"); } return $decl; } } # XXX Correct to *real* parsing. This is only a subset. sub parsefrom { my($this,$str) = @_; # First, take the words in the beginning $str =~ /^\s*((?:\w+\b\s*)+)([^[].*)$/; my $base = $1; my $decl = $2; my $foo = $this->stripptrs($decl); $this->{Base} = $base; $this->{Chain} = $foo; } sub get_decl { my($this,$name,$opts) = @_; for(@{$this->{Chain}}) { if($_ eq "PTR") {$name = "*$name"} elsif($_ =~/^ARR\((.*)\)$/) { if($opts->{VarArrays2Ptrs}) { $name = "*$name"; } else { $name = "($name)[$1]"; } } else { confess("Invalid decl") } } return "$this->{Base} $name"; } # Useful when parsing argument decls sub protoname { return shift->{ProtoName} } sub get_copy { my($this,$from,$to) = @_; my ($prev,$close); if($#{$this->{Chain}} >= 0) { # strdup loses portability :( return "($to) = malloc(strlen($from)+1); strcpy($to,$from);" if $this->{Base} =~ /^\s*char\s*$/; return "($to) = newSVsv($from);" if $this->{Base} =~ /^\s*SV\s*$/; my $code = $this->get_malloc($to,$from); my ($deref0,$deref1) = ($from,$to); for(@{$this->{Chain}}) { if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");} elsif($_ =~/^ARR\((.*)\)$/) { $no++; $prev .= " if(!$deref0) {$deref1=0;} else {int __malloc_ind_$no; for(__malloc_ind_$no = 0; __malloc_ind_$no < $1; __malloc_ind_$no ++) {"; $deref0 = $deref0."[__malloc_ind_$no]"; $deref1 = $deref1."[__malloc_ind_$no]"; $close .= "}}"; } else { confess("Invalid decl $_") } } $code .= "$prev $deref1 = $deref0; $close"; return $code; } return "($to) = ($from);"; } sub get_free { my($this,$from) = @_; my ($prev,$close); if($#{$this->{Chain}} >= 0) { return "free($from);" if $this->{Base} =~ /^\s*char\s*$/; return "SvREFCNT_dec($from);" if $this->{Base} =~ /^\s*SV\s*$/; my @mallocs; my $str = "{"; my $deref = "$from"; my $prev = undef; my $close = undef; my $no = 0; for(@{$this->{Chain}}) { $no++; if($no > 1) {croak("Can only free one layer!\n");} # if($_ eq "PTR") {confess("Cannot free pointer, must be array ;) (FIX CType.pm)");} return "free($from);\n "; } } else { ""; } } sub need_malloc { my($this) = @_; return scalar grep /(ARR|PTR)/,(@{$this->{Chain}}) } # Just returns with the array string. sub get_malloc { my($this,$assignto) = @_; my $str = "{"; my $deref = "$assignto"; my $prev = undef; my $close = undef; my $no = 0; for(@{$this->{Chain}}) { if($_ eq "PTR") {confess("Cannot alloc pointer, must be array");} elsif($_ =~/^ARR\((.*)\)$/) { $str .= "$prev $assignto = malloc(sizeof(* $assignto) * $1); "; $no++; $prev = "{int __malloc_ind_$no; for(__malloc_ind_$no = 0; __malloc_ind_$no < $1; __malloc_ind_$no ++) {"; $deref = $deref."[__malloc_ind_$no]"; $close .= "}}"; } else { confess("Invalid decl $_") } } $str .= "}"; return $str; } sub getvar { } # Determine if everything constant and can just declare sub need_alloc { } sub alloccode { } sub copycode { } sub freecode { } 1; PDL-2.018/Basic/Gen/PP/Dims.pm0000644060175006010010000000355712562522363013717 0ustar chmNone############################################## package PDL::PP::PdlDimsObj; # Hold more dims use Carp; sub new { my($type) = @_; bless {},$type; } sub get_indobj_make { my($this,$expr) = @_; $expr =~ /^([a-zA-Z0-9]+)(?:=([0-9]+))?$/ or confess "Invalid index expr '$expr'\n"; my $name = $1; my $val = $2; my $indobj; if(defined $this->{$name}) { $indobj = $this->{$name}; } else { $indobj = PDL::PP::Ind->new($name); $this->{$name}=$indobj; } if(defined $val) { $indobj->add_value($val); } return $indobj; } ##################################################################### # # Encapsulate one index. package PDL::PP::Ind; use Carp; sub new { my($type,$name) = @_; my $this = bless {Name => $name},$type; return $this; } # set the value of an index, also used by perl level threading sub add_value { my($this,$val) = @_; croak("index values for $this->{Name} must be positive") unless $val > 0; if(defined $this->{Value}) { if ($this->{Value} == -1 || $this->{Value} == 1) { $this->{Value} = $val } elsif($val != 1 && $val != $this->{Value}) { croak("For index $this->{Name} conflicting values $this->{Value} and $val given\n"); } } else { $this->{Value} = $val; } } # This index will take its size value from outside parameter ... sub set_from { my($this,$otherpar) = @_; $this->{From} = $otherpar; } sub name {return (shift)->{Name}} sub get_decldim { my($this) = @_; return "PDL_Indx __$this->{Name}_size;"; } sub get_initdim { my($this) = @_; my $init = '-1'; $init = "\$COMP(".$this->{From}->{ProtoName}.")" if $this->{From}; $init = $this->{Value} if defined $this->{Value}; "\$PRIV(__$this->{Name}_size) = $init;" } sub get_copydim { my($this,$fromsub,$tosub) = @_; my($iname) = "__$this->{Name}_size"; &$tosub($iname) ."=". &$fromsub($iname) .";" ; } sub get_size { my($this) = @_; "\$PRIV(__$this->{Name}_size)" } 1; PDL-2.018/Basic/Gen/PP/dump.pp0000644060175006010010000000407612562522363013770 0ustar chmNone# These are suspended for now... # use blib; # For Types.pm # require './PP.pm'; open PP, "PP.pm" or die "can't open PP.pm"; $str = join '',; $str =~ m|\@PDL::PP::EXPORT\s*=\s*qw/([^/]*)/|s; $str = $1; # Get the contents of the qw// $pm = ' =head1 NAME PDL::PP::Dump -- dump pp_xxx calls to stdout =head1 SYNOPSIS perl -MPDL::PP::Dump Basic/Ops/ops.pd =head1 DESCRIPTION The most basic PP script debugger thinkable. =head1 AUTHOR Christian Soeller . =cut package PDL::PP::Dump; use Exporter; @ISA = Exporter; @EXPORT = qw('.$str.q|); my $typecheck =0; sub import { my ($pack,$arg) = @_; $typecheck =1 if defined $arg && $arg =~ /^typecheck$/i; @_ = ($pack); goto &Exporter::import; } sub printargs { my $name = shift; print "$name("; print join ',',map("'$_'",@_); print ");\n"; } for (@EXPORT) { if ($_ !~ /pp_def/) { my $def = "sub $_ { printargs($_,\@_) unless \$typecheck }"; # print "defining =>\n$def\n"; eval($def); } } sub pp_def { my($name,%hash) = @_; use PDL::Types ':All'; if ($typecheck) { my @alltypes = ppdefs; my $jointypes = join '',@alltypes; my $types = exists $hash{GenericTypes} ? $hash{GenericTypes} : [@alltypes]; for my $key (qw/Code BackCode/) { if (exists $hash{$key}) { while ($hash{$key} =~ s/\$T([a-zA-Z]+)\s*\(([^)]*)\)//) { my ($mactypes,$alternatives) = ($1,$2); # print "type macro ($mactypes) in $name\n"; my @mactypes = split '', $mactypes; print "$name has extra types in macro: $mactypes vs $jointypes\n" unless $mactypes =~ /^\s*[$jointypes]+\s*$/; for my $gt (@$types) { print "$name has no Macro for generic type $gt (has $mactypes)" unless grep {$gt eq $_} @mactypes; } } } } } else { print "pp_def('$name',\n"; foreach (keys(%hash)) { if ($_ =~ /(Generic)*Types/) { print "$_ => [" . join(',',@{$hash{$_}}) . "]\n"; } else { print "$_ =>\n'".$hash{$_}."',\n"; } } print ");\n"; } } 1; |; print $pm; PDL-2.018/Basic/Gen/PP/PDLCode.pm0000644060175006010010000011272413036512174014226 0ustar chmNone# This file provides a class that parses the Code -member # of the PDL::PP code. # # This is what makes the nice loops go around etc. # package PDL::PP::Code; use Carp; our @CARP_NOT; use strict; # check for bad value support # use PDL::Config; #use vars qw ( $bvalflag $usenan ); my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; my $usenan = $PDL::Config{BADVAL_USENAN} || 0; sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});} # we define the method separate_code() at the end of this # file, so that it can call the constructors from the classes # defined in this file. ugly... # Do the appropriate substitutions in the code. sub new { my($type,$code,$badcode,$parnames,$parobjs,$indobjs,$generictypes, $extrageneric,$havethreading,$name, $dont_add_thrloop, $nogeneric_loop, $backcode ) = @_; die "Error: missing name argument to PDL::PP::Code->new call!\n" unless defined $name; # simple way of handling bad code check $badcode = undef unless $bvalflag; my $handlebad = defined($badcode); # last three arguments may not be supplied # (in fact, the nogeneric_loop argument may never be supplied now?) # # "backcode" is a flag to the PDL::PP::Threadloop class indicating thre threadloop # is for writeback code (typically used for writeback of data from child to parent PDL $dont_add_thrloop = 0 unless defined $dont_add_thrloop; $nogeneric_loop = 0 unless defined $nogeneric_loop; # C++ style comments # # This regexp isn't perfect because it doesn't cope with # literal string constants. # $code =~ s,//.*?\n,,g; if ($::PP_VERBOSE) { print "Processing code for $name\n"; print "DONT_ADD_THRLOOP!\n" if $dont_add_thrloop; print "EXTRAGEN: {" . join(" ", map { "$_=>" . $$extrageneric{$_}} keys %$extrageneric) . "}\n"; print "ParNAMES: ",(join ',',@$parnames),"\n"; print "GENTYPES: ", @$generictypes, "\n"; print "HandleBad: $handlebad\n"; } my $this = bless { IndObjs => $indobjs, ParNames => $parnames, ParObjs => $parobjs, Gencurtype => [], # stack to hold GenType in generic loops types => 0, # hack for PDL::PP::Types/GenericLoop pars => {}, # hack for PDL::PP::NaNSupport/GenericLoop Generictypes => $generictypes, # so that MacroAccess can check it Name => $name, }, $type; my $inccode = join '',map {$_->get_incregisters();} (sort values %{$this->{ParObjs}}); # First, separate the code into an array of C fragments (strings), # variable references (strings starting with $) and # loops (array references, 1. item = variable. # my ( $threadloops, $coderef, $sizeprivs ) = $this->separate_code( "{$inccode\n$code\n}" ); # Now, if there is no explicit threadlooping in the code, # enclose everything into it. if(!$threadloops && !$dont_add_thrloop && $havethreading) { print "Adding threadloop...\n" if $::PP_VERBOSE; my $nc = $coderef; if( !$backcode ){ # Normal readbackdata threadloop $coderef = PDL::PP::ThreadLoop->new(); } else{ # writebackcode threadloop $coderef = PDL::PP::BackCodeThreadLoop->new(); } push @{$coderef},$nc; } # repeat for the bad code, then stick good and bad into # a BadSwitch object which creates the necessary # 'if (bad) { badcode } else { goodcode }' code # # NOTE: amalgamate sizeprivs from good and bad code # if ( $handlebad ) { print "Processing 'bad' code...\n" if $::PP_VERBOSE; my ( $bad_threadloops, $bad_coderef, $bad_sizeprivs ) = $this->separate_code( "{$inccode\n$badcode\n}" ); if(!$bad_threadloops && !$dont_add_thrloop && $havethreading) { print "Adding 'bad' threadloop...\n" if $::PP_VERBOSE; my $nc = $bad_coderef; if( !$backcode ){ # Normal readbackdata threadloop $bad_coderef = PDL::PP::ThreadLoop->new(); } else{ # writebackcode threadloop $bad_coderef = PDL::PP::BackCodeThreadLoop->new(); } push @{$bad_coderef},$nc; } my $good_coderef = $coderef; $coderef = PDL::PP::BadSwitch->new( $good_coderef, $bad_coderef ); # amalgamate sizeprivs from Code/BadCode segments # (sizeprivs is a simple hash, with each element # containing a string - see PDL::PP::Loop) while ( my ( $bad_key, $bad_str ) = each %$bad_sizeprivs ) { my $str = $$sizeprivs{$bad_key}; if ( defined $str ) { die "ERROR: sizeprivs problem in PP/PDLCode.pm (BadVal stuff)\n" unless $str eq $bad_str; } $$sizeprivs{$bad_key} = $bad_str; # copy over } } # if: $handlebad print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; # Enclose it all in a genericloop. unless ($nogeneric_loop) { # XXX Make genericloop understand denied pointers;... my $nc = $coderef; $coderef = PDL::PP::GenericLoop->new($generictypes,"", [grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)'); push @{$coderef},$nc; } # Do we have extra generic loops? # If we do, first reverse the hash: my %glh; for(keys %$extrageneric) { push @{$glh{$extrageneric->{$_}}},$_; } my $no = 0; for(keys %glh) { my $nc = $coderef; $coderef = PDL::PP::GenericLoop->new($generictypes,$no++, $glh{$_},$_); push @$coderef,$nc; } # Then, in this form, put it together what we want the code to actually do. print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; $this->{Code} = "{".(join '',sort values %$sizeprivs). $coderef->get_str($this,[]) ."}"; $this->{Code}; } # new() # This sub determines the index name for this index. # For example, a(x,y) and x0 becomes [x,x0] sub make_loopind { my($this,$ind) = @_; my $orig = $ind; while(!$this->{IndObjs}{$ind}) { if(!((chop $ind) =~ /[0-9]/)) { confess("Index not found for $_ ($ind)!\n"); } } return [$ind,$orig]; } ##################################################################### # # Encapsulate the parsing code objects # # All objects have two methods: # new - constructor # get_str - get the string to be put into the xsub. ########################### # # Encapsulate a block package PDL::PP::Block; sub new { my($type) = @_; bless [],$type; } sub myoffs { return 0; } sub myprelude {} sub myitem {return "";} sub mypostlude {} sub get_str { my ($this,$parent,$context) = @_; my $str = $this->myprelude($parent,$context); $str .= $this->get_str_int($parent,$context); $str .= $this->mypostlude($parent,$context); return $str; } sub get_str_int { my ( $this, $parent, $context ) = @_; my $nth=0; my $str = ""; MYLOOP: while(1) { my $it = $this->myitem($parent,$nth); last MYLOOP if $nth and !$it; $str .= $it; $str .= (join '',map {ref $_ ? $_->get_str($parent,$context) : $_} @{$this}[$this->myoffs()..$#{$this}]); $nth++; } return $str; } # get_str_int() ########################### # # Deal with bad code # - ie create something like # if ( badflag ) { badcode } else { goodcode } # package PDL::PP::BadSwitch; @PDL::PP::BadSwitch::ISA = "PDL::PP::Block"; sub new { my($type,$good,$bad) = @_; return bless [$good,$bad], $type; } sub get_str { my ($this,$parent,$context) = @_; my $good = $this->[0]; my $bad = $this->[1]; my $str = "if ( \$PRIV(bvalflag) ) { PDL_COMMENT(\"** do 'bad' Code **\")\n"; $str .= "\n#define PDL_BAD_CODE\n"; $str .= $bad->get_str($parent,$context); $str .= "\n#undef PDL_BAD_CODE\n"; $str .= "} else { PDL_COMMENT(\"** else do 'good' Code **\")\n"; $str .= $good->get_str($parent,$context); $str .= "}\n"; return $str; } ########################### # # Encapsulate a loop package PDL::PP::Loop; @PDL::PP::Loop::ISA = "PDL::PP::Block"; sub new { my($type,$args,$sizeprivs,$parent) = @_; my $this = bless [$args],$type; for(@{$this->[0]}) { print "SIZP $sizeprivs, $_\n" if $::PP_VERBOSE; my $i = $parent->make_loopind($_); $sizeprivs->{$i->[0]} = "register PDL_Indx __$i->[0]_size = \$PRIV(__$i->[0]_size);\n"; print "SP :",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; } return $this; } sub myoffs { return 1; } sub myprelude { my($this,$parent,$context) = @_; my $text = ""; my $i; push @$context, map { $i = $parent->make_loopind($_); # Used to be $PRIV(.._size) but now we have it in a register. $text .= "{PDL_COMMENT(\"Open $_\") register PDL_Indx $_; for($_=0; $_<(__$i->[0]_size); $_++) {"; $i; } @{$this->[0]}; return $text; } sub mypostlude { my($this,$parent,$context) = @_; splice @$context, - ($#{$this->[0]}+1); return join '',map {"}} PDL_COMMENT(\"Close $_\")"} @{$this->[0]}; } ########################### # # Encapsulate a generic type loop # # we use the value of $parent->{types} [set by a PDL::PP::Types object] # to determine whether to define/undefine the THISISxxx macros # (makes the xs code easier to read) # package PDL::PP::GenericLoop; @PDL::PP::GenericLoop::ISA = "PDL::PP::Block"; # Types: BSULFD use PDL::Types ':All'; sub new { my($type,$types,$name,$varnames,$whattype) = @_; bless [(PDL::PP::get_generictyperecs($types)),$name,$varnames, $whattype],$type; } sub myoffs {4} sub myprelude { my($this,$parent,$context) = @_; push @{$parent->{Gencurtype}},'PDL_undef'; # so that $GENERIC can get at it # horrible hack for PDL::PP::NaNSupport if ( $this->[1] ne "" ) { my ( @test ) = keys %{$parent->{pars}}; die "ERROR: need to rethink NaNSupport in GenericLoop\n" if $#test != -1; $parent->{pars} = {}; } my $thisis_loop = ''; if ( $parent->{types} ) { $thisis_loop = join '', map { "#undef THISIS$this->[1]_$_\n#define THISIS$this->[1]_$_(a)\n" } (ppdefs); } return <[3]) { case -42: PDL_COMMENT("Warning eater") {(void)1; WARNING_EATER } sub myitem { my($this,$parent,$nth) = @_; # print "GENERICITEM\n"; my $item = $this->[0]->[$nth]; if(!$item) {return "";} $parent->{Gencurtype}->[-1] = $item->[1]; # horrible hack for PDL::PP::NaNSupport if ( $this->[1] ne "" ) { foreach my $parname ( @{$this->[2]} ) { $parent->{pars}{$parname} = $item->[1]; } } my $thisis_loop = ''; if ( $parent->{types} ) { $thisis_loop = ( join '', map { "#undef THISIS$this->[1]_$_\n#define THISIS$this->[1]_$_(a)\n"; } (ppdefs) ) . "#undef THISIS$this->[1]_$item->[3]\n" . "#define THISIS$this->[1]_$item->[3](a) a\n"; } return "\t} break; case $item->[0]: {\n". $thisis_loop . (join '',map{ # print "DAPAT: '$_'\n"; $parent->{ParObjs}{$_}->get_xsdatapdecl($item->[1]); } (@{$this->[2]})) ; } sub mypostlude { my($this,$parent,$context) = @_; pop @{$parent->{Gencurtype}}; # and clean up the Gentype stack # horrible hack for PDL::PP::NaNSupport if ( $this->[1] ne "" ) { $parent->{pars} = {}; } return "\tbreak;} default:barf(\"PP INTERNAL ERROR! PLEASE MAKE A BUG REPORT\\n\");}\n"; } ########################### # # Encapsulate a threadloop. # There are several different package PDL::PP::ThreadLoop; sub new { return PDL::PP::ComplexThreadLoop->new(@_); } package PDL::PP::SimpleThreadLoop; use Carp; @PDL::PP::SimpleThreadLoop::ISA = "PDL::PP::Block"; our @CARP_NOT; sub new { my($type) = @_; bless [],$type; } sub myoffs { return 0; } sub myprelude {my($this,$parent,$context) = @_; my $no; my ($ord,$pdls) = $parent->get_pdls(); ' PDL_COMMENT("THREADLOOPBEGIN") if(PDL->startthreadloop(&($PRIV(__pdlthread)),$PRIV(vtable)->readdata, __privtrans))) return; do { '.(join '',map {"${_}_datap += \$PRIV(__pdlthread).offs[".(0+$no++)."];\n"} @$ord).' '; } sub mypostlude {my($this,$parent,$context) = @_; my $no; my ($ord,$pdls) = $parent->get_pdls(); ' PDL_COMMENT("THREADLOOPEND") '.(join '',map {"${_}_datap -= \$PRIV(__pdlthread).offs[".(0+$no++)."];\n"} @$ord).' } while(PDL->iterthreadloop(&$PRIV(__pdlthread),0)); ' } #### # # This relies on PP.pm making sure that initthreadloop always sets # up the two first dimensions even when they are not necessary. # package PDL::PP::ComplexThreadLoop; use Carp; @PDL::PP::ComplexThreadLoop::ISA = "PDL::PP::Block"; our @CARP_NOT; sub new { my $type = shift; bless [],$type; } sub myoffs { return 0; } sub myprelude { my($this,$parent,$context, $backcode) = @_; # Set appropriate function from the vtable to supply to threadthreadloop. # Function name from the vtable is readdata for normal code # function name for backcode is writebackdata my $funcName = "readdata"; $funcName = "writebackdata" if( $backcode ); my ($ord,$pdls) = $parent->get_pdls(); join( "\n ", '', 'PDL_COMMENT("THREADLOOPBEGIN")', 'if ( PDL->startthreadloop(&($PRIV(__pdlthread)),$PRIV(vtable)->'.$funcName.', __tr) ) return; do { register PDL_Indx __tind1=0,__tind2=0; register PDL_Indx __tnpdls = $PRIV(__pdlthread).npdls; register PDL_Indx __tdims1 = $PRIV(__pdlthread.dims[1]); register PDL_Indx __tdims0 = $PRIV(__pdlthread.dims[0]); register PDL_Indx *__offsp = PDL->get_threadoffsp(&$PRIV(__pdlthread));', ( map { "register PDL_Indx __tinc0_${_} = \$PRIV(__pdlthread).incs[${_}];"} 0..$#{$ord}), ( map { "register PDL_Indx __tinc1_${_} = \$PRIV(__pdlthread).incs[__tnpdls+$_];"} 0.. $#{$ord}), ( map { $ord->[$_] ."_datap += __offsp[$_];"} 0..$#{$ord} ), 'for( __tind2 = 0 ; __tind2 < __tdims1 ; __tind2++', ( map { "\t\t," . $ord->[$_] . "_datap += __tinc1_${_} - __tinc0_${_} * __tdims0"} 0..$#{$ord} ), ')', '{ for( __tind1 = 0 ; __tind1 < __tdims0 ; __tind1++', ( map { "\t\t," . $ord->[$_] . "_datap += __tinc0_${_}"} 0..$#{$ord}), ')', '{ PDL_COMMENT("This is the tightest threadloop. Make sure inside is optimal.")' ); } # Should possibly fold out thread.dims[0] and [1]. sub mypostlude {my($this,$parent,$context) = @_; my ($ord,$pdls) = $parent->get_pdls(); join( "\n ", '', 'PDL_COMMENT("THREADLOOPEND")', '}', '}', ( map { $ord->[$_] . "_datap -= __tinc1_${_} * __tdims1 + __offsp[${_}];"} 0..$#{$ord} ), '} while(PDL->iterthreadloop(&$PRIV(__pdlthread),2));' ) } # Simple subclass of ComplexThreadLoop to implement writeback code # # package PDL::PP::BackCodeThreadLoop; use Carp; @PDL::PP::BackCodeThreadLoop::ISA = "PDL::PP::ComplexThreadLoop"; our @CARP_NOT; sub myprelude { my($this,$parent,$context, $backcode) = @_; # Set backcode flag if not defined. This will make the parent # myprelude emit proper writeback code $backcode = 1 unless defined($backcode); $this->SUPER::myprelude($parent, $context, $backcode); } ########################### # # Encapsulate a types() switch # # horrible hack: # set $parent->{types} if we create this object so that # PDL::PP::GenericLoop knows to define the THISIS ... macros # package PDL::PP::Types; use Carp; use PDL::Types ':All'; @PDL::PP::Types::ISA = "PDL::PP::Block"; our @CARP_NOT; sub new { my($type,$ts,$parent) = @_; my $types = join '', ppdefs; # BSUL.... $ts =~ /[$types]+/ or confess "Invalid type access with '$ts'!"; $parent->{types} = 1; # hack for PDL::PP::GenericLoop bless [$ts],$type; } sub myoffs { return 1; } sub myprelude { my($this,$parent,$context) = @_; return "\n#if ". (join '||',map {"(THISIS_$_(1)+0)"} split '',$this->[0])."\n"; } sub mypostlude {my($this,$parent,$context) = @_; "\n#endif\n" } ########################### # # Encapsulate an access package PDL::PP::Access; use Carp; our @CARP_NOT; sub new { my($type,$str,$parent) = @_; $str =~ /^\$([a-zA-Z_]\w*)\s*\(([^)]*)\)/ or confess ("Access wrong: '$str'\n"); my($pdl,$inds) = ($1,$2); if($pdl =~ /^T/) {new PDL::PP::MacroAccess($pdl,$inds, $parent->{Generictypes},$parent->{Name});} elsif($pdl =~ /^P$/) {new PDL::PP::PointerAccess($pdl,$inds);} elsif($pdl =~ /^PP$/) {new PDL::PP::PhysPointerAccess($pdl,$inds);} elsif($pdl =~ /^SIZE$/) {new PDL::PP::SizeAccess($pdl,$inds);} elsif($pdl =~ /^RESIZE$/) {new PDL::PP::ReSizeAccess($pdl,$inds);} elsif($pdl =~ /^GENERIC$/) {new PDL::PP::GentypeAccess($pdl,$inds);} elsif($pdl =~ /^PDL$/) {new PDL::PP::PdlAccess($pdl,$inds);} elsif(!defined $parent->{ParObjs}{$pdl}) {new PDL::PP::OtherAccess($pdl,$inds);} else { bless [$pdl,$inds],$type; } } sub get_str { my($this,$parent,$context) = @_; # print "AC: $this->[0]\n"; $parent->{ParObjs}{$this->[0]}->do_access($this->[1],$context) if defined($parent->{ParObjs}{$this->[0]}); } ########################### # # Just some other substituted thing. package PDL::PP::OtherAccess; sub new { my($type,$pdl,$inds) = @_; bless [$pdl,$inds],$type; } sub get_str {my($this) = @_;return "\$$this->[0]($this->[1])"} ########################### # # used by BadAccess code to know when to use NaN support # - the output depends on the value of the # BADVAL_USENAN option in perldl.conf # == 1 then we use NaN's # 0 PDL.bvals.Float/Double # # note the *horrible hack* for piddles whose type have been # specified using the FType option - see GenericLoop. # There MUST be a better way than this... # package PDL::PP::NaNSupport; use PDL::Types ':All'; # typefld et al. # need to be lower-case because of FlagTyped stuff # # need to be able to handle signatures with fixed types # which means parameters like 'int mask()', # which means the hack to add 'int' to %use_nan # my %use_nan = map {(typefld($_,'convertfunc') => typefld($_,'usenan')*$usenan)} typesrtkeys; $use_nan{int} = 0; # original try ##my %use_nan = ## map {(typefld($_,'convertfunc') => typefld($_,'usenan')*$usenan)} typesrtkeys; # Was the following, before new Type "interface" # ( byte => 0, short => 0, ushort => 0, long => 0, # int => 0, longlong => 0, # necessary for fixed-type piddles (or something) # float => $usenan, # double => $usenan # ); my %set_nan = ( float => 'PDL->bvals.Float', PDL_Float => 'PDL->bvals.Float', double => 'PDL->bvals.Double', PDL_Double => 'PDL->bvals.Double', ); sub use_nan ($) { my $type = shift; $type =~ s/^PDL_//; $type = lc $type; die "ERROR: Unknown type [$type] used in a 'Bad' macro." unless exists $use_nan{$type}; return $use_nan{$type}; } sub convert ($$$$$) { my ( $parent, $name, $lhs, $rhs, $opcode ) = @_; my $type = $parent->{Gencurtype}[-1]; die "ERROR: unable to find type info for $opcode access" unless defined $type; # note: gentype may not be sensible because the # actual piddle could have a 'fixed' type die "ERROR: unable to find piddle $name in parent!" unless exists $parent->{ParObjs}{$name}; my $pobj = $parent->{ParObjs}{$name}; # based on code from from PdlParObj::ctype() # - want to handle FlagTplus case # - may not be correct # - extended to include hack to GenericLoop # if ( exists $parent->{pars}{$name} ) { $type = $parent->{pars}{$name}; print "#DBG: hacked <$name> to type <$type>\n" if $::PP_VERBOSE; } elsif ( exists $pobj->{FlagTyped} and $pobj->{FlagTyped} ) { $type = $pobj->{Type}; # this should use Dev.pm - fortunately only worried about double/float here # XXX - do I really know what I'm doing ? if ( $pobj->{FlagTplus} ) { my $gtype = $parent->{Gencurtype}[-1]; if ( $gtype eq "PDL_Double" ) { $type = $gtype if $type ne "double"; } elsif ( $gtype eq "PDL_Float" ) { $type = $gtype if $type !~ /^(float|double)$/; # note: ignore doubles } } } if ( use_nan($type) ) { if ( $opcode eq "SETBAD" ) { # $rhs = "(0.0/0.0)"; $rhs = $set_nan{$type}; } else { $rhs = "0"; $lhs = "finite($lhs)"; } } return ( $lhs, $rhs ); } ########################### # # Encapsulate a check on whether a value is good or bad # handles both checking (good/bad) and setting (bad) # # Integer types (BSUL) + floating point when no NaN (FD) # $ISBAD($a(n)) -> $a(n) == a_badval # $ISGOOD($a()) $a() != a_badval # $SETBAD($a()) $a() = a_badval # # floating point with NaN # $ISBAD($a(n)) -> finite($a(n)) == 0 # $ISGOOD($a()) finite($a()) != 0 # $SETBAD($a()) $a() = PDL->bvals.Float (or .Double) # # I've also got it so that the $ on the pdl name is not # necessary - so $ISBAD(a(n)) is also accepted, so as to reduce the # amount of line noise. This is actually done by the regexp # in the separate_code() sub at the end of the file. # # note: # we also expand out $a(n) etc as well here # # To do: # need to allow use of F,D without NaN # package PDL::PP::BadAccess; use Carp; our @CARP_NOT; sub new { my ( $type, $opcode, $pdl_name, $inds, $parent ) = @_; # trying to avoid auto creation of hash elements my $check = $parent->{ParObjs}; die "\nIt looks like you have tried a \$${opcode}() macro on an\n" . " unknown piddle <$pdl_name($inds)>\n" unless exists($check->{$pdl_name}) and defined($check->{$pdl_name}); return bless [$opcode, $pdl_name, $inds], $type; } our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' ); sub get_str { my($this,$parent,$context) = @_; my $opcode = $this->[0]; my $name = $this->[1]; my $inds = $this->[2]; print "PDL::PP::BadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE; my $op = $ops{$opcode}; die "ERROR: unknown check <$opcode> sent to PDL::PP::BadAccess\n" unless defined $op; my $obj = $parent->{ParObjs}{$name}; die "ERROR: something screwy in PDL::PP::BadAccess (PP/PDLCode.pm)\n" unless defined( $obj ); my $lhs = $obj->do_access($inds,$context); my $rhs = "${name}_badval"; ( $lhs, $rhs ) = PDL::PP::NaNSupport::convert( $parent, $name, $lhs, $rhs, $opcode ); print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE; return "$lhs $op $rhs"; } ########################### # # Encapsulate a check on whether a value is good or bad # handles both checking (good/bad) and setting (bad) # # Integer types (BSUL) + floating point when no NaN (FD) # $ISBADVAR(foo,a) -> foo == a_badval # $ISGOODVAR(foo,a) foo != a_badval # $SETBADVAR(foo,a) foo = a_badval # # floating point with NaN # $ISBADVAR(foo,a) -> finite(foo) == 0 # $ISGOODVAR(foo,a) finite(foo) != 0 # $SETBADVAR(foo,a) foo = PDL->bvals.Float (or .Double) # package PDL::PP::BadVarAccess; use Carp; our @CARP_NOT; sub new { my ( $type, $opcode, $var_name, $pdl_name, $parent ) = @_; # trying to avoid auto creation of hash elements my $check = $parent->{ParObjs}; die "\nIt looks like you have tried a \$${opcode}() macro on an\n" . " unknown piddle <$pdl_name>\n" unless exists($check->{$pdl_name}) and defined($check->{$pdl_name}); bless [$opcode, $var_name, $pdl_name], $type; } our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' ); sub get_str { my($this,$parent,$context) = @_; my $opcode = $this->[0]; my $var_name = $this->[1]; my $pdl_name = $this->[2]; print "PDL::PP::BadVarAccess sent [$opcode] [$var_name] [$pdl_name]\n" if $::PP_VERBOSE; my $op = $ops{$opcode}; die "ERROR: unknown check <$opcode> sent to PDL::PP::BadVarAccess\n" unless defined $op; my $obj = $parent->{ParObjs}{$pdl_name}; die "ERROR: something screwy in PDL::PP::BadVarAccess (PP/PDLCode.pm)\n" unless defined( $obj ); my $lhs = $var_name; my $rhs = "${pdl_name}_badval"; ( $lhs, $rhs ) = PDL::PP::NaNSupport::convert( $parent, $pdl_name, $lhs, $rhs, $opcode ); print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE; return "$lhs $op $rhs"; } ########################### # # Encapsulate a check on whether a value is good or bad using PP # handles both checking (good/bad) and setting (bad) # this is only an initial attempt - it will, almost certainly, # need more work as more code is converted to handle bad values # # currently it can only handle cases like # $PPISBAD(PARENT,[i]) -> PARENT_physdatap[i] == PARENT_badval # etc # # if we use NaN's, then # $PPISBAD(PARENT,[i]) -> finite(PARENT_physdatap[i]) == 0 # $PPISGOOD(PARENT,[i]) -> finite(PARENT_physdatap[i]) != 0 # $PPSETBAD(PARENT,[i]) -> PARENT_physdatap[i] = PDL->bvals.Float (or .Double) # package PDL::PP::PPBadAccess; use Carp; our @CARP_NOT; sub new { my ( $type, $opcode, $pdl_name, $inds, $parent ) = @_; $opcode =~ s/^PP//; bless [$opcode, $pdl_name, $inds], $type; } # PP is stripped in new() our %ops = ( ISBAD => '==', ISGOOD => '!=', SETBAD => '=' ); sub get_str { my($this,$parent,$context) = @_; my $opcode = $this->[0]; my $name = $this->[1]; my $inds = $this->[2]; print "PDL::PP::PPBadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE; my $op = $ops{$opcode}; die "\nERROR: unknown check <$opcode> sent to PDL::PP::PPBadAccess\n" unless defined $op; my $obj = $parent->{ParObjs}{$name}; die "\nERROR: ParObjs does not seem to exist for <$name> = problem in PDL::PP::PPBadAccess\n" unless defined $obj; my $lhs = $obj->do_physpointeraccess() . "$inds"; my $rhs = "${name}_badval"; ( $lhs, $rhs ) = PDL::PP::NaNSupport::convert( $parent, $name, $lhs, $rhs, $opcode ); print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE; return "$lhs $op $rhs"; } ########################### # # Encapsulate a check on whether the state flag of a piddle # is set/change this state # # $PDLSTATEISBAD(a) -> ($PDL(a)->state & PDL_BADVAL) > 0 # $PDLSTATEISGOOD(a) -> ($PDL(a)->state & PDL_BADVAL) == 0 # # $PDLSTATESETBAD(a) -> ($PDL(a)->state |= PDL_BADVAL) # $PDLSTATESETGOOD(a) -> ($PDL(a)->state &= ~PDL_BADVAL) # package PDL::PP::PDLStateBadAccess; use Carp; our @CARP_NOT; sub new { my ( $type, $op, $val, $pdl_name, $parent ) = @_; # $op is one of: IS SET # $val is one of: GOOD BAD # trying to avoid auto creation of hash elements my $check = $parent->{ParObjs}; die "\nIt looks like you have tried a \$PDLSTATE${op}${val}() macro on an\n" . " unknown piddle <$pdl_name>\n" unless exists($check->{$pdl_name}) and defined($check->{$pdl_name}); bless [$op, $val, $pdl_name], $type; } our %ops = ( IS => { GOOD => '== 0', BAD => '> 0' }, SET => { GOOD => '&= ~', BAD => '|= ' }, ); sub get_str { my($this,$parent,$context) = @_; my $op = $this->[0]; my $val = $this->[1]; my $name = $this->[2]; print "PDL::PP::PDLStateBadAccess sent [$op] [$val] [$name]\n" if $::PP_VERBOSE; my $opcode = $ops{$op}{$val}; my $type = $op . $val; die "ERROR: unknown check <$type> sent to PDL::PP::PDLStateBadAccess\n" unless defined $opcode; my $obj = $parent->{ParObjs}{$name}; die "\nERROR: ParObjs does not seem to exist for <$name> = problem in PDL::PP::PDLStateBadAccess\n" unless defined $obj; my $state = $obj->do_pdlaccess() . "->state"; my $str; if ( $op eq 'IS' ) { $str = "($state & PDL_BADVAL) $opcode"; } elsif ( $op eq 'SET' ) { $str = "$state ${opcode}PDL_BADVAL"; } print "DBG: [$str]\n" if $::PP_VERBOSE; return $str; } ########################### # # Encapsulate a Pointeraccess package PDL::PP::PointerAccess; use Carp; our @CARP_NOT; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; croak ("can't access undefined pdl ".$this->[0]) unless defined($parent->{ParObjs}{$this->[0]}); # $parent->{ParObjs}{$this->[0]}->{FlagPaccess} = 1; $parent->{ParObjs}{$this->[0]}->{FlagPhys} = 1; $parent->{ParObjs}{$this->[0]}->do_pointeraccess(); } ########################### # # Encapsulate a PhysPointeraccess package PDL::PP::PhysPointerAccess; use Carp; our @CARP_NOT; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; $parent->{ParObjs}{$this->[0]}->do_physpointeraccess() if defined($parent->{ParObjs}{$this->[0]}); } ########################### # # Encapsulate a PDLaccess package PDL::PP::PdlAccess; use Carp; our @CARP_NOT; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; croak ("can't access undefined pdl ".$this->[0]) unless defined($parent->{ParObjs}{$this->[0]}); $parent->{ParObjs}{$this->[0]}->do_pdlaccess(); } ########################### # # Encapsulate a macroaccess package PDL::PP::MacroAccess; use Carp; use PDL::Types ':All'; my $types = join '',ppdefs; our @CARP_NOT; sub new { my($type,$pdl,$inds,$gentypes,$name) = @_; $pdl =~ /^\s*T([A-Z]+)\s*$/ or confess("Macroaccess wrong: $pdl\n"); my @ilst = split '',$1; for my $gt (@$gentypes) { warn "$name has no Macro for generic type $gt (has $pdl)\n" unless grep {$gt eq $_} @ilst } for my $mtype (@ilst) { warn "Macro for unsupported generic type identifier $mtype". " (probably harmless)\n" unless grep {$mtype eq $_} @$gentypes; } return bless [$pdl,$inds,$name], $type; } sub get_str {my($this,$parent,$context) = @_; my ($pdl,$inds,$name) = @{$this}; $pdl =~ /^\s*T([A-Z]+)\s*$/ or confess("Macroaccess wrong in $name (allowed types $types): was '$pdl'\n"); my @lst = split ',',$inds; my @ilst = split '',$1; if($#lst != $#ilst) {confess("Macroaccess: different nos of args $pdl $inds\n");} croak "generic type access outside a generic loop in $name" unless defined $parent->{Gencurtype}->[-1]; my $type = mapfld $parent->{Gencurtype}->[-1], 'ctype' => 'ppsym'; # print "Type access: $type\n"; croak "unknown Type in $name (generic type currently $parent->{Gencurtype}->[-1]" unless defined $type; for (0..$#lst) { return "$lst[$_]" if $ilst[$_] =~ /$type/; } } ########################### # # Encapsulate a SizeAccess package PDL::PP::SizeAccess; use Carp; our @CARP_NOT; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; croak "can't get SIZE of undefined dimension $this->[0]" unless defined($parent->{IndObjs}{$this->[0]}); $parent->{IndObjs}{$this->[0]}->get_size(); } ########################### # # Encapsulate a ReSizeAccess package PDL::PP::ReSizeAccess; use Carp; our @CARP_NOT; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; $this->[0] =~ /^([^,]+),([^,]+)$/ or croak "Can't interpret resize str $this->[0]"; croak "can't RESIZE undefined dimension $1" unless defined($parent->{IndObjs}{$1}); my $s = $parent->{IndObjs}{$1}->get_size(); # XXX NOTE: All piddles must be output piddles, there must not be # a loop over this var (at all!) etc. Should check for these, # this is why not yet documented. # FURTHER NOTE: RESIZE DOESN'T COPY DATA PROPERLY! my($ord,$pdls) = $parent->get_pdls(); my @p; for(@$ord) { push @p, $_ if $pdls->{$_}->has_dim($1); } print "RESIZEACC: $1 $2, (",(join ',',@p),")\n"; warn "RESIZE USED: DO YOU KNOW WHAT YOU ARE DOING???\n"; return "$s = $2; ".(join '',map {$pdls->{$_}->do_resize($1,$2)} @p); } ########################### # # Encapsulate a GentypeAccess package PDL::PP::GentypeAccess; use Carp; our @CARP_NOT; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; croak "generic type access outside a generic loop" unless defined $parent->{Gencurtype}->[-1]; my $type = $parent->{Gencurtype}->[-1]; if ($this->[0]) { croak "not a defined name" unless defined($parent->{ParObjs}{$this->[0]}); $type = $parent->{ParObjs}{$this->[0]}->ctype($type); } return $type; } ######################## # # Type coercion # # Now, if TYPES:F given and double arguments, will coerce. package PDL::PP::TypeConv; # make the typetable from info in PDL::Types use PDL::Types ':All'; my @typetable = map {[$typehash{$_}->{ppsym}, $typehash{$_}->{ctype}, $typehash{$_}->{numval}, ]} typesrtkeys; sub print_xscoerce { my($this) = @_; $this->printxs("\t__priv->datatype=PDL_B;\n"); # First, go through all the types, selecting the most general. for(@{$this->{PdlOrder}}) { $this->printxs($this->{Pdls}{$_}->get_xsdatatypetest()); } # See which types we are allowed to use. $this->printxs("\tif(0) {}\n"); for(@{$this->get_generictypes()}) { $this->printxs("\telse if(__priv->datatype <= $_->[2]) __priv->datatype = $_->[2];\n"); } $this->{Types} =~ /F/ and ( $this->printxs("\telse if(__priv->datatype == PDL_D) {__priv->datatype = PDL_F; PDL_COMMENT(\"Cast double to float\")}\n")); $this->printxs(qq[\telse {croak("Too high type \%d given!\\n",__priv->datatype);}]); # Then, coerce everything to this type. for(@{$this->{PdlOrder}}) { $this->printxs($this->{Pdls}{$_}->get_xscoerce()); } } # XXX Should use PDL::Core::Dev; no strict 'vars'; # STATIC! sub PDL::PP::get_generictyperecs { my($types) = @_; my $foo; return [map {$foo = $_; ( grep {/$foo->[0]/} (@$types) ) ? [mapfld($_->[0],'ppsym'=>'sym'),$_->[1],$_->[2],$_->[0]] : () } @typetable]; } sub xxx_get_generictypes { my($this) = @_; return [map { $this->{Types} =~ /$_->[0]/ ? [mapfld($_->[0],'ppsym'=>'sym'),$_->[1],$_->[2],$_->[0]] : () } @typetable]; } package PDL::PP::Code; # my ( $threadloops, $coderef, $sizeprivs ) = $this->separate_code( $code ); # # umm, can't call classes defined later on in code ... # hence moved to end of file # (rather ugly...) # # XXX The above statement is almost certainly false. This module is parsed # before separate_code is ever called, so all of the class definitions # should exist. -- David Mertens, Dec 2 2011 # # separates the code into an array of C fragments (strings), # variable references (strings starting with $) and # loops (array references, 1. item = variable. # sub separate_code { ## $DB::single=1; my ( $this, $code ) = @_; # First check for standard code errors: catch_code_errors($code); my $coderef = new PDL::PP::Block; my @stack = ($coderef); my $threadloops = 0; my $sizeprivs = {}; local $_ = $code; ## print "Code to parse = [$_]\n" if $::PP_VERBOSE; while($_) { # Parse next statement # I'm not convinced that having the checks twice is a good thing, # since it makes it easy (for me at least) to forget to update one # of them s/^(.*?) # First, some noise is allowed. This may be bad. ( \$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?[a-zA-Z_]\w*\s*\([^)]*\)\s*\) # $ISBAD($a(..)), ditto for ISGOOD and SETBAD |\$PP(ISBAD|ISGOOD|SETBAD)\s*\(\s*[a-zA-Z_]\w*\s*,\s*[^)]*\s*\) # $PPISBAD(CHILD,[1]) etc ### |\$STATE(IS|SET)(BAD|GOOD)\s*\(\s*[^)]*\s*\) # $STATEISBAD(a) etc |\$PDLSTATE(IS|SET)(BAD|GOOD)\s*\(\s*[^)]*\s*\) # $PDLSTATEISBAD(a) etc |\$[a-zA-Z_]\w*\s*\([^)]*\) # $a(...): access |\bloop\s*\([^)]+\)\s*%\{ # loop(..) %{ |\btypes\s*\([^)]+\)\s*%\{ # types(..) %{ |\bthreadloop\s*%\{ # threadloop %{ |%} # %} |$)//xs or confess("Invalid program $_"); my $control = $2; # Store the user code. # Some day we shall parse everything. push @{$stack[-1]},$1; if ( $control =~ /^\$STATE/ ) { print "\nDBG: - got [$control]\n\n"; } # Then, our control. if($control) { if($control =~ /^loop\s*\(([^)]+)\)\s*%\{/) { my $ob = new PDL::PP::Loop([split ',',$1], $sizeprivs,$this); print "SIZEPRIVSXX: $sizeprivs,",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; push @{$stack[-1]},$ob; push @stack,$ob; } elsif($control =~ /^types\s*\(([^)]+)\)\s*%\{/) { my $ob = new PDL::PP::Types($1,$this); push @{$stack[-1]},$ob; push @stack,$ob; } elsif($control =~ /^threadloop\s*%\{/) { my $ob = new PDL::PP::ThreadLoop(); push @{$stack[-1]},$ob; push @stack,$ob; $threadloops ++; } elsif($control =~ /^\$PP(ISBAD|ISGOOD|SETBAD)\s*\(\s*([a-zA-Z_]\w*)\s*,\s*([^)]*)\s*\)/) { push @{$stack[-1]},new PDL::PP::PPBadAccess($1,$2,$3,$this); } elsif($control =~ /^\$(ISBAD|ISGOOD|SETBAD)VAR\s*\(\s*([^)]*)\s*,\s*([^)]*)\s*\)/) { push @{$stack[-1]},new PDL::PP::BadVarAccess($1,$2,$3,$this); } elsif($control =~ /^\$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?([a-zA-Z_]\w*)\s*\(([^)]*)\)\s*\)/) { push @{$stack[-1]},new PDL::PP::BadAccess($1,$2,$3,$this); # } elsif($control =~ /^\$STATE(IS|SET)(BAD|GOOD)\s*\(\s*([^)]*)\s*\)/) { # push @{$stack[-1]},new PDL::PP::StateBadAccess($1,$2,$3,$this); } elsif($control =~ /^\$PDLSTATE(IS|SET)(BAD|GOOD)\s*\(\s*([^)]*)\s*\)/) { push @{$stack[-1]},new PDL::PP::PDLStateBadAccess($1,$2,$3,$this); } elsif($control =~ /^\$[a-zA-Z_]\w*\s*\([^)]*\)/) { push @{$stack[-1]},new PDL::PP::Access($control,$this); } elsif($control =~ /^%}/) { pop @stack; } else { confess("Invalid control: $control\n"); } } else { print("No \$2!\n") if $::PP_VERBOSE; } } # while: $_ return ( $threadloops, $coderef, $sizeprivs ); } # sub: separate_code() # This is essentially a collection of regexes that look for standard code # errors and croaks with an explanation if they are found. sub catch_code_errors { my $code_string = shift; # Look for constructs like # loop %{ # which is invalid - you need to specify the dimension over which it # should loop report_error('Expected dimension name after "loop" and before "%{"', $1) if $code_string =~ /(.*\bloop\s*%\{)/s; } # Report an error as precisely as possible. If they have #line directives # in the code string, use that in the reporting; otherwise, use standard # Carp mechanisms my $line_re = qr/#\s*line\s+(\d+)\s+"([^"]*)"/; sub report_error { my ($message, $code) = @_; # Just croak if they didn't supply a #line directive: croak($message) if $code !~ $line_re; # Find the line at which the error occurred: my $line = 0; my $filename; LINE: foreach (split /\n/, $code) { $line++; if (/$line_re/) { $line = $1; $filename = $2; } } die "$message at $filename line $line\n"; } # return true 1; PDL-2.018/Basic/Gen/PP/PdlParObj.pm0000644060175006010010000003241713036512174014631 0ustar chmNone############################################## ############################################## package PDL::PP::PdlParObj; use Carp; use PDL::Types; # check for bad value support # use PDL::Config; my $usenan = $PDL::Config{BADVAL_USENAN} || 0; our %Typemap = (); use PDL::Types ':All'; # build a typemap for our translation purposes # again from info in PDL::Types for my $typ (typesrtkeys) { $Typemap{typefld($typ,'ppforcetype')} = { Ctype => typefld($typ,'ctype'), Cenum => typefld($typ,'sym'), Val => typefld($typ,'numval'), }; } # Try to load Text::Balanced my $hasTB = 0; eval q{ use Text::Balanced; $hasTB = 1; }; # split regex $re separated arglist # but ignore bracket-protected bits # (i.e. text that is within matched brackets) # fallback to simple split if we can't find Text::Balanced my $prebrackreg = qr/^([^\(\{\[]*)/; sub splitprotected ($$) { my ($re,$txt) = @_; return split $re, $txt unless $hasTB; return () if !defined $txt || $txt =~ /^\s*$/; my ($got,$pre) = (1,''); my @chunks = (''); my $ct = 0; # infinite loop protection while ($got && $txt =~ /[({\[]/ && $ct++ < 1000) { # print "iteration $ct\n"; ($got,$txt,$pre) = Text::Balanced::extract_bracketed($txt,'{}()[]',$prebrackreg); my @partialargs = split $re, $pre, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs; $chunks[-1] .= $got; } confess "possible infinite parse loop, splitting '$txt' " if $ct >= 1000; my @partialargs = split $re, $txt, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs if @partialargs; # print STDERR "args found: $#chunks\n"; # print STDERR "splitprotected $txt on $re: [",join('|',@chunks),"]\n"; return @chunks; } # null != [0] # - in Core. #{package PDL; # sub isnull { # my $this = shift; # return ($this->getndims==1 && $this->getdim(0)==0) ? 1:0 } #} 1; #__DATA__ # need for $badflag is due to hacked get_xsdatapdecl() # - this should disappear when (if?) things are done sensibly # my $typeregex = join '|', map {typefld($_,'ppforcetype')} typesrtkeys; our $pars_re = qr/^ \s*((?:$typeregex)[+]*|)\s* # $1: first option (?: \[([^]]*)\] # $2: The initial [option] part )?\s* (\w+) # $3: The name \(([^)]*)\) # $4: The indices /x; sub new { my($type,$string,$number,$badflag) = @_; $badflag ||= 0; my $this = bless {Number => $number, BadFlag => $badflag},$type; # Parse the parameter string. Note that the regexes for this match were # originally defined here, but were moved to PDL::PP for FullDoc parsing. $string =~ $pars_re or confess "Invalid pdl def $string (regex $typeregex)\n"; my($opt1,$opt2,$name,$inds) = ($1,$2,$3,$4); map {$_ = '' unless defined($_)} ($opt1,$opt2,$inds); # shut up -w print "PDL: '$opt1', '$opt2', '$name', '$inds'\n" if $::PP_VERBOSE; # Set my internal variables $this->{Name} = $name; $this->{Flags} = [(split ',',$opt2),($opt1?$opt1:())]; for(@{$this->{Flags}}) { /^io$/ and $this->{FlagW}=1 or /^nc$/ and $this->{FlagNCreat}=1 or /^o$/ and $this->{FlagOut}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 or /^oca$/ and $this->{FlagOut}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 and $this->{FlagCreateAlways}=1 or /^t$/ and $this->{FlagTemp}=1 and $this->{FlagCreat}=1 and $this->{FlagW}=1 or /^phys$/ and $this->{FlagPhys} = 1 or /^((?:$typeregex)[+]*)$/ and $this->{Type} = $1 and $this->{FlagTyped} = 1 or confess("Invalid flag $_ given for $string\n"); } # if($this->{FlagPhys}) { # # warn("Warning: physical flag not implemented yet"); # } if ($this->{FlagTyped} && $this->{Type} =~ s/[+]$// ) { $this->{FlagTplus} = 1; } if($this->{FlagNCreat}) { delete $this->{FlagCreat}; delete $this->{FlagCreateAlways}; } my @inds = map{ s/\s//g; # Remove spaces $_; } split ',', $inds; $this->{RawInds} = [@inds]; return $this; } sub name {return (shift)->{Name}} sub add_inds { my($this,$dimsobj) = @_; $this->{IndObjs} = [map {$dimsobj->get_indobj_make($_)} @{$this->{RawInds}}]; my %indcount; $this->{IndCounts} = [ map { 0+($indcount{$_->name}++); } @{$this->{IndObjs}} ]; $this->{IndTotCounts} = [ map { ($indcount{$_->name}); } @{$this->{IndObjs}} ]; } # do the dimension checking for perl level threading # assumes that IndObjs have been created sub perldimcheck { my ($this,$pdl) = @_; croak ("can't create ".$this->name) if $pdl->isnull && !$this->{FlagCreat}; return 1 if $pdl->isnull; my $rdims = @{$this->{RawInds}}; croak ("not enough dimensions for ".$this->name) if ($pdl->threadids)[0] < $rdims; my @dims = $pdl->dims; my ($i,$ind) = (0,undef); for $ind (@{$this->{IndObjs}}) { $ind->add_value($dims[$i++]); } return 0; # not creating } sub finalcheck { my ($this,$pdl) = @_; return [] if $pdl->isnull; my @corr = (); my @dims = $pdl->dims; my ($i,$ind) = (0,undef); for $ind (@{$this->{IndObjs}}) { push @corr,[$i-1,$ind->{Value},$dims[$i-1]] if $dims[$i++] != $ind->{Value}; } return [@corr]; } # get index sizes for a parameter that has to be created sub getcreatedims { my $this = shift; return map { croak "can't create: index size ".$_->name." not initialised" if !defined($_->{Value}) || $_->{Value} < 1; $_->{Value} } @{$this->{IndObjs}}; } # find the value for a given PDL type sub typeval { my $ctype = shift; my @match = grep {$Typemap{$_}->{Ctype} =~ /^$ctype$/} keys(%Typemap); if ($#match < 0) { use Data::Dumper; print Dumper \%Typemap; croak "unknown PDL type '$ctype'" ; } return $Typemap{$match[0]}->{Val}; } # return the PDL type for this pdl sub ctype { my ($this,$generic) = @_; return $generic unless $this->{FlagTyped}; croak "ctype: unknownn type" unless defined($Typemap{$this->{Type}}); my $type = $Typemap{$this->{Type}}->{Ctype}; if ($this->{FlagTplus}) { $type = $Typemap{$this->{Type}}->{Val} > PDL::PP::PdlParObj::typeval($generic) ? $Typemap{$this->{Type}}->{Ctype} : $generic; } return $type; } # return the enum type for a parobj; it'd better be typed sub cenum { my $this = shift; croak "cenum: unknown type [" . $this->{Type} . "]" unless defined($PDL::PP::PdlParObj::Typemap{$this->{Type}}); return $PDL::PP::PdlParObj::Typemap{$this->{Type}}->{Cenum}; } sub get_nname{ my($this) = @_; "(\$PRIV(pdls[$this->{Number}]))"; } sub get_nnflag { my($this) = @_; "(\$PRIV(vtable->per_pdl_flags[$this->{Number}]))"; } # XXX There might be weird backprop-of-changed stuff for [phys]. # # Have changed code to assume that, if(!$this->{FlagCreat}) # then __creating[] will == 0 # -- see make_redodims_thread() in ../PP.pm # sub get_xsnormdimchecks { my($this) = @_; my $pdl = $this->get_nname; my $iref = $this->{IndObjs}; my $ninds = 0+scalar(@$iref); my $str = ""; $str .= "if(!__creating[$this->{Number}]) {\n" if $this->{FlagCreat}; # Dimensional Promotion when number of dims is less than required: # Previous warning message now commented out, # which means we only need include the code if $ninds > 0 # if ( $ninds > 0 ) { $str .= " if(($pdl)->ndims < $ninds) {\n" . join('', map { my $size = $iref->[$_-1]->get_size(); " if (($pdl)->ndims < $_ && $size <= 1) $size = 1;\n" } (1..$ninds)) # XXX why is this here, commented, and not removed? If re-inserted, be sure to use PDL_COMMENT ## ." /* \$CROAK(\"Too few dimensions for argument \'$this->{Name}\'\\n\"); */\n" . " }\n"; } # Now, the real check. my $no = 0; for( @$iref ) { my $siz = $_->get_size(); my $dim = "($pdl)->dims[$no]"; my $ndims = "($pdl)->ndims"; $str .= " if($siz == -1 || ($ndims > $no && $siz == 1)) {\n" . " $siz = $dim;\n" . " } else if($ndims > $no && $siz != $dim) {\n" . # XXX should these lines simply be removed? If re-inserted, be sure to use PDL_COMMENT # " if($dim == 1) {\n" . # " /* Do nothing */ /* XXX Careful, increment? */" . # " } else {\n" . " if($dim != 1) {\n" . " \$CROAK(\"Wrong dims\\n\");\n" . " }\n }\n"; $no++; } $str .= "PDL->make_physical(($pdl));\n" if $this->{FlagPhys}; if ( $this->{FlagCreat} ) { $str .= "} else {\n"; # We are creating this pdl. $str .= " PDL_Indx dims[".($ninds+1)."]; PDL_COMMENT(\"Use ninds+1 to avoid smart (stupid) compilers\")"; $str .= join "", (map {"dims[$_] = ".$iref->[$_]->get_size().";"} 0 .. $#$iref); my $istemp = $this->{FlagTemp} ? 1 : 0; $str .="\n PDL->thread_create_parameter(&\$PRIV(__pdlthread),$this->{Number},dims,$istemp);\n"; $str .= "}"; } return $str; } # sub: get_xsnormdimchecks() sub get_incname { my($this,$ind) = @_; if($this->{IndTotCounts}[$ind] > 1) { "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name).$this->{IndCounts}[$ind]; } else { "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name); } } sub get_incdecls { my($this) = @_; if(scalar(@{$this->{IndObjs}}) == 0) {return "";} (join '',map { "PDL_Indx ".($this->get_incname($_)).";"; } (0..$#{$this->{IndObjs}}) ) . ";" } sub get_incregisters { my($this) = @_; if(scalar(@{$this->{IndObjs}}) == 0) {return "";} (join '',map { "register PDL_Indx ".($this->get_incname($_))." = \$PRIV(". ($this->get_incname($_)).");\n"; } (0..$#{$this->{IndObjs}}) ) } sub get_incdecl_copy { my($this,$fromsub,$tosub) = @_; join '',map { my $iname = $this->get_incname($_); &$fromsub($iname)."=".&$tosub($iname).";"; } (0..$#{$this->{IndObjs}}) } sub get_incsets { my($this,$str) = @_; my $no=0; (join '',map { "if($str->ndims <= $_ || $str->dims[$_] <= 1) \$PRIV(".($this->get_incname($_)).") = 0; else \$PRIV(".($this->get_incname($_)). ") = ".($this->{FlagPhys}? "$str->dimincs[$_];" : "PDL_REPRINC($str,$_);"); } (0..$#{$this->{IndObjs}}) ) } # Print an access part. sub do_access { my($this,$inds,$context) = @_; my $pdl = $this->{Name}; # Parse substitutions into hash my %subst = map {/^\s*(\w+)\s*=>\s*(\S*)\s*$/ or confess "Invalid subst $_\n"; ($1,$2)} splitprotected ',',$inds; # Generate the text my $text; $text = "(${pdl}_datap)"."["; $text .= join '+','0',map { $this->do_indterm($pdl,$_,\%subst,$context); } (0..$#{$this->{IndObjs}}); $text .= "]"; # If not all substitutions made, the user probably made a spelling # error. Barf. if(scalar(keys %subst) != 0) { confess("Substitutions left: ".(join ',',keys %subst)."\n"); } return "$text PDL_COMMENT(\"ACCESS($access)\") "; } sub has_dim { my($this,$ind) = @_; my $h = 0; for(@{$this->{IndObjs}}) { $h++ if $_->name eq $ind; } return $h; } sub do_resize { my($this,$ind,$size) = @_; my @c;my $index = 0; for(@{$this->{IndObjs}}) { push @c,$index if $_->name eq $ind; $index ++; } my $pdl = $this->get_nname; return (join '',map {"$pdl->dims[$_] = $size;\n"} @c). "PDL->resize_defaultincs($pdl);PDL->allocdata($pdl);". $this->get_xsdatapdecl(undef,1); } sub do_pdlaccess { my($this) = @_; return '$PRIV(pdls['.$this->{Number}.'])'; } sub do_pointeraccess { my($this) = @_; return $this->{Name}."_datap"; } sub do_physpointeraccess { my($this) = @_; return $this->{Name}."_physdatap"; } sub do_indterm { my($this,$pdl,$ind,$subst,$context) = @_; # Get informed my $indname = $this->{IndObjs}[$ind]->name; my $indno = $this->{IndCounts}[$ind]; my $indtot = $this->{IndTotCounts}[$ind]; # See if substitutions my $substname = ($indtot>1 ? $indname.$indno : $indname); my $incname = $indname.($indtot>1 ? $indno : ""); my $index; if(defined $subst->{$substname}) {$index = delete $subst->{$substname};} else { # No => get the one from the nearest context. for(reverse @$context) { if($_->[0] eq $indname) {$index = $_->[1]; last;} } } if(!defined $index) {confess "Access Index not found: $pdl, $ind, $indname On stack:".(join ' ',map {"($_->[0],$_->[1])"} @$context)."\n" ;} # return "\$PRIV(".($this->get_incname($ind))."*". $index .")"; # Now we have them in register variables -> no PRIV return ("(".($this->get_incname($ind))."*". "PP_INDTERM(".$this->{IndObjs}[$ind]->get_size().", $index))"); } # XXX hacked to create a variable containing the bad value for # this piddle. # This is a HACK (Doug Burke 07/08/00) # XXX # sub get_xsdatapdecl { my($this,$genlooptype,$asgnonly) = @_; my $type; my $pdl = $this->get_nname; my $flag = $this->get_nnflag; my $name = $this->{Name}; $type = $this->ctype($genlooptype) if defined $genlooptype; my $declini = ($asgnonly ? "" : "\t$type *"); my $cast = ($type ? "($type *)" : ""); # ThreadLoop does this for us. # return "$declini ${name}_datap = ($cast((${_})->data)) + (${_})->offs;\n"; my $str = "$declini ${name}_datap = ($cast(PDL_REPRP_TRANS($pdl,$flag)));\n" . "$declini ${name}_physdatap = ($cast($pdl->data));\n"; # assuming we always need this # - may not be true - eg if $asgnonly ?? # - not needed for floating point types when using NaN as bad values if ( $this->{BadFlag} and $type and ( $usenan == 0 or $type !~ /^PDL_(Float|Double)$/ ) ) { my $cname = $type; $cname =~ s/^PDL_//; $str .= "\t$type ${name}_badval = 0;\n"; $str .= "\tPDL_Anyval ${name}_anyval_badval = PDL->get_pdl_badvalue($pdl);\n"; $str .= "\tANYVAL_TO_CTYPE(${name}_badval, ${type}, ${name}_anyval_badval);\n"; } return "$str\n"; } 1; PDL-2.018/Basic/Gen/PP/Signature.pm0000644060175006010010000000636712562522363014766 0ustar chmNone=head1 NAME PDL::PP::Signature - Internal module to handle signatures =head1 DESCRIPTION Internal module to handle signatures =head1 SYNOPSIS use PDL::PP::Signature; =cut package PDL::PP::Signature; use PDL::PP::PdlParObj; use PDL::PP::Dims; use Carp; use SelfLoader; @ISA = qw/ SelfLoader /; # we pass on $bvalflag to the PdlParObj's created by parse # (a hack for PdlParObj::get_xsdatapdecl() which should # disappear when (if?) things are done sensibly) # sub new { my ($type,$str,$bvalflag) = @_; $bvalflag ||= 0; my ($namep,$objp) = parse($str,$bvalflag); return bless {Names => $namep, Objects => $objp},$type; } *with = \&new; 1; =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu) and by Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut __DATA__ # Eliminate whitespace entries sub nospacesplit {map {/^\s*$/?():$_} split $_[0],$_[1]} sub names { my $this = shift; return $this->{Names}; } sub objs { my $this = shift; return $this->{Objects}; } # Pars -> ParNames, Parobjs sub parse { my($str,$bvalflag) = @_; my @entries = nospacesplit ';',$str; my $number = 0; my %objs; my @names; my $obj; for (@entries) { $obj = PDL::PP::PdlParObj->new($_,"PDL_UNDEF_NUMBER",$bvalflag); push @names,$obj->name; $objs{$obj->name} = $obj; } return (\@names,\%objs,1); } sub realdims { my $this = shift; my @rds = map { scalar @{$this->{Objects}->{$_}->{RawInds}}} @{$this->{Names}}; # print "Realdims are ".join(',',@rds)."\n"; return \@rds; } sub creating { my $this = shift; # my @creat = map { $this->{Objects}->{$_}->{FlagCreat} ? 1:0 } # @{$this->{Names}}; # print "Creating is ".join(',',@creat)."\n"; croak "you must perform a checkdims before calling creating" unless defined $this->{Create}; return $this->{Create}; } sub getinds { my $this = shift; $this->{Dims} = new PDL::PP::PdlDimsObj; for (@{$this->{Names}}) { $this->{Objects}->{$_}->add_inds($this->{Dims}); } } sub resetinds { my $this = shift; for (keys %{$this->{Dims}}) {$this->{Dims}->{$_}->{Value} = undef;} } sub checkdims { my $this = shift; $this->getinds; # we have to recreate to keep defaults currently my $n = @{$this->{Names}}; croak "not enough pdls to match signature" unless $#_ >= $n-1; my @pdls = @_[0..$n-1]; if ($PDL::debug) { print "args: ". join(' ,',map { "[".join(',',$_->dims)."]," } @pdls) . "\n"} my $i = 0; my @creating = map $this->{Objects}->{$_}->perldimcheck($pdls[$i++]), @{$this->{Names}}; $i = 0; for (@{$this->{Names}}) { push @creating, $this->{Objects}->{$_}->getcreatedims if $creating[$i++]; } $this->{Create} = \@creating; $i = 0; my $corr = 0; for (@{$this->{Names}}) { $corr = $this->{Objects}->{$_}->finalcheck($pdls[$i++]); next unless $#$corr>-1; my ($j,$str) = (0,""); for (@$corr) {$str.= ":,"x($_->[0]-$j)."(0),*$_->[1],"; $j=$_->[0]+1 } chop $str; $_[$i-1] = $pdls[$i-1]->slice($str); } } PDL-2.018/Basic/Gen/PP/Struct.pm0000644060175006010010000000012212562522363014270 0ustar chmNone# Just container for many C::Types package C::StructType; package C::StructObj; PDL-2.018/Basic/Gen/PP/SymTab.pm0000644060175006010010000000304312562522363014210 0ustar chmNone# For making sure that no conflicts occur package SymTab; use Carp; sub new { my($type,%ids) = @_; my($this) = bless { Id2Sym => {}, Sym2Id => {}, IsPar => {}, }, $type; $this->add_ids(%ids); $this; } sub add_ids { my($this,%hash) = @_; for(keys %hash) { $this->{Id2Sym}{$_} = $hash{$_}; # This usually sets the 'undef' key to whatever is in $_, because the # object in $hash{$_} is usually a scalar, not an array. I know this # becuase this function is called by AddArgsyms in PDL::PP, which # conructs the %hash to be # # sym_name => sym_name # # The only other place that invokes this code is the constructor, # which itself is called by MkDefSyms in PDL::PP. That invocation is # called with %hash set as # # _PDL_ThisTrans => ["__privtrans",C::Type->new(undef,"$_[0] *foo")] # # AFAIK, Sym2Id is never used anywhere in the code generation, and # the setting of undef throws warning messages, so I am going to # comment-out this line for now. --David Mertens, 12-12-2011 #$this->{Sym2Id}{$hash{$_}->[0]} = $_; } } sub add_params { my($this,%hash) = @_; $this->add_ids(%hash); for(keys %hash) { $this->{IsPar}{$_} = 1; } } sub decl_locals { my($this) = @_; my $str; for(keys %{$this->{Id2Sym}}) { if(!$this->{IsPar}{$_}) { $str .= $this->{Id2Sym}{$_}[1] ->get_decl($this->{Id2Sym}{$_}[0]).";"; } } $str; } sub get_params { } sub get_symname { my($this,$id) = @_; confess "Symbol not found: $id\n" if(!defined($this->{Id2Sym}{$id})); return $this->{Id2Sym}{$id}[0]; } 1; PDL-2.018/Basic/Gen/PP/Var.pm0000644060175006010010000000014112562522363013535 0ustar chmNone package C::Var; # Get one from C::Type; sub alloccode { } sub copycode { } sub freecode { } PDL-2.018/Basic/Gen/PP/XS.pm0000644060175006010010000000034612562522363013346 0ustar chmNonepackage XS; sub mkproto { my($name,$pars) = @_; my $shortpars = join ',',map {$_->[0]} @$pars; my $longpars = join "\n",map {"\t".$_->[1]->get_decl($_->[0])} @$pars; return<new("Name1", "Name2", $ref_to_sub) # where Name1 represents the target of the rule, Name2 the condition, # and the subroutine reference is the routine called when the rule is # applied. # # If their is no condition, the argument can be left out of the call # (unless there is a doc string), so # [["Name1"], [], $ref_to_sub]] # becomes # PDL::PP::Rule->new("Name1", $ref_to_sub) # # The target and conditions can also be an array reference, so # [["Name1"], ["Name2","Name3"], $ref_to_sub]] # [["Name1","Name2"], ["Name3"], $ref_to_sub]] # [["Name1","Name2"], ["Name3","Name4"], $ref_to_sub]] # become, respectively # PDL::PP::Rule->new("Name1", ["Name2","Name3"], $ref_to_sub) # PDL::PP::Rule->new(["Name1","Name2"], "Name3", $ref_to_sub) # PDL::PP::Rule->new(["Name1","Name2"], ["Name3","Name4], $ref_to_sub) # # If the old rule had a document string, this is placed between # the condition and the subroutine reference. To make processing # simpler, if a doc string exists then the condition must also # be supplied, even if it is just [] (ie no condition). # # There are specialized rules for common situations. The rules for the # target, condition, and doc arguments hold from the base class (ie # whether scalar or array values are used, ...) # # Return a constant: # # PDL::PP::Rule::Returns->new($targets [,$conditions [,$doc]], $value) # is used to return a constant. So # [["Name1"], [], sub { "foo" }] # becomes # PDL::PP::Rule::Returns->new("Name1", "foo") # # This class is specialized since there are some common return values: # PDL::PP::Rule::Returns::Zero->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::One->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::EmptyString->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::NULL->new($targets [,$conditions [,$doc]]) # which return 0, 1, "", and "NULL" respectively # # The InsertName class exists to allow you to return something like # "foobar" # The old rules # [["Foo"], ["Name"], sub { return "_pdl_$_[0]_bar"; }] # [["Foo"], ["Name","Arg2"], sub { return "_pdl_$_[0]_bar"; }] # become # PDL::PP::Rule::InsertName->new("Foo", '_pdl_${name}_bar') # PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar') # Note that the Name argument is automatically used as a condition, so # it does not need to be supplied, and the return value should be # given as a single-quoted string and use the $name variable # # The Substitute rule replaces dollar-signed macros ($P(), $ISBAD(), etc) # with the low-level C code to perform the macro. # # The Substitute class replaces the dosubst rule. The old rule # [["NewXSCoerceMustSubs"], ["NewXSCoerceMustSub1","NewXSSymTab","Name"], # \&dosubst] # becomes # PDL::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1") # # PDL::PP::Rule::Substitute->new($target,$condition) # $target and $condition must be scalars. # # Implicit conditions are NewXSSymTab and Name # # The Substitute:Usual class replaces the dousualsubsts rule. The old rule # [["CacheBadFlagInit"], ["CacheBadFlagInitNS","NewXSSymTab","Name"], # \&dousualsubsts], # becomes # PDL::PP::Rule::Substitute::Usual->new("CacheBadFlagInit", "CacheBadFlagInitNS") # # PDL::PP::Rule::Substitute::Usual->new($target, $condition) # $target and $condition must be scalars. # # Implicit conditions are NewXSSymTab and Name # # The MakeComp rule replaces the subst_makecomp routine. The old rule # [["MakeCompiledRepr"], ["MakeComp","CompNames","CompObjs"], # sub {subst_makecomp("COMP",@_)}] # becomes # PDL::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"], # "COMP") # PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol) # $target and $symbol must be scalars. # # Notes: # InsertName could become a subclass of Insert since there are # a few rules that just insert conditions into a text string. # # Substitute, Substitute::Usual, MakeComp classes feel a bit # ugly. See next point. Also the get_std_childparent method is # a bit of a hack. # # DJB thinks that the code fragments themselves could be objects # since they should 'know' what needs doing to them (eg the # substitutions). Not sure whether it would really clarify things. # # To do: # wrap_vfn could propbably be moved into a class. # # move the PDL::PP::Rule and subclasses into their own file? # package PDL::PP::Rule; use strict; require PDL::Core::Dev; use Carp; our @CARP_NOT; my $INVALID_OTHERPARS_RE = qr/^(?:magicno|flags|vtable|freeproc|bvalflag|has_badvalue|badvalue|pdls|__datatype)\z/; use overload ("\"\"" => \&PDL::PP::Rule::stringify); sub stringify { my $self = shift; my $str = ref $self; if ("PDL::PP::Rule" eq $str) { $str = "Rule"; } else { $str =~ s/PDL::PP::Rule:://; } $str = "($str) "; $str .= exists $self->{doc} ? $self->{doc} : join(",", @{$self->{targets}}); return $str; } # Takes two args: the calling object and the message, but we only care # about the message: sub report ($$) { print $_[1] if $::PP_VERBOSE; } # Very limited error checking. # Allow scalars for targets and conditions to be optional # # At present you have to have a conditions argument if you supply # a doc string # # It seems strange to make the subroutine reference an optional # argument but this is being used to transition to a slightly-different # object design # sub new { my $class = shift; my $self = {}; bless $self, $class; my $usage = "Usage: PDL::PP::Rule->new(\$targets[,\$conditions[,\$doc],] [,\$ref])\n"; # handle arguments my $nargs = $#_; die $usage if $nargs < 0 or $nargs > 3; my $targets = shift; $targets = [$targets] unless ref $targets eq "ARRAY"; $self->{targets} = $targets; if ($#_ != -1) { if (ref $_[-1] eq "CODE") { $self->{ref} = pop; } my ($conditions,$doc) = @_; if (defined $conditions) { $conditions = [$conditions] unless ref $conditions eq "ARRAY"; } else { $conditions = []; } $self->{conditions} = $conditions; $self->{doc} = $doc if defined $doc; } return $self; } # $rule->check_if_targets_exist($pars); # # Returns 1 if any of the targets exist in $pars, 0 otherwise. # A return value of 1 means that the rule should not be applied. # # Not 100% happy with use of report here. Needs re-thinking. # sub check_if_targets_exist { my $self = shift; my $pars = shift; my $targets = $self->{targets}; foreach my $target (@$targets) { if (exists $pars->{$target}) { $self->report("--skipping since TARGET $target exists\n"); return 1; } } return 0; } # $rule->check_if_conditions_exist($pars); # # Returns 1 if all of the required conditions exist in $pars, 0 otherwise. # A return value of 0 means that the rule should not be applied. # # Not 100% happy with use of report here. Needs re-thinking. # sub check_if_conditions_exist { my $self = shift; my $pars = shift; my $conditions = $self->{conditions}; foreach my $condition (@$conditions) { # skip if not a required condition next if substr($condition,0,1) eq "_"; unless (exists $pars->{$condition}) { $self->report("--skipping since CONDITION $condition does not exist\n"); return 0; } } return 1; } # $rule->is_valid($pars); # # Returns 1 if the rule should be applied (ie no targets already # exist in $pars and all the required conditions exist in $pars), # otherwise 0. # sub is_valid { my $self = shift; my $pars = shift; return 0 if $self->check_if_targets_exist($pars); return 0 unless $self->check_if_conditions_exist($pars); return 1; } # my @args = $self->extract_args($pars); # # If this method is called we assume that # $self->check_if_conditions_exist($pars) # returns 1. # sub extract_args { my $self = shift; my $pars = shift; my $conditions = $self->{conditions}; my @args; foreach (@$conditions) { # make a copy of each condition so that any changes to it are not # also made to the original array! my $condition = $_; # Remove any possible underscores (which indicate optional conditions): $condition =~ s/^_//; # Note: This will *not* create $pars->{$condition} if it did not already # exist: push @args, $pars->{$condition}; } return @args; } # Apply the rule using the supplied $pars hash reference. # sub apply { my $self = shift; my $pars = shift; carp "Unable to apply rule $self as there is no subroutine reference!" unless exists $self->{ref}; my $targets = $self->{targets}; my $conditions = $self->{conditions}; my $ref = $self->{ref}; $self->report("Applying: $self\n"); # Is the rule valid? # return unless $self->is_valid($pars); # Create the argument array for the routine. # my @args = $self->extract_args($pars); # Run this rule's subroutine: my @retval = $self->{ref}(@args); # Check for any inconsistencies: confess "Internal error: rule '$self' returned " . (1+$#retval) . " items and expected " . (1+$#$targets) unless $#retval == $#$targets; $self->report("--setting:"); foreach my $target (@$targets) { $self->report(" $target"); confess "Cannot have multiple meanings for target $target!" if exists $pars->{$target}; my $result = shift @retval; # The following test suggests that things could/should be # improved in the code generation. # if (defined $result and $result eq 'DO NOT SET!!') { $self->report (" is 'DO NOT SET!!'"); } else { $pars->{$target} = $result; } } $self->report("\n"); } package PDL::PP::Rule::Croak; # Croaks if all of the input variables are defined. Use this to identify # incompatible arguments. our @ISA = qw(PDL::PP::Rule); use Carp; our @CARP_NOT; sub new { croak('Usage: PDL::PP::Ruel::Croak->new(["incompatible", "arguments"], "Croaking message")') unless @_ == 3; my $class = shift; my $self = $class->SUPER::new([], @_); return bless $self, $class; } sub apply { my ($self, $pars) = @_; croak($self->{doc}) if $self->is_valid($pars); } package PDL::PP::Rule::Returns; use strict; use Carp; our @CARP_NOT; ##use PDL::PP::Rule; our @ISA = qw (PDL::PP::Rule); # This class does not treat return values of "DO NOT SET!!" # as special. # sub new { my $class = shift; my $value = pop; my @args = @_; my $self = $class->SUPER::new(@args); bless $self, $class; $self->{"returns.value"} = $value; my $targets = $self->{targets}; croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!" unless $#$targets == 0; return $self; } sub apply { my $self = shift; my $pars = shift; carp "Unable to apply rule $self as there is no return value!" unless exists $self->{"returns.value"}; my $target = $self->{targets}->[0]; $self->report("Applying: $self\n"); # Is the rule valid? # return unless $self->is_valid($pars); # Set the value # $self->report ("--setting: $target\n"); $pars->{$target} = $self->{"returns.value"}; } package PDL::PP::Rule::Returns::Zero; use strict; ##use PDL::PP::Rule::Returns; our @ISA = qw (PDL::PP::Rule::Returns); sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args,0); bless $self, $class; return $self; } package PDL::PP::Rule::Returns::One; use strict; ##use PDL::PP::Rule::Returns; our @ISA = qw (PDL::PP::Rule::Returns); sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args,1); bless $self, $class; return $self; } package PDL::PP::Rule::Returns::EmptyString; use strict; ##use PDL::PP::Rule::Returns; our @ISA = qw (PDL::PP::Rule::Returns); sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args,""); bless $self, $class; return $self; } package PDL::PP::Rule::Returns::NULL; use strict; ##use PDL::PP::Rule::Returns; our @ISA = qw (PDL::PP::Rule::Returns); sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args,"NULL"); bless $self, $class; return $self; } package PDL::PP::Rule::InsertName; use strict; use Carp; our @CARP_NOT; ##use PDL::PP::Rule; our @ISA = qw (PDL::PP::Rule); # This class does not treat return values of "DO NOT SET!!" # as special. # sub new { my $class = shift; my $value = pop; my @args = @_; my $self = $class->SUPER::new(@args); bless $self, $class; $self->{"insertname.value"} = $value; # Generate a defaul doc string unless (exists $self->{doc}) { $self->{doc} = 'Sets ' . $self->{targets}->[0] . ' to "' . $value . '"'; } my $targets = $self->{targets}; croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!" unless $#$targets == 0; # we add "Name" as the first condition # my $conditions = $self->{conditions}; unshift @$conditions, "Name"; return $self; } sub apply { my $self = shift; my $pars = shift; carp "Unable to apply rule $self as there is no return value!" unless exists $self->{"insertname.value"}; $self->report("Applying: $self\n"); # Is the rule valid? # return unless $self->is_valid($pars); # Set the value # my $target = $self->{targets}->[0]; my $name = $pars->{Name}; $self->report ("--setting: $target (name=$name)\n"); $pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";"; } # Poor name. This is the old "dosubst" routine # # PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","NewXSSymTab","Name"], # \&dosubst), # # PDL::PP::Rule::Substitute->new($target,$condition) # $target and $condition must be scalars. # # Implicit conditions are NewXSSymTab and Name # package PDL::PP::Rule::Substitute; use strict; use Carp; our @CARP_NOT; ##use PDL::PP::Rule; our @ISA = qw (PDL::PP::Rule); # Probably want this directly in the apply routine but leave as is for now # sub dosubst_private { my ($src,$symtab,$name) = @_; my $ret = (ref $src ? $src->[0] : $src); my %syms = ( ((ref $src) ? %{$src->[1]} : ()), PRIV => sub {return "".$symtab->get_symname('_PDL_ThisTrans'). "->$_[0]"}, CROAK => sub {return "PDL->pdl_barf(\"Error in $name:\" $_[0])"}, NAME => sub {return $name}, MODULE => sub {return $::PDLMOD}, SETPDLSTATEBAD => sub { return "$_[0]\->state |= PDL_BADVAL"; }, SETPDLSTATEGOOD => sub { return "$_[0]\->state &= ~PDL_BADVAL"; }, ISPDLSTATEBAD => sub { return "(($_[0]\->state & PDL_BADVAL) > 0)"; }, ISPDLSTATEGOOD => sub { return "(($_[0]\->state & PDL_BADVAL) == 0)"; }, BADFLAGCACHE => sub { return "badflag_cache"; }, SETREVERSIBLE => sub { return "if($_[0]) \$PRIV(flags) |= PDL_ITRANS_REVERSIBLE;\n" . " else \$PRIV(flags) &= ~PDL_ITRANS_REVERSIBLE;\n" }, ); while( $ret =~ s/\$(\w+)\(([^()]*)\)/ (defined $syms{$1} or confess("$1 not defined in '$ret'!")) and (&{$syms{$1}}($2))/ge ) {}; $ret; } sub new { my $class = shift; die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);" unless $#_ == 1; my $target = shift; my $condition = shift; die "\$target must be a scalar for PDL::PP::Rule->Substitute" if ref $target; die "\$condition must be a scalar for PDL::PP::Rule->Substitute" if ref $condition; my $self = $class->SUPER::new($target, [$condition, "NewXSSymTab", "Name"], \&dosubst_private); bless $self, $class; return $self; } # Poor name. This is the old "dousualsubsts" routine # # PDL::PP::Rule->new("CacheBadFlagInit", ["CacheBadFlagInitNS","NewXSSymTab","Name"], # \&dousualsubsts), # # PDL::PP::Rule::Substitute::Usual->new($target, $condition) # $target and $condition must be scalars. # # Implicit conditions are NewXSSymTab and Name # # Need to think about @std_childparent as it is also used by # other bits of code. At the moment provide a class method # to access the array but there has to be better ways of # doing this. # package PDL::PP::Rule::Substitute::Usual; use strict; use Carp; our @CARP_NOT; ##use PDL::PP::Rule; our @ISA = qw (PDL::PP::Rule::Substitute); # This is a copy of the main one for now. Need a better solution. # my @std_childparent = ( CHILD => sub {return '$PRIV(pdls[1]->'.(join ',',@_).")"}, PARENT => sub {return '$PRIV(pdls[0]->'.(join ',',@_).")"}, CHILD_P => sub {return '$PRIV(pdls[1]->'.(join ',',@_).")"}, PARENT_P => sub {return '$PRIV(pdls[0]->'.(join ',',@_).")"}, CHILD_PTR => sub {return '$PRIV(pdls[1])'}, PARENT_PTR => sub {return '$PRIV(pdls[0])'}, COMP => sub {return '$PRIV('.(join ',',@_).")"} ); sub get_std_childparent { return @std_childparent; } sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args); bless $self, $class; return $self; } # We modify the arguments from the conditions to include the # extra information # # We simplify the base-class version since we assume that all # conditions are required here. # sub extract_args { my $self = shift; my $pars = shift; # The conditions are [, NewXSSymTab, Name] # my $code = $pars->{$self->{conditions}[0]}; my $symtab = $pars->{$self->{conditions}[1]}; my $name = $pars->{$self->{conditions}[2]}; return ([$code,{@std_childparent}],$symtab,$name); } # Poor name. This is the old "subst_makecomp" routine # # PDL::PP::Rule->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"], # sub {subst_makecomp("COMP",@_)}), # # PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol) # $target and $symbol must be scalars. # package PDL::PP::Rule::MakeComp; use strict; use Carp; our @CARP_NOT; ##use PDL::PP::Rule; our @ISA = qw (PDL::PP::Rule); # This is a copy of the main one for now. Need a better solution. # my @std_redodims = ( SETNDIMS => sub {return "PDL->reallocdims(__it,$_[0])"}, SETDIMS => sub {return "PDL->setdims_careful(__it)"}, SETDELTATHREADIDS => sub {return ' {int __ind; PDL->reallocthreadids($CHILD_PTR(), $PARENT(nthreadids)); for(__ind=0; __ind<$PARENT(nthreadids)+1; __ind++) { $CHILD(threadids[__ind]) = $PARENT(threadids[__ind]) + ('.$_[0].'); } } '}); ##sub get_std_redodims { return @std_redodims; } # Probably want this directly in the apply routine but leave as is for now # sub subst_makecomp_private { my($which,$mc,$cn,$co) = @_; return [$mc,{ # @::std_childparent, PDL::PP::Rule::Substitute::Usual::get_std_childparent(), ($cn ? (('DO'.$which.'DIMS') => sub {return join '', map{$$co{$_}->need_malloc ? $$co{$_}->get_malloc('$PRIV('.$_.')') : ()} @$cn}) : () ), ($which eq "PRIV" ? @std_redodims : ()), }, ]; } sub new { my $class = shift; die "Usage: PDL::PP::Rule::MakeComp->new(\$target,\$conditions,\$symbol);" unless $#_ == 2; my $target = shift; my $condition = shift; my $symbol = shift; die "\$target must be a scalar for PDL::PP::Rule->MakeComp" if ref $target; die "\$symbol must be a scalar for PDL::PP::Rule->MakeComp" if ref $symbol; my $self = $class->SUPER::new($target, $condition, \&subst_makecomp_private); bless $self, $class; $self->{"makecomp.value"} = $symbol; return $self; } # We modify the arguments from the conditions to include the # extra information # # We simplify the base-class version since we assume that all # conditions are required here. # sub extract_args { my $self = shift; my $pars = shift; # The conditions are [, conditions...] # - could use slicing here # my @args = ($self->{"makecomp.value"}); foreach my $condition (@{$self->{conditions}}) { push @args, $pars->{$condition}; } return @args; } package PDL::PP; use strict; our $VERSION = "2.3"; $VERSION = eval $VERSION; use PDL::Types ':All'; use Config; use FileHandle; use Exporter; use Data::Dumper; our @ISA = qw(Exporter); @PDL::PP::EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot pp_add_exported pp_addxs pp_add_isa pp_export_nothing pp_core_importList pp_beginwrap pp_setversion pp_addbegin pp_boundscheck pp_line_numbers pp_deprecate_module/; $PP::boundscheck = 1; $::PP_VERBOSE = 0; $PDL::PP::done = 0; # pp_done has not been called yet END { #you can uncomment this for testing, but this should remain #commented in production code. This causes pp_done to be called #even when a .pd file aborts with die(), potentially bypassing #problem code when build is re-attempted. Having this commented #means we are a bit more strict: a module must call pp_done in #order to have .xs and .pm files written. # pp_done() unless $PDL::PP::done; } use Carp; our @CARP_NOT; # check for bad value support use PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; my $ntypes = $#PDL::Types::names; sub nopm { $::PDLPACK eq 'NONE' } # flag that we don't want to generate a PM sub import { my ($mod,$modname, $packname, $prefix, $callpack) = @_; # Allow for users to not specify the packname ($packname, $prefix, $callpack) = ($modname, $packname, $prefix) if ($packname =~ m|/|); $::PDLMOD=$modname; $::PDLPACK=$packname; $::PDLPREF=$prefix; $::CALLPACK = defined $callpack ? $callpack : $::PDLMOD; $::PDLOBJ = "PDL"; # define pp-funcs in this package $::PDLXS=""; $::PDLBEGIN=""; $::PDLPMROUT=""; for ('Top','Bot','Middle') { $::PDLPM{$_}="" } @::PDLPMISA=('PDL::Exporter', 'DynaLoader'); @::PDL_IFBEGINWRAP = ('',''); $::PDLVERSIONSET = ''; $::PDLMODVERSION = undef; $::DOCUMENTED = 0; $::PDLCOREIMPORT = ""; #import list from core, defaults to everything, i.e. use Core # could be set to () for importing nothing from core. or qw/ barf / for # importing barf only. @_=("PDL::PP"); goto &Exporter::import; } # query/set boundschecking # if on the generated XS code will have optional boundschecking # that can be turned on/off at runtime(!) using # __PACKAGE__::set_boundscheck(arg); # arg should be 0/1 # if off code is speed optimized and no runtime boundschecking # can be performed # ON by default sub pp_boundscheck { my $ret = $PP::boundscheck; $PP::boundscheck = $_[0] if $#_ > -1; return $ret; } sub pp_beginwrap { @::PDL_IFBEGINWRAP = ('BEGIN {','}'); } sub pp_setversion { my ($ver) = @_; $::PDLMODVERSION = '$VERSION'; $::PDLVERSIONSET = "\$$::PDLPACK\::VERSION = $ver;"; } sub pp_addhdr { my ($hdr) = @_; $::PDLXSC .= $hdr; } sub pp_addpm { my $pm = shift; my $pos; if (ref $pm) { my $opt = $pm; $pm = shift; croak "unknown option" unless defined $opt->{At} && $opt->{At} =~ /^(Top|Bot|Middle)$/; $pos = $opt->{At}; } else { $pos = 'Middle'; } $::PDLPM{$pos} .= "$pm\n\n"; } sub pp_add_exported { # my ($this,$exp) = @_; my $exp = join ' ', @_; # get rid of this silly $this argument $::PDLPMROUT .= $exp." "; } sub pp_addbegin { my ($cmd) = @_; if ($cmd =~ /^\s*BOOT\s*$/) { pp_beginwrap; } else { $::PDLBEGIN .= $cmd."\n"; } } # Sub to call to export nothing (i.e. for building OO package/object) sub pp_export_nothing { $::PDLPMROUT = ' '; } sub pp_add_isa { push @::PDLPMISA,@_; } sub pp_add_boot { my ($boot) = @_; $::PDLXSBOOT .= $boot." "; } sub pp_bless{ my($new_package)=@_; $::PDLOBJ = $new_package; } # sub to call to set the import list from core on the 'Use Core' line in the .pm file. # set to '()' to not import anything from Core, or 'qw/ barf /' to import barf. sub pp_core_importList{ $::PDLCOREIMPORT = $_[0]; } sub printxs { shift; $::PDLXS .= join'',@_; } sub pp_addxs { PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n", @_, "\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ\n\n"); } # inserts #line directives into source text. Use like this: # ... # FirstKey => ..., # Code => pp_line_numbers (__LINE__, $a . $b . $c), # OtherKey => ... sub pp_line_numbers ($$) { my ($line, $string) = @_; # The line needs to be incremented by one for the bookkeeping to work $line++; # Get the source filename using caller() my (undef, $filename) = caller; # Escape backslashes: $filename =~ s/\\/\\\\/g; my @to_return = "#line $line \"$filename\""; # Look for threadloops and loops and add # line directives foreach (split (/(\n)/, $string)) { # Always add the current line. push @to_return, $_; # If we need to add a # line directive, do so before incrementing push (@to_return, "\n#line $line \"$filename\"") if (/%\{/ or /%}/); $line++ if /\n/; } return join('', @to_return); } sub printxsc { shift; $::PDLXSC .= join '',@_; } sub pp_done { return if $PDL::PP::done; # do only once! $PDL::PP::done = 1; $::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n\n\n=cut\n\n\n" : ''; print "DONE!\n" if $::PP_VERBOSE; print "Inline running PDL::PP version $PDL::PP::VERSION...\n" if nopm(); (my $fh = FileHandle->new(">$::PDLPREF.xs")) or die "Couldn't open xs file\n"; my $pdl_boot = PDL::Core::Dev::PDL_BOOT('PDL', $::PDLMOD); # don't hardcode in more than one place $fh->print(qq% /* * THIS FILE WAS GENERATED BY PDL::PP! Do not modify! */ #define PDL_COMMENT(comment) PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL ") PDL_COMMENT("autogenerated code. Normally, one would use typical C-style ") PDL_COMMENT("multiline comments (i.e. /* comment */). However, because such ") PDL_COMMENT("comments do not nest, it's not possible for PDL::PP users to ") PDL_COMMENT("comment-out sections of code using multiline comments, as is ") PDL_COMMENT("often the practice when debugging, for example. So, when you ") PDL_COMMENT("see something like this: ") PDL_COMMENT(" ") PDL_COMMENT("Memory access") PDL_COMMENT(" ") PDL_COMMENT("just think of it as a C multiline comment like: ") PDL_COMMENT(" ") PDL_COMMENT(" /* Memory access */ ") #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "pdl.h" #include "pdlcore.h" static Core* PDL; PDL_COMMENT("Structure hold core C functions") static int __pdl_debugging = 0; static int __pdl_boundscheck = 0; static SV* CoreSV; PDL_COMMENT("Gets pointer to perl var holding core structure") #if ! $PP::boundscheck # define PP_INDTERM(max, at) at #else # define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FILE__, __LINE__) : at) #endif $::PDLXSC MODULE = $::PDLMOD PACKAGE = $::PDLMOD PROTOTYPES: ENABLE int set_debugging(i) int i; CODE: RETVAL = __pdl_debugging; __pdl_debugging = i; OUTPUT: RETVAL int set_boundscheck(i) int i; CODE: if (! $PP::boundscheck) warn("Bounds checking is disabled for $::PDLMOD"); RETVAL = __pdl_boundscheck; __pdl_boundscheck = i; OUTPUT: RETVAL MODULE = $::PDLMOD PACKAGE = $::PDLOBJ $::PDLXS BOOT: PDL_COMMENT("Get pointer to structure of core shared C routines") PDL_COMMENT("make sure PDL::Core is loaded") $pdl_boot $::PDLXSBOOT %); unless (nopm) { $::PDLPMISA = "'".join("','",@::PDLPMISA)."'"; $::PDLBEGIN = "BEGIN {\n$::PDLBEGIN\n}" unless $::PDLBEGIN =~ /^\s*$/; ($fh = FileHandle->new(">$::PDLPREF.pm")) or die "Couldn't open pm file\n"; $fh->print(qq% # # GENERATED WITH PDL::PP! Don't modify! # package $::PDLPACK; \@EXPORT_OK = qw( $::PDLPMROUT); \%EXPORT_TAGS = (Func=>[\@EXPORT_OK]); use PDL::Core$::PDLCOREIMPORT; use PDL::Exporter; use DynaLoader; $::PDL_IFBEGINWRAP[0] $::PDLVERSIONSET \@ISA = ( $::PDLPMISA ); push \@PDL::Core::PP, __PACKAGE__; bootstrap $::PDLMOD $::PDLMODVERSION; $::PDL_IFBEGINWRAP[-1] $::PDLBEGIN $::PDLPM{Top} $::FUNCSPOD $::PDLPM{Middle}; $::PDLPM{Bot} # Exit with OK status 1; %); # end of print } # unless (nopm) {... } # end pp_done sub pp_def { my($name,%obj) = @_; print "*** Entering pp_def for $name\n" if $::PP_VERBOSE; # See if the 'name' is multiline, in which case we extract the # name and add the FullDoc field if ($name =~ /\n/) { my $fulldoc = $name; # See if the very first thing is a word. That is going to be the # name of the function under consideration if ($fulldoc =~ s/^(\w+)//) { $name = $1; } elsif ($fulldoc =~ /=head2 (\w+)/) { $name = $1; } else { croak('Unable to extract name'); } $obj{FullDoc} = $fulldoc; } $obj{Name} = $name; translate(\%obj,$PDL::PP::deftbl); print "Output of translate for $name:\n" . Dumper(\%obj) . "\n" if exists $obj{Dump} and $obj{Dump} and $::PP_VERBOSE; croak("ERROR: No FreeFunc for pp_def=$name!\n") unless exists $obj{FreeFunc}; # and $obj{FreeFunc}; PDL::PP->printxsc(join "\n\n",@obj{'StructDecl','RedoDimsFunc', 'CopyFunc', 'ReadDataFunc','WriteBackDataFunc', 'FreeFunc', 'FooFunc', 'VTableDef','NewXSInPrelude', } ); PDL::PP->printxs($obj{NewXSCode}); pp_add_boot($obj{XSBootCode} . $obj{BootSetNewXS}); PDL::PP->pp_add_exported($name); PDL::PP::pp_addpm("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc}; PDL::PP::pp_addpm($obj{PMCode}); PDL::PP::pp_addpm($obj{PMFunc}."\n"); print "*** Leaving pp_def for $name\n" if $::PP_VERBOSE; } # marks this module as deprecated. This handles the user warnings, and adds a # notice into the documentation. Can take a {infavor => "newmodule"} option sub pp_deprecate_module { my $options; if( ref $_[0] eq 'HASH' ) { $options = shift; } else { $options = { @_ }; } my $infavor; if( $options && ref $options eq 'HASH' && $options->{infavor} ) { $infavor = $options->{infavor}; } my $mod = $::PDLMOD; my $envvar = 'PDL_SUPPRESS_DEPRECATION_WARNING__' . uc $mod; $envvar =~ s/::/_/g; my $warning_main = "$mod is deprecated."; $warning_main .= " Please use $infavor instead." if $infavor; my $warning_suppression_runtime = "This module will be removed in the future; please update your code.\n" . "Set the environment variable $envvar\n" . "to suppress this warning\n"; my $warning_suppression_pod = "A warning will be generated at runtime upon a C of this module\n" . "This warning can be suppressed by setting the $envvar\n" . "environment variable\n"; my $deprecation_notice = < 'Top'}, $deprecation_notice ); pp_addpm {At => 'Top'}, < "(char *)SvPV($arg,PL_na)", # short => "(short)SvIV($arg)", # int => "(int)SvIV($arg)", # long => "(long)SvIV($arg)", # double => "(double)SvNV($arg)", # float => "(float)SvNV($arg)", # SV => "$arg", # ); # my $basetype = $type->{Base}; # $basetype =~ s/\s+//g; # get rid of whitespace # # die "Cannot find $basetype in my (small) typemap" unless exists($typemap{$basetype}); # return ($typemap{$basetype}); # } # #--------- END OF THE OLD CODE --------------- # # The code loads the typemap from the Perl typemap using the loading logic of # xsubpp. Do note that I made the assumption that # $Config{}installprivlib}/ExtUtils was the right root directory for the search. # This could break on some systems? # # Also I do _not_ parse the Typemap argument from ExtUtils::MakeMaker because I don't # know how to catch it here! This would be good to fix! It does look for a file # called typemap in the current directory however. # # The parsing of the typemap is mechanical and taken straight from xsubpp and # the resulting hash lookup is then used to convert the input type to the # necessary outputs (as seen in the old code above) # # JB 06/05/05 # sub typemap { my $oname = shift; my $type = shift; my $arg = shift; # # Modification to parse Perl's typemap here. # # The default search path for the typemap taken from xsubpp. It seems it is # necessary to prepend the installprivlib/ExtUtils directory to find the typemap. # It is not clear to me how this is to be done. # my ($typemap, $mode, $junk, $current, %input_expr, %proto_letter, %output_expr, %type_kind); # according to MM_Unix 'privlibexp' is the right directory # seems to work even on OS X (where installprivlib breaks things) # if this does not work portably we should split out the typemap finding code # and make it as complex as necessary + save the typemap location # in the PDL::Config hash my $_rootdir = $Config{privlibexp}.'/ExtUtils/'; # print "_rootdir set to '$_rootdir'\n"; # First the system typemaps.. my @tm = ($_rootdir.'../../../../lib/ExtUtils/typemap', $_rootdir.'../../../lib/ExtUtils/typemap', $_rootdir.'../../lib/ExtUtils/typemap', $_rootdir.'../../../typemap', $_rootdir.'../../typemap', $_rootdir.'../typemap', $_rootdir.'typemap'); # Finally tag onto the end, the current directory typemap. Ideally we should here pick # up the TYPEMAPS flag from ExtUtils::MakeMaker, but a) I don't know how and b) # it is only a slight inconvenience hopefully! # # Note that the OUTPUT typemap is unlikely to be of use here, but I have kept # the source code from xsubpp for tidiness. push @tm, 'typemap'; my $foundtm = 0; foreach $typemap (@tm) { next unless -f $typemap ; # skip directories, binary files etc. warn("Warning: ignoring non-text typemap file '$typemap'\n"), next unless -T $typemap ; $foundtm = 1; open(TYPEMAP, $typemap) or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; $mode = 'Typemap'; $junk = "" ; $current = \$junk; while () { next if /^\s*#/; my $line_no = $. + 1; if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } if ($mode eq 'Typemap') { chomp; my $line = $_ ; TrimWhitespace($_) ; # skip blank lines and comment lines next if /^$/ or /^#/ ; my($t_type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; $t_type = TidyType($t_type) ; $type_kind{$t_type} = $kind ; # prototype defaults to '$' $proto = "\$" unless $proto ; warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") unless ValidProtoString($proto) ; $proto_letter{$t_type} = C_string($proto) ; } elsif (/^\s/) { $$current .= $_; } elsif ($mode eq 'Input') { s/\s+$//; $input_expr{$_} = ''; $current = \$input_expr{$_}; } else { s/\s+$//; $output_expr{$_} = ''; $current = \$output_expr{$_}; } } close(TYPEMAP); } carp "**CRITICAL** PP found no typemap in $_rootdir/typemap; this will cause problems..." unless $foundtm; # # Do checks... # # First reconstruct the type declaration to look up in type_kind my $full_type=TidyType($type->get_decl('')); # Skip the variable name die "The type =$full_type= does not have a typemap entry!\n" unless exists($type_kind{$full_type}); my $typemap_kind = $type_kind{$full_type}; # Look up the conversion from the INPUT typemap. Note that we need to do some # massaging of this. my $input = $input_expr{$typemap_kind}; # Remove all before =: $input =~ s/^(.*?)=\s*//; # This should not be very expensive # Replace $arg with $arg $input =~ s/\$arg/$arg/; # And type with $full_type $input =~ s/\$type/$full_type/; return ($input); } sub identity2priv { return ' int i; $SETNDIMS($PARENT(ndims)); for(i=0; i<$CHILD(ndims); i++) { $CHILD(dims[i]) = $PARENT(dims[i]); } $SETDIMS(); $SETDELTATHREADIDS(0); '; } sub pdimexpr2priv { my($pdimexpr,$hdr,$dimcheck) = @_; $pdimexpr =~ s/\$CDIM\b/i/g; return ' int i,cor; '.$dimcheck.' $SETNDIMS($PARENT(ndims)); $DOPRIVDIMS(); $PRIV(offs) = 0; for(i=0; i<$CHILD(ndims); i++) { cor = '.$pdimexpr.'; $CHILD(dims[i]) = $PARENT(dims[cor]); $PRIV(incs[i]) = $PARENT(dimincs[cor]); } $SETDIMS(); $SETDELTATHREADIDS(0); '; } # something to do with copying values between parent and children # # we can NOT assume that PARENT and CHILD have the same type, # hence the version for bad code # # NOTE: we use the same code for 'good' and 'bad' cases - it's # just that when we use it for 'bad' data, we have to change the # definition of the EQUIVCPOFFS macro - see the Code rule # sub equivcpoffscode { return 'PDL_Indx i; for(i=0; i<$CHILD_P(nvals); i++) { $EQUIVCPOFFS(i,i); }'; } # sub: equivcpoffscode() # Pars -> ParNames, Parobjs # # XXX # - the need for BadFlag is due to hacked get_xsdatapdecl() # in PP/PdlParObj and because the PdlParObjs are created by # PDL::PP::Signature (Doug Burke 07/08/00) sub Pars_nft { my($str,$badflag) = @_; my $sig = PDL::PP::Signature->new($str,$badflag); return ($sig->names,$sig->objs,1); } # ParNames,Parobjs -> DimObjs sub ParObjs_DimObjs { my($pnames,$pobjs) = @_; my ($dimobjs) = PDL::PP::PdlDimsObj->new(); for(@$pnames) { $pobjs->{$_}->add_inds($dimobjs); } return ($dimobjs); } # Eliminate whitespace entries sub nospacesplit {map {/^\s*$/?():$_} split $_[0],$_[1]} sub OtherPars_nft { my($otherpars,$dimobjs) = @_; my(@names,%types,$type); # support 'int ndim => n;' syntax for (nospacesplit ';',$otherpars) { if (/^\s*([^=]+)\s*=>\s*(\S+)\s*$/) { my ($ctype,$dim) = ($1,$2); $ctype =~ s/(\S+)\s+$/$1/; # get rid of trailing ws print "OtherPars: setting dim '$dim' from '$ctype'\n" if $::PP_VERBOSE; $type = C::Type->new(undef,$ctype); croak "can't set unknown dimension" unless defined($dimobjs->{$dim}); $dimobjs->{$dim}->set_from($type); } elsif(/^\s*pdl\s+\*\s*(\w+)$/) { # It is a piddle -> make it a controlling one. die("Not supported yet"); } else { $type = C::Type->new(undef,$_); } my $name = $type->protoname; if ($name =~ /$INVALID_OTHERPARS_RE/) { croak "Invalid OtherPars name: $name"; } push @names,$name; $types{$name} = $type; } return (\@names,\%types); } sub NXArgs { my($parnames,$parobjs,$onames,$oobjs) = @_; my $pdltype = C::Type->new(undef,"pdl *__foo__"); my $nxargs = [ ( map {[$_,$pdltype]} @$parnames ), ( map {[$_,$oobjs->{$_}]} @$onames ) ]; return $nxargs; } # XXX # - the need for BadFlag is due to hacked get_xsdatapdecl() # in PP/PdlParObj and because the PdlParObjs are created by # PDL::PP::Signature (Doug Burke 07/08/00) sub NewParentChildPars { my($p2child,$name,$badflag) = @_; return (Pars_nft("PARENT(); [oca]CHILD();",$badflag),0,"${name}_NN"); } # XXX # - the need for BadFlag is due to hacked get_xsdatapdecl() # in PP/PdlParObj and because the PdlParObjs are created by # PDL::PP::Signature (Doug Burke 07/08/00) # # however, it looks like this isn't being used anymore, # so commenting out. # #sub ParentChildPars { # my($p2child,$name,$badflag) = @_; # return (Pars_nft("PARENT(); [oca]CHILD();",$badflag),0,"${name}_XX", # " # *$name = \\&PDL::$name; # sub PDL::$name { # my \$this = shift; # my \$foo=\$this->null; # PDL::${name}_XX(\$this,\$foo,\@_); # \$foo # } # "); #} sub mkstruct { my($pnames,$pobjs,$comp,$priv,$name) = @_; my $npdls = $#$pnames+1; my $decl = qq{typedef struct $name { PDL_TRANS_START($npdls); $priv $comp char __ddone; PDL_COMMENT("Dims done") } $name;}; return $decl; } sub def_vtable { my($vname,$sname,$rdname,$rfname,$wfname,$cpfname,$ffname, $pnames,$pobjs,$affine_ok,$foofname) = @_; my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames; my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0); my $npdls = scalar @$pnames; my $join_flags = join",",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ? 0 : $aff} 0..$npdls-1; if($Config{cc} eq 'cl') { $join_flags = '""' if $join_flags eq ''; } return "static char ${vname}_flags[] = { ". $join_flags . "}; pdl_transvtable $vname = { 0,0, $nparents, $npdls, ${vname}_flags, $rdname, $rfname, $wfname, $ffname,NULL,NULL,$cpfname, sizeof($sname),\"$vname\" };"; } sub sort_pnobjs { my($pnames,$pobjs) = @_; my (@nn); for(@$pnames) { push ( @nn, $_ ) unless $pobjs->{$_}{FlagW}; } for(@$pnames) { push ( @nn, $_ ) if $pobjs->{$_}{FlagW}; } my $no = 0; for(@nn) { $pobjs->{$_}{Number} = $no++; } return (\@nn,$pobjs); } # XXX __privtrans explicit :( sub wrap_vfn { my($code,$hdrinfo,$rout,$p2child,$name) = @_; my $type = ($name eq "copy" ? "pdl_trans *" : "void"); my $sname = $hdrinfo->{StructName}; my $oargs = ($name eq "foo" ? ",int i1,int i2,int i3" : ""); # print "$rout\_$name: $p2child\n"; my $p2decl = ''; # Put p2child in simple boolean context rather than strict numerical equality if ( $p2child ) { $p2decl = "pdl *__it = ((pdl_trans_affine *)(__tr))->pdls[1]; pdl *__parent = __tr->pdls[0];"; if ( $name eq "redodims" ) { $p2decl .= ' if (__parent->hdrsv && (__parent->state & PDL_HDRCPY)) { PDL_COMMENT("call the perl routine _hdr_copy.") int count; dSP; ENTER ; SAVETMPS ; PUSHMARK(SP) ; XPUSHs( sv_mortalcopy((SV*)__parent->hdrsv) ); PUTBACK ; count = call_pv("PDL::_hdr_copy",G_SCALAR); SPAGAIN ; if(count != 1) croak("PDL::_hdr_copy didn\'t return a single value - please report this bug (B)."); { PDL_COMMENT("convenience block for tmp var") SV *tmp = (SV *) POPs ; __it->hdrsv = (void*) tmp; if(tmp != &PL_sv_undef ) (void)SvREFCNT_inc(tmp); } __it->state |= PDL_HDRCPY; FREETMPS ; LEAVE ; } '; } } # if: $p2child == 1 qq|$type $rout(pdl_trans *__tr $oargs) { int __dim; $sname *__privtrans = ($sname *) __tr; $p2decl { $code } } |; } # sub: wrap_vfn() sub makesettrans { my($pnames,$pobjs,$symtab) = @_; my $trans = $symtab->get_symname('_PDL_ThisTrans'); my $no=0; return (join '',map { "$trans->pdls[".($no++)."] = $_;\n" } @$pnames). "PDL->make_trans_mutual((pdl_trans *)$trans);\n"; } sub CopyOtherPars { my($onames,$otypes,$symtab) = @_; my $repr; my $sname = $symtab->get_symname('_PDL_ThisTrans'); for(@$onames) { $repr .= $otypes->{$_}->get_copy("$_","$sname->$_"); } return $repr; } sub mkxscat { my($glb,$xs_c_headers,$hdr,@bits) = @_; my($boot,$prelude,$str); if($glb) { $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); $boot = $xs_c_headers->[3]; $str = "$hdr\n"; } else { my $xscode = join '' => @bits; $str = "$hdr CODE:\n { $xscode XSRETURN(0);\n}\n\n"; } $str =~ s/(\s*\n)+/\n/g; ($str,$boot,$prelude) } sub mkVarArgsxscat { my($glb,$xs_c_headers,$hdr,@bits) = @_; my($boot,$prelude,$str); if($glb) { $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); $boot = $xs_c_headers->[3]; $str = "$hdr\n"; } else { my $xscode = join '' => @bits; $str = "$hdr \n { $xscode \n}\n\n"; } $str =~ s/(\s*\n)+/\n/g; ($str,$boot,$prelude) } sub MakeNows { my($pnames, $symtab) = @_; my $str = "\n"; for(@$pnames) { $str .= "$_ = PDL->make_now($_);\n"; } return $str; } sub Sym2Loc { return $_[0]->decl_locals(); } sub MkPrivStructInit { my( $symtab, $vtable, $affflag, $nopdlthread ) = @_; my $sname = $symtab->get_symname('_PDL_ThisTrans'); my $ci = ' '; return "\n${ci}$sname = malloc(sizeof(*$sname));\n" . ($nopdlthread ? "" : "${ci}PDL_THR_CLRMAGIC(&$sname->__pdlthread);\n") . "${ci}PDL_TR_SETMAGIC($sname);\n" . "${ci}$sname->flags = $affflag;\n" . "${ci}$sname->__ddone = 0;\n" . "${ci}$sname->vtable = &$vtable;\n" . "${ci}$sname->freeproc = PDL->trans_mallocfreeproc;\n"; } # sub: MkPrivStructInit() sub MkDefSyms { return SymTab->new( _PDL_ThisTrans => ["__privtrans",C::Type->new(undef,"$_[0] *foo")], ); } sub AddArgsyms { my($symtab,$args) = @_; $symtab->add_params( map {($_->[0],$_->[0])} @$args ); return $symtab; } sub indent($$) { my ($text,$ind) = @_; $text =~ s/^(.*)$/$ind$1/mg; return $text; } # This subroutine generates the XS code needed to call the perl 'initialize' # routine in order to create new output PDLs sub callPerlInit { my $names = shift; # names of variables to initialize my $ci = shift; # current indenting my $callcopy = $#_ > -1 ? shift : 0; my $ret = ''; foreach my $name (@$names) { unless ($callcopy) { $ret .= << "EOC"} if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") $name\_SV = sv_newmortal(); $name = PDL->null(); PDL->SetSV_PDL($name\_SV,$name); if (bless_stash) $name\_SV = sv_bless($name\_SV, bless_stash); } else { PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(objname, 0))); PUTBACK; perl_call_method(\"initialize\", G_SCALAR); SPAGAIN; $name\_SV = POPs; PUTBACK; $name = PDL->SvPDLV($name\_SV); } EOC else { $ret .= << "EOD" } if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") $name\_SV = sv_newmortal(); $name = PDL->null(); PDL->SetSV_PDL($name\_SV,$name); if (bless_stash) $name\_SV = sv_bless($name\_SV, bless_stash); } else { /* XXX should these commented lines be removed? See also a 8 lines down */ /* warn("possibly relying on deprecated automatic copy call in derived class\n") warn("please modify your initialize method to avoid future problems\n"); */ PUSHMARK(SP); XPUSHs(parent); PUTBACK; perl_call_method(\"copy\", G_SCALAR); /* perl_call_method(\"initialize\", G_SCALAR); */ SPAGAIN; $name\_SV = POPs; PUTBACK; $name = PDL->SvPDLV($name\_SV); } EOD } # doreach: $name return indent($ret,$ci); } #sub callPerlInit() # This subroutine is called when no 'otherpars' exist. # This writes an XS header which handles variable argument lists, # thus avoiding the perl layer in calling the routine. D. Hunt 4/11/00 # # The use of 'DO NOT SET!!' looks ugly. # # Removing useless use of hasp2child in this function. DCM Sept 12, 2011 sub VarArgsXSHdr { my($name,$xsargs,$parobjs,$optypes,#$hasp2child, $pmcode,$hdrcode,$inplacecode,$globalnew,$callcopy) = @_; # Don't do var args processing if the user has pre-defined pmcode return 'DO NOT SET!!' if ($pmcode); # don't generate a HDR if globalnew is set # globalnew implies internal usage, not XS return undef if $globalnew; my $ci = ' '; # current indenting my $pars = join "\n",map {$ci.$_->[1]->get_decl($_->[0]).";"} @$xsargs; my @args = map { $_->[0] } @$xsargs; my %out = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut}) && !exists($$parobjs{$_}{FlagCreateAlways})} @args; my %outca = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut}) && exists($$parobjs{$_}{FlagCreateAlways})} @args; my %tmp = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagTemp}) } @args; my %other = map { $_ => exists($$optypes{$_}) } @args; # remember, othervars *are* input vars my $nout = (grep { $_ } values %out); my $noutca = (grep { $_ } values %outca); my $nother = (grep { $_ } values %other); my $ntmp = (grep { $_ } values %tmp); my $ntot = @args; my $nmaxonstack = $ntot - $noutca; my $nin = $ntot - ($nout + $noutca + $ntmp); my $ninout = $nin + $nout; my $nallout = $nout + $noutca; my $usageargs = join (",", @args); $ci = ' '; # Current indenting # Generate declarations for SV * variables corresponding to pdl * output variables. # These are used in creating output and temp variables. One variable (ex: SV * outvar1_SV;) # is needed for each output and output create always argument my $svdecls = join ("\n", map { "${ci}SV *${_}_SV;" } grep { $out{$_} || $outca{$_} || $tmp{$_} } @args); my @create = (); # The names of variables which need to be created by calling # the 'initialize' perl routine from the correct package. $ci = ' '; # Current indenting # clause for reading in all variables my $clause1 = ''; my $cnt = 0; foreach my $i ( 0 .. $#args ) { my $x = $args[$i]; if ($other{$x}) { # other par $clause1 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n"; $cnt++; } elsif ($outca{$x}) { push (@create, $x); } else { $clause1 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; $cnt++; } } # Add code for creating output variables via call to 'initialize' perl routine $clause1 .= callPerlInit (\@create, $ci, $callcopy); @create = (); # clause for reading in input and output vars and creating temps my $clause2; # skip this clause if there are no temps if ($nmaxonstack == $ninout) { $clause2 = ''; } else { $clause2 = "\n else if (items == $ninout) { PDL_COMMENT(\"all but temps on stack, read in output, create temps\")" . " nreturn = $noutca;\n"; $cnt = 0; foreach my $i ( 0 .. $#args ) { my $x = $args[$i]; if ($other{$x}) { $clause2 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n"; $cnt++; } elsif ($tmp{$x} || $outca{$x}) { # a temporary or always create variable push (@create, $x); } else { # an input or output variable $clause2 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; $cnt++; } } # Add code for creating output variables via call to 'initialize' perl routine $clause2 .= callPerlInit (\@create, $ci, $callcopy); $clause2 .= "}\n"; @create = (); } # clause for reading in input and creating output and temp vars my $clause3 = ''; $cnt = 0; foreach my $i ( 0 .. $#args ) { my $x = $args[$i]; if ($other{$x}) { $clause3 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n"; $cnt++; } elsif ($out{$x} || $tmp{$x} || $outca{$x}) { push (@create, $x); } else { $clause3 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; $cnt++; } } # Add code for creating output variables via call to 'initialize' perl routine $clause3 .= callPerlInit (\@create, $ci, $callcopy); @create = (); return<[0]}{FlagOut} ! # this will cause $$parobjs{$arg->[0]} to spring into existance even if $$parobjs{$arg->[0]}{FlagOut} # does not exist!! foreach my $arg (@$xsargs) { my $x = $arg->[0]; push (@outs, $x) if (exists ($$parobjs{$x}) and exists ($$parobjs{$x}{FlagOut})); } my $ci = ' '; # Current indenting my $clause1 = ''; foreach my $i ( 0 .. $#outs ) { $clause1 .= "${ci}ST($i) = $outs[$i]_SV;\n"; } return <<"END" if (nreturn) { if (nreturn - items > 0) EXTEND (SP, nreturn - items); $clause1 XSRETURN(nreturn); } else { XSRETURN(0); } END } # sub: VarArgsXSReturn() sub XSCHdrs { my($name,$pars,$gname) = @_; # Hmmm, do we need $shortpars at all? #my $shortpars = join ',',map {$_->[0]} @$pars; my $longpars = join ",",map {$_->[1]->get_decl($_->[0])} @$pars; return ["void $name($longpars) {","}","", "PDL->$gname = $name;"]; } # abstract the access to the bad value status # - means we can easily change the representation without too # many changes # # it's also used in one place in PP/PDLCode.pm # -- there it's hard-coded # sub set_badflag { return '$PRIV(bvalflag) = 1;' . "\n"; } sub clear_badflag { return '$PRIV(bvalflag) = 0;' . "\n"; } sub get_badflag { return '$PRIV(bvalflag)'; } sub get_badflag_priv { return '$PRIV(bvalflag)'; } sub set_badstate { my $pdl = shift; return "\$SETPDLSTATEBAD($pdl)"; } sub clear_badstate { my $pdl = shift; return "\$SETPDLSTATEGOOD($pdl)"; } sub get_badstate { my $pdl = shift; return "\$ISPDLSTATEBAD($pdl)"; } # checks the input piddles to see if the routine # is being any data containing bad values # # if FindBadStatusCode is set, use it, # otherwise create the code automatically. # # - in the automatic code creation, # if $badflag is 0, rather than being undefined, then # we issue a warning if any piddles contain bad values # (and set the bvalflag to 0) # # XXX it looks like output piddles are included in the # check. I *think* this is just wasted code, but I'm # not sure. # sub findbadstatus { my ( $badflag, $badcode, $xsargs, $parobjs, $optypes, $symtab, $name ) = @_; return '' unless $bvalflag; return $badcode if defined $badcode; my $sname = $symtab->get_symname('_PDL_ThisTrans'); my @args = map { $_->[0] } @$xsargs; my %out = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut}) && !exists($$parobjs{$_}{FlagCreateAlways}) } @args; my %outca = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagOut}) && exists($$parobjs{$_}{FlagCreateAlways}) } @args; my %tmp = map { $_ => exists($$parobjs{$_}) && exists($$parobjs{$_}{FlagTemp}) } @args; my %other = map { $_ => exists($$optypes{$_}) } @args; my $clear_bad = clear_badflag(); my $set_bad = set_badflag(); my $get_bad = get_badflag(); my $str = $clear_bad; # set the badflag_cache variable if any input piddle has the bad flag set # my $add = 0; my $badflag_str = " \$BADFLAGCACHE() = "; foreach my $i ( 0 .. $#args ) { my $x = $args[$i]; unless ( $other{$x} or $out{$x} or $tmp{$x} or $outca{$x}) { if ($add) { $badflag_str .= " || "; } else { $add = 1; } $badflag_str .= get_badstate($args[$i]); } } # It is possible, at present, for $add to be 0. I think this is when # the routine has no input piddles, such as fibonacci in primitive.pd, # but there may be other cases. These routines could/should (?) # be marked as NoBadCode to avoid this, or maybe the code here made # smarter. Left as is for now as do not want to add instability into # the 2.4.3 release if I can help it - DJB 23 Jul 2006 # if ($add != 0) { $str .= $badflag_str . ";\n if (\$BADFLAGCACHE()) ${set_bad}\n"; } else { print "\nNOTE: $name has no input bad piddles.\n\n" if $::PP_VERBOSE; } if ( defined($badflag) and $badflag == 0 ) { $str .= " if ( $get_bad ) { printf(\"WARNING: $name does not handle bad values.\\n\"); $clear_bad }\n"; print "\nNOTE: $name does not handle bad values.\n\n" if $::PP_VERBOSE; } # if: $badflag return $str; } # sub: findbadstatus # copies over the bad value state to the output piddles # # if CopyBadStatusCode is set, use it, # otherwise create the code automatically. # # note: this is executed before the trans_mutual call # is made, since the state may be changed by the # Code section # sub copybadstatus { my ( $badflag, $badcode, $xsargs, $parobjs, $symtab ) = @_; ## return '' unless $bvalflag or $badflag == 0; return '' unless $bvalflag; if (defined $badcode) { # realised in 2.4.3 testing that use of $PRIV at this stage is # dangerous since it may have been freed. So I introduced the # $BFLACACHE variable which stores the $PRIV(bvalflag) value # for use here. # For now make the substitution automatic but it will likely become an # error to use $PRIV(bvalflag) here. # if ($badcode =~ m/\$PRIV(bvalflag)/) { $badcode =~ s/\$PRIV(bvalflag)/\$BADFLAGCACHE()/; print "\nPDL::PP WARNING: copybadstatus contains '\$PRIV(bvalflag)'; replace with \$BADFLAGCACHE()\n\n"; } return $badcode; } # names of output variables (in calling order) my @outs; # beware of existance tests like this: $$parobjs{$arg->[0]}{FlagOut} ! # this will cause $$parobjs{$arg->[0]} to spring into existance even if $$parobjs{$arg->[0]}{FlagOut} # does not exist!! foreach my $arg (@$xsargs) { my $x = $arg->[0]; push (@outs, $x) if (exists ($$parobjs{$x}) and exists ($$parobjs{$x}{FlagOut})); } my $sname = $symtab->get_symname('_PDL_ThisTrans'); my $str = ''; # It appears that some code in Bad.xs sets the cache value but then # this bit of code never gets called. Is this an efficiency issue (ie # should we try and optimise away those ocurrences) or does it perform # some purpose? # $str = "if (\$BADFLAGCACHE()) {\n"; foreach my $arg ( @outs ) { $str .= " " . set_badstate($arg) . ";\n"; } $str .= "}\n"; return $str; } # sub: copybadstatus() # insert code, after the autogenerated xs argument processing code # produced by VarArgsXSHdr and AFTER any in HdrCode # - this code flags the routine as working inplace, # # Inplace can be supplied several values # => 1 # assumes fn has an inout and output piddle (eg 'a(); [o] b();') # # => [ 'a' ] # assumes several input piddles in sig, so 'a' labels which # one is to be marked inplace # # => [ 'a', 'b' ] # input piddle is a(), output pidle is 'b' # sub InplaceCode { my ( $ppname, $xsargs, $parobjs, $arg ) = @_; return '' unless defined $arg; # find input and output piddles my ( @in, @out ); foreach my $arg (@$xsargs) { my $name = $arg->[0]; if ( exists $$parobjs{$name} ) { if ( exists $$parobjs{$name}{FlagOut} ) { push @out, $name; } elsif ( ! exists $$parobjs{$name}{FlagTemp} ) { push @in, $name; } } } # handle different values of arg my ( $in, $out ); # default vals - only set if we have one input/output piddle $in = $in[0] if $#in == 0; $out = $out[0] if $#out == 0; if ( ref($arg) eq "ARRAY" ) { my $narg = $#$arg; if ( $narg > -1 ) { $in = $$arg[0]; $out = $$arg[1] if $narg > 0; } } elsif ( ref($arg) eq "" ) { return '' unless $arg; # use default values } else { die "ERROR: Inplace rule [$ppname] must be sent either an array ref or a scalar.\n"; } die "ERROR: Inplace [$ppname] does not know name of input piddle\n" unless defined $in; die "ERROR: Inplace [$ppname] does not know name of output piddle\n" unless defined $out; my $instate = $in . "->state"; return qq{\tif ( $instate & PDL_INPLACE && ($out != $in)) { $instate &= ~PDL_INPLACE; PDL_COMMENT("unset") $out = $in; PDL_COMMENT("discard output value, leak ?") PDL->SetSV_PDL(${out}_SV,${out}); }}, } # sub: InplaceCode # If there is an EquivCPOffsCOde and: # no bad-value support ==> use that # bad value support ==> write a bit of code that does # if ( $PRIV(bvalflag) ) { bad-EquivCPOffsCode } # else { good-EquivCPOffsCode } # # Note: since EquivCPOffsCOde doesn't (or I haven't seen any that # do) use 'loop %{' or 'threadloop %{', we can't rely on # PDLCode to automatically write code like above, hence the # explicit definition here. # # Note: I *assume* that bad-Equiv..Code == good-Equiv..Code *EXCEPT* # that we re-define the meaning of the $EQUIVCPOFFS macro to # check for bad values when copying things over. # This means having to write less code. # # Since PARENT & CHILD need NOT be the same type we cannot just copy # values from one to the other - we have to check for the presence # of bad values, hence the expansion for the $bad code # # Some operators (notably range) also have an out-of-range flag; they use # the macro EQUIVCPTRUNC instead of EQUIVCPOFFS. # $EQUIVCPTRUNC does the same as EQUIVCPOFFS but accepts a child-out-of-bounds # flag. If the out-of-bounds flag is set, the forward code puts BAD/0 into # the child, and reverse code refrains from copying. # --CED 27-Jan-2003 # # sent [EquivCPOffsCode,BadFlag] # # NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block # wart of C preprocessing. They look like statements but sometimes # process into blocks, so if/then/else constructs can get broken. # Either (1) use blocks for if/then/else, or (2) get excited and # use the "do {BLOCK} while(0)" block-to-statement conversion construct # in the substitution. I'm too Lazy. --CED 27-Jan-2003 # sub CodefromEquivCPOffsCode { my $good = shift; my $bflag = shift; my $bad = $good; # parse 'good' code $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = \$PP(PARENT)[$2]/g; $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = ($3) ? 0 : \$PP(PARENT)[$2]/g; my $str = $good; if ( defined $bflag and $bflag ) { # parse 'bad' code $bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g; $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/ if( ($3) || \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else {\$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g; $str = 'if( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'; } return $str; } # sub: CodefromEquivCPOffsCode # this just reverses PARENT & CHILD in the expansion of # the $EQUIVCPOFFS macro (ie compared to CodefromEquivCPOffsCode) # sub BackCodefromEquivCPOffsCode { my $good = shift; my $bflag = shift; my $bad = $good; # parse 'good' code $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(PARENT)[$2] = \$PP(CHILD)[$1]/g; $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) \$PP(PARENT)[$2] = \$PP(CHILD)[$1] /g; my $str = $good; if ( defined $bflag and $bflag ) { # parse 'bad' code $bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; }/g; $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) { if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; } } /g; $str = 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'; } return $str; } # sub: BackCodefromEquivCPOffsCode sub GenDocs { my ($name,$pars,$otherpars,$doc,$baddoc) = @_; # Allow explcit non-doc using Doc=>undef return '' if $doc eq '' && (!defined $doc) && $doc==undef; return '' if $doc =~ /^\s*internal\s*$/i; # remove any 'bad' documentation if we're not compiling support $baddoc = undef unless $bvalflag; # If the doc string is one line let's have to for the # reference card information as well my @splitRes; # temp split variable to get rid of # 'implicit split to @_ is deprecated' messages $doc = "=for ref\n\n".$doc if( scalar(@splitRes = split("\n", $doc)) <= 1); $::DOCUMENTED++; $pars = "P(); C()" unless $pars; # Strip leading whitespace and trailing semicolons and whitespace $pars =~ s/^\s*(.+[^;])[;\s]*$/$1/; $otherpars =~ s/^\s*(.+[^;])[;\s]*$/$1/ if $otherpars; my $sig = "$pars".( $otherpars ? "; $otherpars" : ""); $doc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; # Strip extra =cut's if ( defined $baddoc ) { # Strip leading newlines and any =cut markings $baddoc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; $baddoc =~ s/^\n+//; $baddoc = "=for bad\n\n$baddoc"; } my $baddoc_function_pod = <<"EOD" ; XXX=head2 $name XXX=for sig Signature: ($sig) $doc $baddoc XXX=cut EOD $baddoc_function_pod =~ s/^XXX=/=/gms; return $baddoc_function_pod; } sub ToIsReversible { my($rev) = @_; if($rev eq "1") { '$SETREVERSIBLE(1)' } else { $rev } } sub make_newcoerce { my($ftypes) = @_; join '',map { "$_->datatype = $ftypes->{$_}; " } (keys %$ftypes); } # Assuming that, if HASP2Child is true, we only have # PARENT; CHILD parameters, so we can just take the # datatype to be that of PARENT (which is set up by # find_datatype()). Little bit complicated because # we need to set CHILD's datatype under certain # circumstances # sub coerce_types { my($parnames,$parobjs,$ignore,$newstab,$hasp2child) = @_; # assume [oca]CHILD();, although there might be an ignore if ( $hasp2child ) { my $child = $$parnames[1]; return "" if $ignore->{$child}; die "ERROR: expected $child to be [oca]\n" unless $parobjs->{$child}{FlagCreateAlways}; return "$child\->datatype = \$PRIV(__datatype);\n$child\->has_badvalue = \$PRIV(has_badvalue);\n$child\->badvalue = \$PRIV(badvalue);\n" if $hasp2child; } my $str = ""; foreach ( @$parnames ) { next if $ignore->{$_}; my $po = $parobjs->{$_}; my $dtype; if ( $po->{FlagTyped} ) { $dtype = $po->cenum(); $dtype = "PDLMAX($dtype,\$PRIV(__datatype))" if $po->{FlagTplus}; } else { $dtype = "\$PRIV(__datatype)"; } if ( $po->{FlagCreateAlways} ) { $str .= "$_->datatype = $dtype; "; } else { $str .= "if( ($_->state & PDL_NOMYDIMS) && $_->trans == NULL ) { $_->datatype = $dtype; } else " if $po->{FlagCreat}; $str .= "if($dtype != $_->datatype) { $_ = PDL->get_convertedpdl($_,$dtype); }"; } } # foreach: @$parnames return $str; } # sub: coerce_types() # First, finds the greatest datatype, then, if not supported, takes # the largest type supported by the function. # Not yet optimal. # # Assuming that, if HASP2Child is true, we only have # PARENT; CHILD parameters, so we can just take the # datatype to be that of PARENT (see also coerce_types()) # sub find_datatype { my($parnames,$parobjs,$ignore,$newstab,$gentypes,$hasp2child) = @_; my $dtype = "\$PRIV(__datatype)"; # TODO XXX # the check can probably be removed, but left in since I don't know # what I'm doing (DJB) die "ERROR: gentypes != $ntypes with p2child\n" if $hasp2child and $#$gentypes != $ntypes; return "$dtype = $$parnames[0]\->datatype;\n\$PRIV(has_badvalue) = $$parnames[0]\->has_badvalue;\n\$PRIV(badvalue) = $$parnames[0]\->badvalue;\n" if $hasp2child; my $str = "$dtype = 0;"; foreach ( @$parnames ) { my $po = $parobjs->{$_}; next if $ignore->{$_} or $po->{FlagTyped} or $po->{FlagCreateAlways}; $str .= "if("; $str .= "!(($_->state & PDL_NOMYDIMS) && $_->trans == NULL) && " if $po->{FlagCreat}; $str .= "$dtype < $_->datatype) { $dtype = $_->datatype; }\n"; } # foreach: @$parnames $str .= join '', map { "if($dtype == PDL_$_) {}\nelse " }(@$gentypes); return $str .= "$dtype = PDL_$gentypes->[-1];\n"; } # sub: find_datatype() sub NT2Decls_p {&NT2Decls__({ToPtrs=>1},@_);} sub NT2Copies_p {&NT2Copies__({ToPtrs=>1},@_);} sub NT2Free_p {&NT2Free__({ToPtrs=>1},@_);} sub NT2Decls {&NT2Decls__({},@_);} sub NT2Decls__ { my($opts,$onames,$otypes) = @_; my $decl; my $dopts = {}; $dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs}; for(@$onames) { $decl .= $otypes->{$_}->get_decl($_,$dopts).";"; } return $decl; } sub NT2Copies__ { my($opts,$onames,$otypes,$copyname) = @_; my $decl; my $dopts = {}; $dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs}; for(@$onames) { $decl .= $otypes->{$_}->get_copy("\$PRIV($_)","$copyname->$_", $dopts).";"; } return $decl; } sub NT2Free__ { my($opts,$onames,$otypes) = @_; my $decl; my $dopts = {}; $dopts->{VarArrays2Ptrs} = 1 if $opts->{ToPtrs}; for(@$onames) { $decl .= $otypes->{$_}->get_free("\$PRIV($_)", $dopts).";"; } return $decl; } # The undef is just so that PrivIsInc gets set. Is this really # needed (well, it is since the rule fails if there aren't 2 # return values; what I meant is what does PrivIsInc do for # us?) # sub make_incsizes { my($parnames,$parobjs,$dimobjs,$havethreading) = @_; my $str = ($havethreading?"pdl_thread __pdlthread; ":""). (join '',map {$parobjs->{$_}->get_incdecls} @$parnames). (join '',map {$_->get_decldim} sort values %$dimobjs); return ($str,undef); } sub make_incsize_copy { my($parnames,$parobjs,$dimobjs,$copyname,$havethreading) = @_; ($havethreading? "PDL->thread_copy(&(\$PRIV(__pdlthread)),&($copyname->__pdlthread));" : ""). (join '',map {$parobjs->{$_}->get_incdecl_copy(sub{"\$PRIV($_[0])"}, sub{"$copyname->$_[0]"})} @$parnames). (join '',map {$_->get_copydim(sub{"\$PRIV($_[0])"}, sub{"$copyname->$_[0]"})} sort values %$dimobjs); } sub make_incsize_free { my($parnames,$parobjs,$dimobjs,$havethreading) = @_; $havethreading ? 'PDL->freethreadloop(&($PRIV(__pdlthread)));' : '' } sub make_parnames { my($pnames,$pobjs,$dobjs) = @_; my @pdls = map {$pobjs->{$_}} @$pnames; my $npdls = $#pdls+1; my $join__parnames = join ",",map {qq|"$_"|} @$pnames; my $join__realdims = join ",",map {$#{$_->{IndObjs}}+1} @pdls; if($Config{cc} eq 'cl') { $join__parnames = '""' if $join__parnames eq ''; $join__realdims = '0' if $join__realdims eq ''; } return("static char *__parnames[] = {". $join__parnames ."}; static PDL_Indx __realdims[] = {". $join__realdims . "}; static char __funcname[] = \"\$MODULE()::\$NAME()\"; static pdl_errorinfo __einfo = { __funcname, __parnames, $npdls }; "); } ############################## # # hdrcheck -- examine the various PDLs that form the output PDL, # and copy headers as necessary. The last header found with the hdrcpy # bit set is used. This used to do just a simple ref copy but now # it uses the perl routine PDL::_hdr_copy to do the dirty work. That # routine makes a deep copy of the header. Copies of the deep copy # are distributed to all the names of the piddle that are not the source # of the header. I believe that is the Right Thing to do but I could be # wrong. # # It's hard to read this sort of macro stuff so here's the flow: # - Check the hdrcpy flag. If it's set, then check the header # to see if it exists. If it doees, we need to call the # perl-land PDL::_hdr_copy routine. There are some shenanigans # to keep the return value from evaporating before we've had a # chance to do our bit with it. # - For each output argument in the function signature, try to put # a reference to the new header into that argument's header slot. # (For functions with multiple outputs, this produces multiple linked # headers -- that could be Wrong; fixing it would require making # yet more explicit copies!) # - Remortalize the return value from PDL::_hdr_copy, so that we don't # leak memory. # # --CED 12-Apr-2003 # sub hdrcheck { my ($pnames,$pobjs) = @_; my $nn = $#$pnames; my @names = map { "\$PRIV(pdls[$_])" } 0..$nn; # from make_redodims_thread() we know that __creating[] == 0 unless # ...{FlagCreat} is true # my $str = " { PDL_COMMENT(\"convenience block\") void *hdrp = NULL; char propagate_hdrcpy = 0; SV *hdr_copy = NULL; "; # Find a header among the possible names foreach ( 0 .. $nn ) { my $aux = $pobjs->{$pnames->[$_]}{FlagCreat} ? "!__creating[$_] && \n" : ""; $str .= <<"HdRCHECK1" if(!hdrp && $aux $names[$_]\->hdrsv && ($names[$_]\->state & PDL_HDRCPY) ) { hdrp = $names[$_]\->hdrsv; propagate_hdrcpy = (($names[$_]\->state & PDL_HDRCPY) != 0); } HdRCHECK1 ; } $str .= << 'DeePcOPY' if (hdrp) { if(hdrp == &PL_sv_undef) hdr_copy = &PL_sv_undef; else { PDL_COMMENT("Call the perl routine _hdr_copy...") int count; PDL_COMMENT("Call the perl routine PDL::_hdr_copy(hdrp)") dSP; ENTER ; SAVETMPS ; PUSHMARK(SP) ; XPUSHs( hdrp ); PUTBACK ; count = call_pv("PDL::_hdr_copy",G_SCALAR); SPAGAIN ; if(count != 1) croak("PDL::_hdr_copy didn't return a single value - please report this bug (A)."); hdr_copy = (SV *)POPs; if(hdr_copy && hdr_copy != &PL_sv_undef) { (void)SvREFCNT_inc(hdr_copy); PDL_COMMENT("Keep hdr_copy from vanishing during FREETMPS") } FREETMPS ; LEAVE ; } PDL_COMMENT("end of callback block") DeePcOPY ; # if(hdrp) block is still open -- now reassign all the aliases... # Found the header -- now copy it into all the right places. foreach ( 0 .. $nn ) { $str .= <<"HdRCHECK2" if ( $names[$_]\->hdrsv != hdrp ){ if( $names[$_]\->hdrsv && $names[$_]\->hdrsv != &PL_sv_undef) (void)SvREFCNT_dec( $names[$_]\->hdrsv ); if( hdr_copy != &PL_sv_undef ) (void)SvREFCNT_inc(hdr_copy); $names[$_]\->hdrsv = hdr_copy; } if(propagate_hdrcpy) $names[$_]\->state |= PDL_HDRCPY; HdRCHECK2 # QUESTION: what is the following line doing? # if ( $pobjs->{$pnames->[$_]}{FlagCreat} ); } $str .= ' if(hdr_copy != &PL_sv_undef) SvREFCNT_dec(hdr_copy); PDL_COMMENT("make hdr_copy mortal again") } PDL_COMMENT("end of if(hdrp) block") } PDL_COMMENT("end of conv. block") '; return $str; } # sub: hdrcheck() sub make_redodims_thread { #my($pnames,$pobjs,$dobjs,$dpars,$pcode ) = @_; my($pnames,$pobjs,$dobjs,$dpars,$pcode, $noPthreadFlag) = @_; my $str; my $npdls = @$pnames; $noPthreadFlag = 0 unless( defined $noPthreadFlag ); # assume we can pthread, unless indicated otherwise my $nn = $#$pnames; my @privname = map { "\$PRIV(pdls[$_])" } ( 0 .. $nn ); $str .= $npdls ? "PDL_Indx __creating[$npdls];\n" : "PDL_Indx __creating[1];\n"; $str .= join '',map {$_->get_initdim."\n"} sort values %$dobjs; # if FlagCreat is NOT true, then we set __creating[] to 0 # and we can use this knowledge below, and in hdrcheck() # and in PP/PdlParObj (get_xsnormdimchecks()) # foreach ( 0 .. $nn ) { $str .= "__creating[$_] = "; if ( $pobjs->{$pnames->[$_]}{FlagCreat} ) { $str .= "PDL_CR_SETDIMSCOND(__privtrans,$privname[$_]);\n"; } else { $str .= "0;\n"; } } # foreach: 0 .. $nn $str .= " {\n$pcode\n}\n"; $str .= " {\n " . make_parnames($pnames,$pobjs,$dobjs) . " PDL->initthreadstruct(2,\$PRIV(pdls), __realdims,__creating,$npdls, &__einfo,&(\$PRIV(__pdlthread)), \$PRIV(vtable->per_pdl_flags), $noPthreadFlag ); }\n"; $str .= join '',map {$pobjs->{$_}->get_xsnormdimchecks()} @$pnames; $str .= hdrcheck($pnames,$pobjs); $str .= join '',map {$pobjs->{$pnames->[$_]}-> get_incsets($privname[$_])} 0..$nn; return $str; } # sub: make_redodims_thread() sub XSHdr { my($xsname,$nxargs) = @_; return XS::mkproto($xsname,$nxargs); } ########################################################### # Name : extract_signature_from_fulldoc # Usage : $sig = extract_signature_from_fulldoc($fulldoc) # Purpose : pull out the signature from the fulldoc string # Returns : whatever is in parentheses in the signature, or undef # Parameters : $fulldoc # Throws : never # Notes : the signature must have the following form: # : # : =for sig # : # : Signature: () # : # : # : The two spaces before "Signature" are required, as are # : the parentheses. sub extract_signature_from_fulldoc { my $fulldoc = shift; if ($fulldoc =~ /=for sig\n\n Signature: \(([^\n]*)\n/g) { # Extract the signature and remove the final parenthesis my $sig = $1; $sig .= $1 while $fulldoc =~ /\G\h+([^\n]*)\n/g; $sig =~ s/\)\s*$//; return $sig; } return; } # Build the valid-types regex and valid Pars argument only once. These are # also used in PDL::PP::PdlParObj, which is why they are globally available. use PDL::PP::PdlParObj; my $pars_re = $PDL::PP::PdlParObj::pars_re; ########################################################### # Name : build_pars_from_fulldoc # Usage : $pars = build_pars_from_fulldoc($fulldoc) # Purpose : extract the Pars from the signature from the fulldoc string, # : the part of the signature that specifies the piddles # Returns : a string appropriate for the Pars key # Parameters : $fulldoc # Throws : if there is no signature # : if there is no extractable Pars section # : if some PDL arguments come after the OtherPars arguments start # Notes : This is meant to be used directly in a Rule. Therefore, it # : is only called if the Pars key does not yet exist, so if it # : is not possible to extract the Pars section, it dies. sub build_pars_from_fulldoc { my $fulldoc = shift; # Get the signature or die my $sig = extract_signature_from_fulldoc($fulldoc) or confess('No Pars specified and none could be extracted from FullDoc'); # Everything is semicolon-delimited my @args = split /\s*;\s*/, $sig; my @pars; my $switched_to_other_pars = 0; for my $arg (@args) { confess('All PDL args must come before other pars in FullDoc signature') if $switched_to_other_pars and $arg =~ $pars_re; if ($arg =~ $pars_re) { push @pars, $arg; } else { $switched_to_other_pars = 1; } } # Make sure there's something there confess('FullDoc signature contains no PDL arguments') if @pars == 0; # All done! return join('; ', @pars); } ########################################################### # Name : build_otherpars_from_fulldoc # Usage : $otherpars = build_otherpars_from_fulldoc($fulldoc) # Purpose : extract the OtherPars from the signature from the fulldoc # : string, the part of the signature that specifies non-piddle # : arguments # Returns : a string appropriate for the OtherPars key # Parameters : $fulldoc # Throws : if some OtherPars arguments come before the last PDL argument # Notes : This is meant to be used directly in a Rule. Therefore, it # : is only called if the OtherPars key does not yet exist. sub build_otherpars_from_fulldoc { my $fulldoc = shift; # Get the signature or do not set my $sig = extract_signature_from_fulldoc($fulldoc) or return 'DO NOT SET!!'; # Everything is semicolon-delimited my @args = split /\s*;\s*/, $sig; my @otherpars; for my $arg (@args) { confess('All PDL args must come before other pars in FullDoc signature') if @otherpars > 0 and $arg =~ $pars_re; if ($arg !~ $pars_re) { push @otherpars, $arg; } } # All done! return 'DO NOT SET!!'if @otherpars == 0; return join('; ', @otherpars); } # Set up the rules for translating the pp_def contents. # $PDL::PP::deftbl = [ # used as a flag for many of the routines # ie should we bother with bad values for this routine? # 1 - yes, # 0 - no, maybe issue a warning # undef - we're not compiling with bad value support # PDL::PP::Rule->new("BadFlag", "_HandleBad", "Sets BadFlag based upon HandleBad key and PDL's ability to handle bad values", sub { return (defined $_[0]) ? ($bvalflag and $_[0]) : undef; }), #################### # FullDoc Handling # #################### # Error processing: does FullDoc contain BadDoc, yet BadDoc specified? PDL::PP::Rule::Croak->new(['FullDoc', 'BadDoc'], 'Cannot have both FullDoc and BadDoc defined'), PDL::PP::Rule::Croak->new(['FullDoc', 'Doc'], 'Cannot have both FullDoc and Doc defined'), # Note: no error processing on Pars; it's OK for the docs to gloss over # the details. # Add the Pars section based on the signature of the FullDoc if the Pars # section doesn't already exist PDL::PP::Rule->new('Pars', 'FullDoc', 'Sets the Pars from the FullDoc if Pars is not explicitly specified', \&build_pars_from_fulldoc ), PDL::PP::Rule->new('OtherPars', 'FullDoc', 'Sets the OtherPars from the FullDoc if OtherPars is not explicitly specified', \&build_otherpars_from_fulldoc ), ################################ # Other Documentation Handling # ################################ # no docs by default PDL::PP::Rule::Returns->new("Doc", [], 'Sets the default doc string', "\n=for ref\n\ninfo not available\n"), # try and automate the docs # could be really clever and include the sig to see about # input/output params, for instance PDL::PP::Rule->new("BadDoc", ["BadFlag","Name","_CopyBadStatusCode"], 'Sets the default documentation for handling of bad values', sub { return undef unless $bvalflag; my ( $bf, $name, $code ) = @_; my $str; if ( not defined($bf) ) { $str = "$name does not process bad values.\n"; } elsif ( $bf ) { $str = "$name processes bad values.\n"; } else { $str = "$name ignores the bad-value flag of the input piddles.\n"; } if ( not defined($code) ) { $str .= "It will set the bad-value flag of all output piddles if " . "the flag is set for any of the input piddles.\n"; } elsif ( $code eq '' ) { $str .= "The output piddles will NOT have their bad-value flag set.\n"; } else { $str .= "The state of the bad-value flag of the output piddles is unknown.\n"; } } ), # Default: no otherpars PDL::PP::Rule::Returns::EmptyString->new("OtherPars"), # the docs PDL::PP::Rule->new("PdlDoc", "FullDoc", sub { my $fulldoc = shift; # Remove bad documentation if bad values are not supported $fulldoc =~ s/=for bad\n\n.*?\n\n//s unless $bvalflag; # Append a final cut if it doesn't exist due to heredoc shinanigans $fulldoc .= "\n\n=cut\n" unless $fulldoc =~ /\n=cut\n*$/; # Make sure the =head1 FUNCTIONS section gets added $::DOCUMENTED++; return $fulldoc; } ), PDL::PP::Rule->new("PdlDoc", ["Name","_Pars","OtherPars","Doc","_BadDoc"], \&GenDocs), ################## # Done with Docs # ################## # Notes # Suffix 'NS' means, "Needs Substitution". In other words, the string # associated with a key that has the suffix "NS" must be run through a # Substitute or Substitute::Usual # some defaults # PDL::PP::Rule::Returns->new("CopyName", [], 'Sets the CopyName key to the default: __copy', "__copy"), PDL::PP::Rule->new("DefaultFlowCodeNS", "_DefaultFlow", 'Sets the code to handle dataflow flags, if applicable', sub { $_[0] ? '$PRIV(flags) |= PDL_ITRANS_DO_DATAFLOW_F | PDL_ITRANS_DO_DATAFLOW_B;' : 'PDL_COMMENT("No flow")'}), # Question: where is ppdefs defined? # Answer: Core/Types.pm # PDL::PP::Rule->new("GenericTypes", [], 'Sets GenericTypes flag to all types known to PDL::Types', sub {[ppdefs]}), PDL::PP::Rule->new("ExtraGenericLoops", "FTypes", 'Makes ExtraGenericLoops identical to FTypes if the latter exists and the former does not', sub {return $_[0]}), PDL::PP::Rule::Returns->new("ExtraGenericLoops", [], 'Sets ExtraGenericLoops to an empty hash if it does not already exist', {}), PDL::PP::Rule::InsertName->new("StructName", 'pdl_${name}_struct'), PDL::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'), PDL::PP::Rule->new("FHdrInfo", ["Name","StructName"], sub { return { Name => $_[0], StructName => $_[1], }; }), # Treat exchanges as affines. Affines assumed to be parent->child. # Exchanges may, if the want, handle threadids as well. # Same number of dimensions is assumed, though. # PDL::PP::Rule->new("AffinePriv", "XCHGOnly", sub { return @_; }), PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$CHILD(ndims)];PDL_Indx offs; '), PDL::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDL_ITRANS_ISAFFINE"), PDL::PP::Rule->new("RedoDims", ["EquivPDimExpr","FHdrInfo","_EquivDimCheck"], \&pdimexpr2priv), PDL::PP::Rule->new("RedoDims", ["Identity","FHdrInfo"], \&identity2priv), # NOTE: we use the same bit of code for all-good and bad data - # see the Code rule # PDL::PP::Rule->new("EquivCPOffsCode", "Identity", "something to do with dataflow between CHILD & PARENT, I think.", \&equivcpoffscode), PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"], "create Code from EquivCPOffsCode", \&CodefromEquivCPOffsCode), PDL::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"], "create BackCode from EquivCPOffsCode", \&BackCodefromEquivCPOffsCode), PDL::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"), PDL::PP::Rule::Returns::One->new("Affine_Ok"), PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"), PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"), PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'), PDL::PP::Rule::InsertName->new("CopyFuncName", 'pdl_${name}_copy'), PDL::PP::Rule::InsertName->new("FreeFuncName", 'pdl_${name}_free'), PDL::PP::Rule::InsertName->new("RedoDimsFuncName", 'pdl_${name}_redodims'), # There used to be a BootStruct rule which just became copied to the XSBootCode # rule, so it has been removed. # PDL::PP::Rule->new("XSBootCode", ["AffinePriv","VTableName"], sub {return " $_[1].readdata = PDL->readdata_affine;\n" . " $_[1].writebackdata = PDL->writebackdata_affine;\n"}), # Parameters in the form 'parent and child(this)'. # The names are PARENT and CHILD. # # P2Child implicitly means "no data type changes". PDL::PP::Rule->new(["USParNames","USParObjs","FOOFOONoConversion","HaveThreading","NewXSName"], ["P2Child","Name","BadFlag"], \&NewParentChildPars), PDL::PP::Rule::InsertName->new("NewXSName", '_${name}_int'), PDL::PP::Rule::Returns->new("EquivPThreadIdExpr", "P2Child", '$CTID-$PARENT(ndims)+$CHILD(ndims)'), PDL::PP::Rule::Returns::One->new("HaveThreading"), # Parameters in the 'a(x,y); [o]b(y)' format, with # fixed nos of real, unthreaded-over dims. # # XXX # - the need for BadFlag is due to hacked get_xsdatapdecl() # in PP/PdlParObj and because the PdlParObjs are created by # PDL::PP::Signature (Doug Burke 07/08/00) PDL::PP::Rule->new(["USParNames","USParObjs","DimmedPars"], ["Pars","BadFlag"], \&Pars_nft), PDL::PP::Rule->new("DimObjs", ["USParNames","USParObjs"], \&ParObjs_DimObjs), # Set CallCopy flag for simple functions (2-arg with 0-dim signatures) # This will copy the $object->copy method, instead of initialize # for PDL-subclassed objects # PDL::PP::Rule->new("CallCopy", ["DimObjs", "USParNames", "USParObjs", "Name", "_P2Child"], sub { my ($dimObj, $USParNames, $USParObjs, $Name, $hasp2c) = @_; return 0 if $hasp2c; my $noDimmedArgs = scalar(keys %$dimObj); my $noArgs = scalar(@$USParNames); if( $noDimmedArgs == 0 and $noArgs == 2 ){ # Check for 2-arg functgion with 0-dim signatures # Check to see if output arg is _not_ explicitly typed: my $arg2 = $USParNames->[1]; my $ParObj = $USParObjs->{$arg2}; if( $ParObj->ctype('generic') eq 'generic'){ # print "Calling Copy for function '$Name'\n"; return 1; } } return 0; }), # "Other pars", the parameters which are usually not pdls. PDL::PP::Rule->new(["OtherParNames","OtherParTypes"], ["OtherPars","DimObjs"], \&OtherPars_nft), PDL::PP::Rule->new(["ParNames","ParObjs"], ["USParNames","USParObjs"], \&sort_pnobjs), PDL::PP::Rule->new("DefSyms", "StructName", \&MkDefSyms), PDL::PP::Rule->new("NewXSArgs", ["USParNames","USParObjs","OtherParNames","OtherParTypes"], \&NXArgs), PDL::PP::Rule::Returns->new("PMCode", undef), PDL::PP::Rule->new("NewXSSymTab", ["DefSyms","NewXSArgs"], \&AddArgsyms), PDL::PP::Rule->new("InplaceCode", ["Name","NewXSArgs","USParObjs","_Inplace"], 'Insert code (just after HdrCode) to ensure the routine can be done inplace', \&InplaceCode), PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], 'Code that will be inserted at the end of the autogenerated xs argument processing code VargArgsXSHdr'), # Create header for variable argument list. Used if no 'other pars' specified. # D. Hunt 4/11/00 # make sure it is not used when the GlobalNew flag is set ; CS 4/15/00 PDL::PP::Rule->new("VarArgsXSHdr", ["Name","NewXSArgs","USParObjs","OtherParTypes", "PMCode","HdrCode","InplaceCode","_GlobalNew","_CallCopy"], 'XS code to process arguments on stack based on supplied Pars argument to pp_def; GlobalNew has implications how/if this is done', \&VarArgsXSHdr), ## Added new line for returning (or not returning) variables. D. Hunt 4/7/00 # make sure it is not used when the GlobalNew flag is set ; CS 4/15/00 # PDL::PP::Rule->new("VarArgsXSReturn", ["NewXSArgs","USParObjs","_GlobalNew"], "Generate XS trailer for returning output variables", \&VarArgsXSReturn), PDL::PP::Rule->new("NewXSHdr", ["NewXSName","NewXSArgs"], \&XSHdr), PDL::PP::Rule->new("NewXSCHdrs", ["NewXSName","NewXSArgs","GlobalNew"], \&XSCHdrs), PDL::PP::Rule->new("NewXSLocals", "NewXSSymTab", \&Sym2Loc), PDL::PP::Rule::Returns::Zero->new("IsAffineFlag"), PDL::PP::Rule::Returns::Zero->new("NoPdlThread"), # hmm, need to check on conditional check here (or rather, other bits of code prob need # to include it too; see Ops.xs, PDL::assgn) ## ## sub { return (defined $_[0]) ? "int \$BADFLAGCACHE() = 0;" : ""; } ], ## ## why have I got a "_HandleBad" condition here? it isn't used in the routine ## and isn't required to fire the rule. Or should we actually check the value of ## HandleBad (ie to optimize for code that explicitly doesn't handle bad code)? ## TO DO: Check assgn in ops for this? Not obvious, or at least we need other ## bits of code work with us (eg the checking of $BADFLAGCACHE in some other ## rule) ## ## PDL::PP::Rule->new("CacheBadFlagInitNS", "_HandleBad", ## sub { return $bvalflag ? "\n int \$BADFLAGCACHE() = 0;\n" : ""; }), PDL::PP::Rule->new("CacheBadFlagInitNS", sub { return $bvalflag ? "\n int \$BADFLAGCACHE() = 0;\n" : ""; }), # The next rule, if done in place of the above, causes Ops.xs to fail to compile # PDL::PP::Rule->new("CacheBadFlagInitNS", "BadFlag", # sub { return $_[0] ? "\n int \$BADFLAGCACHE() = 0;\n" : ""; }), PDL::PP::Rule::Substitute::Usual->new("CacheBadFlagInit", "CacheBadFlagInitNS"), # need special cases for # a) bad values # b) bad values + GlobalNew # c) bad values + PMCode # - perhaps I should have separate rules (but b and c produce the # same output...) # PDL::PP::Rule->new("NewXSStructInit0", ["NewXSSymTab","VTableName","IsAffineFlag","NoPdlThread"], "Rule to create and initialise the private trans structure", \&MkPrivStructInit), PDL::PP::Rule->new("NewXSMakeNow", ["ParNames","NewXSSymTab"], \&MakeNows), PDL::PP::Rule->new("IgnoreTypesOf", "FTypes", sub {return {map {($_,1)} keys %{$_[0]}}}), PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}), PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes", \&make_newcoerce), PDL::PP::Rule::Substitute::Usual->new("NewXSCoerceMust", "NewXSCoerceMustNS"), PDL::PP::Rule::Substitute::Usual->new("DefaultFlowCode", "DefaultFlowCodeNS"), PDL::PP::Rule->new("NewXSFindDatatypeNS", ["ParNames","ParObjs","IgnoreTypesOf","NewXSSymTab","GenericTypes","_P2Child"], \&find_datatype), PDL::PP::Rule::Substitute::Usual->new("NewXSFindDatatype", "NewXSFindDatatypeNS"), PDL::PP::Rule::Returns::EmptyString->new("NewXSTypeCoerce", "NoConversion"), PDL::PP::Rule->new("NewXSTypeCoerceNS", ["ParNames","ParObjs","IgnoreTypesOf","NewXSSymTab","_P2Child"], \&coerce_types), PDL::PP::Rule::Substitute::Usual->new("NewXSTypeCoerce", "NewXSTypeCoerceNS"), PDL::PP::Rule::Returns::EmptyString->new("NewXSStructInit1", ["ParNames","NewXSSymTab"]), PDL::PP::Rule->new("NewXSSetTrans", ["ParNames","ParObjs","NewXSSymTab"], \&makesettrans), PDL::PP::Rule->new("ParsedCode", ["Code","_BadCode","ParNames","ParObjs","DimObjs","GenericTypes", "ExtraGenericLoops","HaveThreading","Name"], sub { return PDL::PP::Code->new(@_); }), PDL::PP::Rule->new("ParsedBackCode", ["BackCode","_BadBackCode","ParNames","ParObjs","DimObjs","GenericTypes", "ExtraGenericLoops","HaveThreading","Name"], sub { return PDL::PP::Code->new(@_, undef, undef, 'BackCode2'); }), # Compiled representations i.e. what the xsub function leaves # in the trans structure. By default, copies of the parameters # but in many cases (e.g. slice) a benefit can be obtained # by parsing the string in that function. # If the user wishes to specify his own code and compiled representation, # The next two definitions allow this. # Because of substitutions that will be there, # makecompiledrepr et al are array refs, 0th element = string, # 1th element = hashref of translated names # This makes the objects: type + ... # PDL::PP::Rule->new(["CompNames","CompObjs"], "Comp", \&OtherPars_nft), PDL::PP::Rule->new("CompiledRepr", ["CompNames","CompObjs"], \&NT2Decls_p), PDL::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompNames","CompObjs"], "COMP"), PDL::PP::Rule->new("CompCopyCode", ["CompNames","CompObjs","CopyName"], \&NT2Copies_p), PDL::PP::Rule->new("CompFreeCode", ["CompNames","CompObjs"], \&NT2Free_p), # This is the default # PDL::PP::Rule->new("MakeCompiledRepr", ["OtherParNames","OtherParTypes","NewXSSymTab"], \&CopyOtherPars), PDL::PP::Rule->new("CompiledRepr", ["OtherParNames","OtherParTypes"], \&NT2Decls), PDL::PP::Rule->new("CompCopyCode", ["OtherParNames","OtherParTypes","CopyName"], \&NT2Copies_p), PDL::PP::Rule->new("CompFreeCode", ["OtherParNames","OtherParTypes"], \&NT2Free_p), # Threads # PDL::PP::Rule->new(["Priv","PrivIsInc"], ["ParNames","ParObjs","DimObjs","HaveThreading"], \&make_incsizes), PDL::PP::Rule->new("PrivCopyCode", ["ParNames","ParObjs","DimObjs","CopyName","HaveThreading"], \&make_incsize_copy), PDL::PP::Rule->new("PrivFreeCode", ["ParNames","ParObjs","DimObjs","HaveThreading"], "Frees the thread", \&make_incsize_free), PDL::PP::Rule::Returns->new("RedoDimsCode", [], 'Code that can be inserted to set the size of output piddles dynamically based on input piddles; is parsed', 'PDL_COMMENT("none")'), PDL::PP::Rule->new("RedoDimsParsedCode", ["RedoDimsCode","_BadRedoDimsCode","ParNames","ParObjs","DimObjs", "GenericTypes","ExtraGenericLoops","HaveThreading","Name"], 'makes the parsed representation from the supplied RedoDimsCode', sub { return 'PDL_COMMENT("no RedoDimsCode")' if $_[0] =~ m|^/[*] none [*]/$|; PDL::PP::Code->new(@_,1); }), PDL::PP::Rule->new("RedoDims", ["ParNames","ParObjs","DimObjs","DimmedPars","RedoDimsParsedCode", '_NoPthread'], 'makes the redodims function from the various bits and pieces', \&make_redodims_thread), PDL::PP::Rule::Returns::EmptyString->new("Priv"), PDL::PP::Rule->new(["PrivNames","PrivObjs"], "Priv", \&OtherPars_nft), PDL::PP::Rule->new("PrivateRepr", ["PrivNames","PrivObjs"], \&NT2Decls_p), PDL::PP::Rule->new("PrivCopyCode", ["PrivNames","PrivObjs","CopyName"], \&NT2Copies_p), # avoid clash with freecode above? # PDL::PP::Rule->new("NTPrivFreeCode", ["PrivNames","PrivObjs"], \&NT2Free_p), PDL::PP::Rule->new("IsReversibleCodeNS", "Reversible", \&ToIsReversible), PDL::PP::Rule::Substitute::Usual->new("IsReversibleCode", "IsReversibleCodeNS"), # Needs cleaning up. NewXSStructInit2DJB has been added to make use # of the PDL::PP::Rule::Substitute class. # PDL::PP::Rule::Substitute->new("NewXSStructInit2DJB", "MakeCompiledRepr"), PDL::PP::Rule->new("NewXSStructInit2", "NewXSStructInit2DJB", sub { return "{".$_[0]."}"; }), PDL::PP::Rule->new("CopyCodeNS", ["PrivCopyCode","CompCopyCode","StructName","NoPdlThread"], sub { return "$_[2] *__copy = malloc(sizeof($_[2]));\n" . ($_[3] ? "" : "PDL_THR_CLRMAGIC(&__copy->__pdlthread);") . " PDL_TR_CLRMAGIC(__copy); __copy->has_badvalue = \$PRIV(has_badvalue); __copy->badvalue = \$PRIV(badvalue); __copy->flags = \$PRIV(flags); __copy->vtable = \$PRIV(vtable); __copy->__datatype = \$PRIV(__datatype); __copy->freeproc = NULL; __copy->__ddone = \$PRIV(__ddone); {int i; for(i=0; i<__copy->vtable->npdls; i++) __copy->pdls[i] = \$PRIV(pdls[i]); } $_[1] if(__copy->__ddone) { $_[0] } return (pdl_trans*)__copy;"; }), PDL::PP::Rule->new("FreeCodeNS", ["PrivFreeCode","CompFreeCode","NTPrivFreeCode"], sub { return " PDL_TR_CLRMAGIC(__privtrans); $_[1] if(__privtrans->__ddone) { $_[0] $_[2] } "; }), PDL::PP::Rule::Substitute::Usual->new("CopyCode", "CopyCodeNS"), PDL::PP::Rule::Substitute::Usual->new("FreeCode", "FreeCodeNS"), PDL::PP::Rule::Substitute::Usual->new("FooCodeSub", "FooCode"), PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMust"), PDL::PP::Rule::MakeComp->new("NewXSCoerceMustSub1", "NewXSCoerceMust", "FOO"), PDL::PP::Rule::Substitute->new("NewXSCoerceMustSub1d", "NewXSCoerceMustSub1"), PDL::PP::Rule->new("NewXSClearThread", "HaveThreading", sub {$_[0] ? "__privtrans->__pdlthread.inds = 0;" : ""}), PDL::PP::Rule->new("NewXSFindBadStatusNS", ["BadFlag","_FindBadStatusCode","NewXSArgs","USParObjs","OtherParTypes","NewXSSymTab","Name"], "Rule to find the bad value status of the input piddles", \&findbadstatus), # this can be removed once the default bad values are stored in a C structure # (rather than as a perl array in PDL::Types) # which it now is, hence the comments (DJB 07/10/00) # - left around in case we move to per-piddle bad values # - NOTE: now we have the experimental per-piddle bad values I need to remember # what I was doing here # [[NewXSCopyBadValues], [BadFlag,NewXSSymTab], # "copybadvalues", # "Rule to copy the default bad values into the trnas structure"], PDL::PP::Rule->new("NewXSCopyBadStatusNS", ["BadFlag","_CopyBadStatusCode","NewXSArgs","USParObjs","NewXSSymTab"], "Rule to copy the bad value status to the output piddles", \©badstatus), # expand macros in ...BadStatusCode # PDL::PP::Rule::Substitute::Usual->new("NewXSFindBadStatus", "NewXSFindBadStatusNS"), PDL::PP::Rule::Substitute::Usual->new("NewXSCopyBadStatus", "NewXSCopyBadStatusNS"), # Generates XS code with variable argument list. If this rule succeeds, the next rule # will not be executed. D. Hunt 4/11/00 # PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], ["_GlobalNew","_NewXSCHdrs","VarArgsXSHdr","NewXSLocals", "CacheBadFlagInit", "NewXSStructInit0", "NewXSFindBadStatus", # NewXSCopyBadValues, # NewXSMakeNow, # this is unnecessary since families never got implemented "NewXSFindDatatype","NewXSTypeCoerce", "NewXSStructInit1", "NewXSStructInit2", "NewXSCoerceMustSub1d","_IsReversibleCode","DefaultFlowCode", "NewXSClearThread", "NewXSSetTrans", "NewXSCopyBadStatus", "VarArgsXSReturn" ], "Rule to print out XS code when variable argument list XS processing is enabled", \&mkVarArgsxscat), # This rule will fail if the preceding rule succeeds # D. Hunt 4/11/00 # PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], ["_GlobalNew","_NewXSCHdrs","NewXSHdr","NewXSLocals", "CacheBadFlagInit", "NewXSStructInit0", "NewXSFindBadStatus", # NewXSCopyBadValues, # NewXSMakeNow, # this is unnecessary since families never got implemented "NewXSFindDatatype","NewXSTypeCoerce", "NewXSStructInit1", "NewXSStructInit2", "NewXSCoerceMustSub1d","_IsReversibleCode","DefaultFlowCode", "NewXSClearThread", "NewXSSetTrans", "NewXSCopyBadStatus" ], "Rule to print out XS code when variable argument list XS processing is disabled", \&mkxscat), PDL::PP::Rule->new("StructDecl", ["ParNames","ParObjs","CompiledRepr","PrivateRepr","StructName"], \&mkstruct), # The RedoDimsSub rule is a bit weird since it takes in the RedoDims target # twice (directly and via RedoDims-PostComp). Can this be cleaned up? # PDL::PP::Rule->new("RedoDims-PreComp", "RedoDims", sub { return $_[0] . ' $PRIV(__ddone) = 1;'; }), PDL::PP::Rule::MakeComp->new("RedoDims-PostComp", ["RedoDims-PreComp", "PrivNames", "PrivObjs"], "PRIV"), PDL::PP::Rule->new("RedoDimsSub", ["RedoDims", "RedoDims-PostComp", "_DimObjs"], sub { my $redodims = $_[0]; my $result = $_[1]; my $dimobjs = $_[2]; $result->[1]{"SIZE"} = sub { croak "can't get SIZE of undefined dimension (RedoDims=$redodims)." unless defined $dimobjs->{$redodims}; return $dimobjs->{$redodims}->get_size(); }; return $result; }), PDL::PP::Rule::Substitute->new("RedoDimsSubd", "RedoDimsSub"), PDL::PP::Rule->new("RedoDimsFunc", ["RedoDimsSubd","FHdrInfo","RedoDimsFuncName","_P2Child"], sub {wrap_vfn(@_,"redodims")}), PDL::PP::Rule::MakeComp->new("ReadDataSub", "ParsedCode", "FOO"), PDL::PP::Rule::Substitute->new("ReadDataSubd", "ReadDataSub"), PDL::PP::Rule->new("ReadDataFunc", ["ReadDataSubd","FHdrInfo","ReadDataFuncName","_P2Child"], sub {wrap_vfn(@_,"readdata")}), PDL::PP::Rule::MakeComp->new("WriteBackDataSub", "ParsedBackCode", "FOO"), PDL::PP::Rule::Substitute->new("WriteBackDataSubd", "WriteBackDataSub"), PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${name}_writebackdata'), PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"), PDL::PP::Rule->new("WriteBackDataFunc", ["WriteBackDataSubd","FHdrInfo","WriteBackDataFuncName","_P2Child"], sub {wrap_vfn(@_,"writebackdata")}),, PDL::PP::Rule->new("CopyFunc", ["CopyCode","FHdrInfo","CopyFuncName","_P2Child"], sub {wrap_vfn(@_,"copy")}), PDL::PP::Rule->new("FreeFunc", ["FreeCode","FHdrInfo","FreeFuncName","_P2Child"], sub {wrap_vfn(@_,"free")}), PDL::PP::Rule::Returns->new("FoofName", "FooCodeSub", "foomethod"), PDL::PP::Rule->new("FooFunc", ["FooCodeSub","FHdrInfo","FoofName","_P2Child"], sub {wrap_vfn(@_,"foo")}), PDL::PP::Rule::Returns::NULL->new("FoofName"), PDL::PP::Rule->new("VTableDef", ["VTableName","StructName","RedoDimsFuncName","ReadDataFuncName", "WriteBackDataFuncName","CopyFuncName","FreeFuncName", "ParNames","ParObjs","Affine_Ok","FoofName"], \&def_vtable), # Maybe accomplish this with an InsertName rule? PDL::PP::Rule->new('PMFunc', 'Name', 'Sets PMFunc to default symbol table manipulations', sub { my ($name) = @_; $::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ. '::'.$name.";\n".$::PDL_IFBEGINWRAP[1] } ), ]; sub printtrans { my($bar) = @_; for (qw/StructDecl RedoDimsFunc ReadDataFunc WriteBackFunc VTableDef NewXSCode/) { print "\n\n================================================ $_ =========================================\n",$bar->{$_},"\n" if $::PP_VERBOSE; } } sub translate { my ($pars,$tbl) = @_; foreach my $rule (@$tbl) { $rule->apply($pars); } # print Dumper($pars); print "GOING OUT!\n" if $::PP_VERBOSE; return $pars; } # sub: translate() ## End # PDL-2.018/Basic/Gen/pptemplate0000755060175006010010000000777112562522363014251 0ustar chmNone#!perl -w sub names { my ($module) = @_; my $name = (split '::', $module)[-1]; my $pdname = lc $name . '.pd'; return ($name,$pdname); } sub pdtmpl { return join '', ; } sub pdMakefile { my ($module,$name,$pdname,$internal) = @_; my $coredev = $internal ? 'PDL::Core::Dev->import()' : 'use PDL::Core::Dev'; my $int = $internal ? '_int' : ''; return << "EOM"; # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; $coredev; \@pack = (["$pdname",$name,$module]); \%hash = pdlpp_stdargs$int(\@pack); # \$hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. # \$hash{INC} .= " -I/usr/local/include"; # uncomment as required # \$hash{LIBS}[0] .= " -L/usr/local/lib -lmylib "; # uncomment as required WriteMakefile(\%hash); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble$int(\@pack); } EOM } sub usage { die << "EOU"; usage: $0 [option] modulename Options: -i internal mode - template for module that is in the PDL distribution EOU } use Getopt::Std; getopts('i'); usage unless $#ARGV > -1; ($module,$name,$pdname) = ($ARGV[0],names $ARGV[0]); die "Makefile.PL exists; move out of the way if you want to proceed" if -f 'Makefile.PL'; die "$pdname exists; move out of the way if you want to proceed" if -f $pdname; open $mkfl, '>Makefile.PL' or die "couldn't open Makefile.PL for writing"; open $pdfl, ">$pdname" or die "couldn't open $pdname for writing"; print $mkfl pdMakefile($module,$name,$pdname,$opt_i); close $mkfl; print $pdfl pdtmpl; close $pdfl; =head1 NAME pptemplate - script to generate Makefile.PL and PP file skeleton =head1 SYNOPSIS # generate Makefile.PL and mymodule.pd in CWD pptemplate PDL::MyModule; =head1 DESCRIPTION The B script is the easiest way to start a new module for PDL that contains PP code (see also L). The usage is simply pptemplate modulename; As a result pptemplate will generate a perl Makefile for the new module (F) that contains the minimal structure to generate a module from PP code and also a skeleton file for your new module. The file will be called F if you called C as pptemplate PDL::CleverAlgs::Mymod; I suppose you can work out the naming rule C<;)>. If not resort to experimentation or the source code. C will refuse to overwrite existing files of the same name to avoid accidents. Move them out of the way if you really want to scrap them. =head2 Options Currently there is only the C<-i> option which switches C into the so called I. It should only be used when you are starting a new module within the main PDL tree that is supposed to be part of the PDL distribution and the normal PDL build process, e.g. cd PDL/IO; mkdir Mpthree; cd Mpthree; pptemplate -i PDL::IO::Mpthree; =head1 BUGS Maybe C<;)>. Feedback and bug reports are welcome. =head1 COPYRIGHT Copyright (c) 2001, Christian Soeller. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as PDL itself (see L). =cut __END__ # template auto generated by pptemplate # uncomment commands, copy and fill in as needed # see also the PDL::PP manpage # pp_bless(''); # package namespace of pp_def'ed functions # defaults to 'PDL' # pp_add_boot(''); # code to add to the XS boot section # pp_addhdr(''); # add C code to the section preceding # the first MODULE keyword # pp_addpm(''); # add perl code to the perl module that PP will create # pp_add_exported(''); # add the list of function names # to the list of exported functions # pp_addxs(''); # add plain XS code to the XS section # pp_add_isa(qw//); # inheritance business: add arglist to modules @ISA # pp_def('name', Code => ''); # minimal pp_def to define function pp_done(); # you will need this to finish pp processing PDL-2.018/Basic/Lite.pm0000644060175006010010000000240713101422377012653 0ustar chmNone=head1 NAME PDL::Lite - minimum PDL module OO loader =head1 DESCRIPTION Loads the smallest possible set of modules for PDL to work, importing only those functions always defined by L) into the current namespace (C, C, C and C). This is the absolute minimum set for PDL. Access to other functions is by method syntax, viz: $x = PDL->pdl(1, 2, 3, 4, 5); $x->wibble(42); =head1 SYNOPSIS use PDL::Lite; # Is equivalent to the following: use PDL::Core ''; use PDL::Ops ''; use PDL::Primitive ''; use PDL::Ufunc ''; use PDL::Basic ''; use PDL::Slices ''; use PDL::Bad ''; use PDL::Version; use PDL::Lvalue; =cut # Load the fundamental PDL packages, no imports # Because there are no imports, we do not need # the usual 'eval in the user's namespace' routine. use PDL::Core ''; use PDL::Ops ''; use PDL::Primitive ''; use PDL::Ufunc ''; use PDL::Basic ''; use PDL::Slices ''; use PDL::Bad ''; use PDL::Version ; # Doesn't export anything - no need for '' use PDL::Lvalue; package PDL::Lite; $VERSION = $PDL::Version::VERSION; @ISA = qw( PDL::Exporter ); @EXPORT = qw( piddle pdl null barf ); # Only stuff always exported! our %EXPORT_TAGS = ( Func => [@EXPORT], ); ;# Exit with OK status 1; PDL-2.018/Basic/LiteF.pm0000644060175006010010000000164213036512174012763 0ustar chmNone=head1 NAME PDL::LiteF - minimum PDL module function loader =head1 DESCRIPTION Loads the smallest possible set of modules for PDL to work, making the functions available in the current namespace. If you want something even smaller see the L module. =head1 SYNOPSIS use PDL::LiteF; # Is equivalent to the following: use PDL::Core; use PDL::Ops; use PDL::Primitive; use PDL::Ufunc; use PDL::Basic; use PDL::Slices; use PDL::Bad; use PDL::Version; use PDL::Lvalue; =cut # get the version: use PDL::Version; package PDL::LiteF; $VERSION = $PDL::Version::VERSION; # Load the fundamental PDL packages, with imports sub PDL::LiteF::import { my $pkg = (caller())[0]; eval <slice(',(0)') .= 1; instead of the clumsy (my $tmp = $a->slice(',(0)')) .= 1; This will only work if your perl supports lvalue subroutines (i.e. versions >= v5.6.0). Note that lvalue subroutines are currently regarded experimental. =head1 SYNOPSIS use PDL::Lvalue; # automatically done with all PDL loaders =head1 FUNCTIONS =cut package PDL::Lvalue; # list of functions that can be used as lvalue subs # extend as necessary my @funcs = qw/ clump diagonal dice dice_axis dummy flat index index2d indexND indexNDb mslice mv nslice nslice_if_pdl nnslice polyfillv px range rangeb reorder reshape sever slice where whereND xchg /; my $prots = join "\n", map {"use attributes 'PDL', \\&PDL::$_, 'lvalue';"} @funcs; =head2 subs =for ref test if routine is a known PDL lvalue sub =for example print "slice is an lvalue sub" if PDL::Lvalue->subs('slice'); returns the list of PDL lvalue subs if no routine name is given, e.g. @lvfuncs = PDL::Lvalue->subs; It can be used in scalar context to find out if your PDL has lvalue subs: print 'has lvalue subs' if PDL::Lvalue->subs; =cut sub subs { my ($type,$func) = @_; if (defined $func) { $func =~ s/^.*:://; return ($^V and $^V >= 5.006007) && scalar grep {$_ eq $func} @funcs; } else { return ($^V and $^V >= 5.006007) ? @funcs : (); } } # print "defining lvalue subs:\n$prots\n"; eval << "EOV" if ($^V and $^V >= 5.006007); { package PDL; no warnings qw(misc); $prots } EOV =head1 AUTHOR Copyright (C) 2001 Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut 1; PDL-2.018/Basic/Makefile.PL0000644060175006010010000000244112562522363013376 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my $defstartup = 'default.perldlrc'; if ($^O =~ /win32/i) { $defstartup = 'default.pdl'; system("copy default.perldlrc $defstartup"); } my @pm_names = qw ( PDL.pm Lite.pm LiteF.pm AutoLoader.pm Options.pm Matrix.pm Reduce.pm Lvalue.pm Constants.pm); my %pm = map { my $h = '$(INST_LIBDIR)/'; $h .= 'PDL/' if $_ !~ /PDL.pm$/; ( $_, $h . $_ ); } ( @pm_names, $defstartup ); my %man3pods = map { my $h = '$(INST_MAN3DIR)/'; $h .= 'PDL::' if $_ !~ /PDL.pm$/; ( $_, $h . substr($_,0,length($_)-3) . '.$(MAN3EXT)' ); } @pm_names; WriteMakefile( 'NAME' => 'PDL', 'VERSION_FROM' => 'Core/Version.pm', 'PM' => \%pm, 'MAN3PODS' => \%man3pods, 'DIR' => ['Pod','Gen','SourceFilter','Core','Bad','Ops','Ufunc', 'Primitive','Slices','Math','MatrixOps','Complex'], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); # modify clean method not to delete files named 'core' # (required for MacOSX, where "Core" and "core" are # indistinguishable) package MY; # so that "SUPER" works right sub clean { my $inherited = shift->SUPER::clean(@_); $inherited =~ s/\s+core\s/ /; # print STDERR "processed list :\n$inherited\n"; $inherited; } PDL-2.018/Basic/Math/0000755060175006010010000000000013110402046012275 5ustar chmNonePDL-2.018/Basic/Math/acosh.c0000644060175006010010000000327712562522363013566 0ustar chmNone/* acosh.c * * Inverse hyperbolic cosine * * * * SYNOPSIS: * * double x, y, acosh(); * * y = acosh( x ); * * * * DESCRIPTION: * * Returns inverse hyperbolic cosine of argument. * * If 1 <= x < 1.5, a rational approximation * * sqrt(z) * P(z)/Q(z) * * where z = x-1, is used. Otherwise, * * acosh(x) = log( x + sqrt( (x-1)(x+1) ). * * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC 1,3 30000 4.2e-17 1.1e-17 * IEEE 1,3 30000 4.6e-16 8.7e-17 * * * ERROR MESSAGES: * * message condition value returned * acosh domain |x| < 1 NAN * */ /* acosh.c */ /* Cephes Math Library Release 2.3: March, 1995 Copyright 1984, 1995 by Stephen L. Moshier */ /* acosh(z) = sqrt(x) * R(x), z = x + 1, interval 0 < x < 0.5 */ #include "mconf.h" static double P[] = { 1.18801130533544501356E2, 3.94726656571334401102E3, 3.43989375926195455866E4, 1.08102874834699867335E5, 1.10855947270161294369E5 }; static double Q[] = { /* 1.00000000000000000000E0,*/ 1.86145380837903397292E2, 4.15352677227719831579E3, 2.97683430363289370382E4, 8.29725251988426222434E4, 7.83869920495893927727E4 }; #ifndef ANSIPROT double log(), sqrt(), polevl(), p1evl(); #endif extern double LOGE2; double acosh(x) double x; { double a, z; if( x < 1.0 ) { mtherr( "acosh", DOMAIN ); return(quiet_nan()); } if( x > 1.0e8 ) { if( !finite(x) ) return(x); return( log(x) + LOGE2 ); } z = x - 1.0; if( z < 0.5 ) { a = sqrt(z) * (polevl(z, P, 4) / p1evl(z, Q, 5) ); return( a ); } a = sqrt( z*(x+1.0) ); return( log(x + a) ); } PDL-2.018/Basic/Math/asinh.c0000644060175006010010000000321212562522363013560 0ustar chmNone/* asinh.c * * Inverse hyperbolic sine * * * * SYNOPSIS: * * double x, y, asinh(); * * y = asinh( x ); * * * * DESCRIPTION: * * Returns inverse hyperbolic sine of argument. * * If |x| < 0.5, the function is approximated by a rational * form x + x**3 P(x)/Q(x). Otherwise, * * asinh(x) = log( x + sqrt(1 + x*x) ). * * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC -3,3 75000 4.6e-17 1.1e-17 * IEEE -1,1 30000 3.7e-16 7.8e-17 * IEEE 1,3 30000 2.5e-16 6.7e-17 * */ /* asinh.c */ /* Cephes Math Library Release 2.3: March, 1995 Copyright 1984, 1995 by Stephen L. Moshier */ #include "mconf.h" static double P[] = { -4.33231683752342103572E-3, -5.91750212056387121207E-1, -4.37390226194356683570E0, -9.09030533308377316566E0, -5.56682227230859640450E0 }; static double Q[] = { /* 1.00000000000000000000E0,*/ 1.28757002067426453537E1, 4.86042483805291788324E1, 6.95722521337257608734E1, 3.34009336338516356383E1 }; #ifndef ANSIPROT double log(), sqrt(), polevl(), p1evl(); #endif extern double LOGE2; double asinh(xx) double xx; { double a, z, x; int sign; #ifdef MINUSZERO if( xx == 0.0 ) return(xx); #endif if( xx < 0.0 ) { sign = -1; x = -xx; } else { sign = 1; x = xx; } if( x > 1.0e8 ) { if(!finite(x)) return(xx); return( sign * (log(x) + LOGE2) ); } z = x * x; if( x < 0.5 ) { a = ( polevl(z, P, 4)/p1evl(z, Q, 4) ) * z; a = a * x + x; if( sign < 0 ) a = -a; return(a); } a = sqrt( z + 1.0 ); return( sign * log(x + a) ); } PDL-2.018/Basic/Math/atanh.c0000644060175006010010000000311012562522363013546 0ustar chmNone/* atanh.c * * Inverse hyperbolic tangent * * * * SYNOPSIS: * * double x, y, atanh(); * * y = atanh( x ); * * * * DESCRIPTION: * * Returns inverse hyperbolic tangent of argument in the range * MINLOG to MAXLOG. * * If |x| < 0.5, the rational form x + x**3 P(x)/Q(x) is * employed. Otherwise, * atanh(x) = 0.5 * log( (1+x)/(1-x) ). * * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC -1,1 50000 2.4e-17 6.4e-18 * IEEE -1,1 30000 1.9e-16 5.2e-17 * */ /* atanh.c */ /* Cephes Math Library Release 2.3: March, 1995 Copyright (C) 1987, 1995 by Stephen L. Moshier */ #include "mconf.h" static double P[] = { -8.54074331929669305196E-1, 1.20426861384072379242E1, -4.61252884198732692637E1, 6.54566728676544377376E1, -3.09092539379866942570E1 }; static double Q[] = { /* 1.00000000000000000000E0,*/ -1.95638849376911654834E1, 1.08938092147140262656E2, -2.49839401325893582852E2, 2.52006675691344555838E2, -9.27277618139601130017E1 }; #ifndef ANSIPROT double fabs(), log(), polevl(), p1evl(); #endif double atanh(x) double x; { double s, z; #ifdef MINUSZERO if( x == 0.0 ) return(x); #endif z = fabs(x); if( z >= 1.0 ) { if( x == 1.0 ) return( infinity() ); if( x == -1.0 ) return( -infinity() ); mtherr( "atanh", DOMAIN ); return( quiet_nan() ); } if( z < 1.0e-7 ) return(x); if( z < 0.5 ) { z = x * x; s = x + x * z * (polevl(z, P, 4) / p1evl(z, Q, 5)); return(s); } return( 0.5 * log((1.0+x)/(1.0-x)) ); } PDL-2.018/Basic/Math/const.c0000644060175006010010000000401212562522363013603 0ustar chmNone/* Some constant values -- */ #include "mconf.h" /* Many of these values should ideally come from or , which should be included in mconf.h if required */ #ifdef DBL_EPSILON double MACHEP = DBL_EPSILON; #else double MACHEP = 1.11022302462515654042E-16; /* 2**-53 */ #endif #if defined DBL_MIN double UFLOWTHRESH = DBL_MIN; #elif defined MINDOUBLE double UFLOWTHRESH = MINDOUBLE; #else double UFLOWTHRESH = 2.22507385850720138309E-308; /* 2**-1022 */ #endif #ifdef DBL_MAX_10_EXP double MAXLOG = DBL_MAX_10_EXP; #else double MAXLOG = 7.08396418532264106224E2; /* log 2**1022 */ #endif #ifdef DBL_MIN_10_EXP double MINLOG = DBL_MIN_10_EXP; #else double MINLOG = -7.08396418532264106224E2; /* log 2**-1022 */ #endif #if defined MAXDOUBLE double MAXNUM = MAXDOUBLE; #elif defined DBL_MAX double MAXNUM = DBL_MAX; #else double MAXNUM = 1.79769313486231570815E308; /* 2**1024*(1-MACHEP) */ #endif #ifdef M_PI #ifndef PI double PI = M_PI; #endif double PIO2 = M_PI/2; double PIO4 = M_PI/4; double THPIO4 = 0.75*M_PI; double TWOOPI = 2/M_PI; #else #ifndef PI double PI = 3.14159265358979323846; /* pi */ #endif double PIO2 = 1.57079632679489661923; /* pi/2 */ double PIO4 = 7.85398163397448309616E-1; /* pi/4 */ double THPIO4 = 2.35619449019234492885; /* 3*pi/4 */ double TWOOPI = 6.36619772367581343075535E-1; /* 2/pi */ #endif #ifdef M_SQRT2 double SQRT2 = M_SQRT2; /* sqrt(2) */ double SQRTH = M_SQRT2/2; /* sqrt(2)/2 */ #else double SQRT2 = 1.41421356237309504880; /* sqrt(2) */ double SQRTH = 7.07106781186547524401E-1; /* sqrt(2)/2 */ #endif double SQ2OPI = 7.9788456080286535587989E-1; /* sqrt( 2/pi ) */ #ifdef M_LN2 double LOGE2 = M_LN2; double LOGSQ2 = M_LN2/2; /* log(2)/2 */ double LOG2E = 1/M_LN2; /* 1/log(2) */ #else double LOGE2 = 6.93147180559945309417E-1; /* log(2) */ double LOGSQ2 = 3.46573590279972654709E-1; /* log(2)/2 */ double LOG2E = 1.4426950408889634073599; /* 1/log(2) */ #endif PDL-2.018/Basic/Math/cpoly.c0000644060175006010010000004563612562522363013624 0ustar chmNone/* Translated from F77 to C, rjrw 10/04/2000 */ /* replaced 'bool' by 'boolvar' to get it to compile on my linux machine, DJB Aug 02 2000 */ /* algorithm 419 collected algorithms from acm. algorithm appeared in comm. acm, vol. 15, no. 02, p. 097. */ #include #include #include /* #if !defined(WIN32) && !defined(_WIN32) && !defined(__APPLE__) && !defined(__CYGWIN__) #include #endif */ #include /* #define DEBUGMAIN */ /* Set up debugging main, etc. */ #include "cpoly.h" /* Internal routines */ static void noshft(int l1); static int fxshft(int l2, double *zr, double *zi); static int vrshft(int l3, double *zr, double *zi); static int calct(void); static void nexth(int boolvar); static void polyev(int nn, double sr, double si, double pr[], double pi[], double qr[], double qi[], double *pvr, double *pvi); static double errev(int nn, double qr[], double qi[], double ms, double mp); static double cauchy(int nn, double pt[], double q[]); static double scale(int nn, double pt[]); static void cdivid(double ar, double ai, double br, double bi, double *cr, double *ci); static double cmod(double r, double i); static void mcon(void); static int init(int nncr); /* Internal global variables */ static double *pr,*pi,*hr,*hi,*qpr,*qpi,*qhr,*qhi,*shr,*shi; static double sr,si,tr,ti,pvr,pvi,are,mre,eta,infin,smalno,base; static int nn; #ifdef DEBUGMAIN /* driver to test cpoly */ int main() { int fail; double p[50],pi[50],zr[50],zi[50]; int i; printf("Example 1. polynomial with zeros 1,2,...,10.\n"); p[0]=1L; p[1]=-55L; p[2]=1320L; p[3]=-18150L; p[4]=157773L; p[5]=-902055L; p[6] = 3416930L; p[7]=-8409500L; p[8]=12753576L; p[9]=-10628640L; p[10]=3628800L; for (i=0;i<11;i++) pi[i]=0; prtc(11,p,pi); fail = cpoly(p,pi,10,zr,zi); if(fail) printf("cpoly has failed on this example\n"); prtz (10,zr,zi); printf("Example 2. zeros on imaginary axis degree 3.\n"); p[0]=1; p[1]=0; p[2]=-10001.0001L; p[3]=0; pi[0]=0; pi[1]=-10001.0001L; pi[2]=0; pi[3]=1; prtc(4,p,pi); fail = cpoly(p,pi,3,zr,zi); if (fail) printf("cpoly has failed on this example\n"); prtz(3,zr,zi); printf("Example 3. zeros at 1+i,1/2*(1+i)....1/(2**-9)*(1+i)\n"); p[0]=1.0; p[1]=-1.998046875L; p[2]=0.0; p[3]=.7567065954208374L; p[4]=-.2002119533717632L; p[5]=1.271507365163416e-2L; p[6]=0; p[7]=-1.154642632172909e-5L; p[8]=1.584803612786345e-7L; p[9]=-4.652065399568528e-10L; p[10]=0; pi[0]=0; pi[1]=p[1]; pi[2]=2.658859252929688L; pi[3]=-7.567065954208374e-1L; pi[4]=0; pi[5]=p[5]; pi[6]=-7.820779428584501e-4L; pi[7]=-p[7]; pi[8]=0; pi[9]=p[9]; pi[10]=9.094947017729282e-13L; prtc(11,p,pi); fail = cpoly(p,pi,10,zr,zi); if (fail) printf("cpoly has failed on this example\n"); prtz(10,zr,zi); printf("Example 4. multiple zeros\n"); p[0]=1L; p[1]=-10L; p[2]=3L; p[3]=284L; p[4]=-1293L; p[5]=2374L; p[6]=-1587L; p[7]=-920L; p[8]=2204L; p[9]=-1344L; p[10]=288L; pi[0]=0; pi[1]=-10L; pi[2]=100L; pi[3]=-334L; pi[4]=200L; pi[5]=1394L; pi[6] =-3836L; pi[7]=4334L; pi[8]=-2352L; pi[9]=504L; pi[10]=0; prtc(11,p,pi); fail = cpoly(p,pi,10,zr,zi); if (fail) printf("cpoly has failed on this example\n"); prtz(10,zr,zi); printf("Example 5. 12 zeros evenly distributed on a circle of radius 1. centered at 0+2i.\n"); p[0]=1L; p[1]=0; p[2]=-264L; p[3]=0; p[4]=7920L; p[5]=0; p[6]=-59136L; p[7]=0; p[8]=126720L; p[9]=0; p[10]=-67584L; p[11]=0; p[12]=4095L; pi[0]=0; pi[1]=-24L; pi[2]=0; pi[3]=1760L; pi[4]=0; pi[5]=-25344L; pi[6]=0; pi[7]=101376L; pi[8]=0; pi[9]=-112640L; pi[10]=0; pi[11]=24576L; pi[12]=0; prtc(13,p,pi); fail = cpoly(p,pi,12,zr,zi); if(fail) printf("cpoly has failed on this example\n"); prtz(12,zr,zi); return 0; } void prtc(int n, double p[], double q[]) { int i; printf("Coefficients\n"); for (i=0;i eta*10.0*cmod(pr[nm2],pi[nm2])) { cdivid(-pr[n],-pi[n],hr[nm1],hi[nm1],&tr,&ti); for (i=0;i=omp && relstp < .05L) { /* Iteration has stalled, probably a cluster of zeros Do 5 fixed shift steps into the cluster to force one zero to dominate */ b = TRUE; if (relstp < eta) tp = eta; else tp = relstp; r1 = sqrt(tp); r2 = sr*(1.0L+r1)-si*r1; si = sr*r1+si*(1.0L+r1); sr = r2; polyev(nn,sr,si,pr,pi,qpr,qpi,&pvr,&pvi); for (j=0;j<5;j++) { boolvar = calct(); nexth(boolvar); } omp = infin; } else { /* Exit if polynomial value increases significantly */ if (mp*0.1L > omp) return conv; omp = mp; } } else { omp = mp; } } /* Calculate next iterate. */ boolvar = calct(); nexth(boolvar); boolvar = calct(); if (!boolvar) { relstp = cmod(tr,ti)/cmod(sr,si); sr += tr; si += ti; } } return conv; } static int calct(void) /* Computes t = -p(s)/h(s) Returns TRUE if h(s) is essentially zero */ { double hvr,hvi; int n = nn-1, boolvar; /* Evaluate h(s) */ polyev(n,sr,si,hr,hi,qhr,qhi,&hvr,&hvi); boolvar = (cmod(hvr,hvi) <= are*10.0*cmod(hr[n-1],hi[n-1])); if (!boolvar) { cdivid(-pvr,-pvi,hvr,hvi,&tr,&ti); } else { tr = 0.0; ti = 0.0; } return boolvar; } static void nexth(int boolvar) /* Calculates the next shifted h polynomial boolvar - TRUE if h(s) is essentially zero */ { double t1,t2; int j,n = nn-1; if (!boolvar) { for (j=1;j 0.); dx = x; /* Do Newton iteration until x converges to two decimal places */ while (fabs(dx/x) > .005L) { q[0] = pt[0]; for(i=1;i max) max = x; if (x != 0.0 && x < min) min = x; } /* Scale only if there are very large or very small components */ if (min >= lo && max <= hi) return 1.0; x = lo/min; if (x <= 1.0L) { sc = 1.0L/(sqrt(max)*sqrt(min)); } else { sc = x; if (infin/sc > max) sc = 1.0; } l = log(sc)/log(base) + .500; return pow(base,l); } static void cdivid(double ar, double ai, double br, double bi, double *cr, double *ci) /* Complex division c = a/b, avoiding overflow */ { double r,d; if (br == 0.0 && bi == 0.0) { /* division by zero, c = infinity. */ *cr = infin; *ci = infin; } else if (fabs(br) < fabs(bi)) { r = br/bi; d = bi+r*br; *cr = (ar*r+ai)/d; *ci = (ai*r-ar)/d; } else { r = bi/br; d = br+r*bi; *cr = (ar+ai*r)/d; *ci = (ai-ar*r)/d; } return; } static double cmod(double r, double i) /* Modulus of a complex number avoiding overflow */ { double ar,ai,f; ar = fabs(r); ai = fabs(i); if (ar < ai) { f = ar/ai; return ai*sqrt(1.0+f*f); } else if (ar > ai) { f = ai/ar; return ar*sqrt(1.0+f*f); } else { return ar*sqrt(2.0); } } static void mcon() /* mcon provides machine constants used in various parts of the program. The user may either set them directly or use the statements below to compute them. The meaning of the four constants are - eta the maximum relative representation error which can be described as the smallest positive floating-point number such that 1.0d0 + eta is greater than 1.0d0. infin the largest floating-point number smalno the smallest positive floating-point number base the base of the floating-point number system used Let t be the number of base-digits in each floating-point number (double precision). Then eta is either .5*b**(1-t) or b**(1-t) depending on whether rounding or truncation is used. Let m be the largest exponent and n the smallest exponent in the number system. Then infiny is (1-base**(-t))*base**m and smalno is base**n. */ { /* #if !defined(WIN32) && !defined(_WIN32) && !defined(__APPLE__) && !defined(__CYGWIN__) base = 2; eta = DBL_EPSILON; smalno = MINDOUBLE; infin = MAXDOUBLE; #else */ base = 2; eta = DBL_EPSILON; smalno = DBL_MIN; infin = DBL_MAX; /* #endif */ #ifdef IBM360 /* These values for base,t,m,n correspond to the ibm/360. */ int m,n,t; base = 16.0; t = 14; m = 63; n = -65; eta = pow(base,1-t); infin = (base)*(1.0-pow(base,-t))*pow(base,m-1); smalno = pow(base,n+3)/pow(base,3); #endif } static int init(int nncr) { static int nmax=0; if (nmax == 0) { /* Set up once-off constants */ mcon(); /* are, mre - Error bounds on complex addition and multiplication, cf e.g. errev() above */ are = eta; mre = 2.0L*sqrt(2.0L)*eta; } else if (nmax >= nncr) { return TRUE; /* Present arrays are big enough */ } else { /* Free old arrays (no need to preserve contents */ free(shi); free(shr); free(qhi); free(qhr); free(qpi); free(qpr); free(hi); free(hr); free(pi); free(pr); } nmax = nncr; pr = (double *) malloc(nmax*sizeof(double)); pi = (double *) malloc(nmax*sizeof(double)); hr = (double *) malloc(nmax*sizeof(double)); hi = (double *) malloc(nmax*sizeof(double)); qpr = (double *) malloc(nmax*sizeof(double)); qpi = (double *) malloc(nmax*sizeof(double)); qhr = (double *) malloc(nmax*sizeof(double)); qhi = (double *) malloc(nmax*sizeof(double)); shr = (double *) malloc(nmax*sizeof(double)); shi = (double *) malloc(nmax*sizeof(double)); if (!(pr && pi && hr && hi && qpr && qpi && qhr && qhi && shr && shi)) { fprintf(stderr,"Couldn't allocate space for cpoly\n"); return FALSE; } else { return TRUE; } } PDL-2.018/Basic/Math/cpoly.h0000644060175006010010000000043612562522363013616 0ustar chmNone#ifdef DEBUGMAIN void prtc(int n, double p[], double q[]); void prtz(int n,double zr[], double zi[]); #endif int cpoly(double opr[], double opi[], int degree, double zeror[], double zeroi[]); #if !defined(FALSE) #define FALSE (0) #endif #if !defined(TRUE) #define TRUE (1) #endif PDL-2.018/Basic/Math/infinity.c0000644060175006010010000000024412562522363014311 0ustar chmNone#include "mconf.h" double infinity(void) { #ifdef DBL_INFINITY return DBL_INFINITY; #else double a=0; return 1./a; /* Expect divide by zero error */ #endif } PDL-2.018/Basic/Math/j0.c0000644060175006010010000001302412562522363012771 0ustar chmNone/* j0.c * * Bessel function of order zero * * * * SYNOPSIS: * * double x, y, j0(); * * y = j0( x ); * * * * DESCRIPTION: * * Returns Bessel function of order zero of the argument. * * The domain is divided into the intervals [0, 5] and * (5, infinity). In the first interval the following rational * approximation is used: * * * 2 2 * (w - r ) (w - r ) P (w) / Q (w) * 1 2 3 8 * * 2 * where w = x and the two r's are zeros of the function. * * In the second interval, the Hankel asymptotic expansion * is employed with two rational functions of degree 6/6 * and 7/7. * * * * ACCURACY: * * Absolute error: * arithmetic domain # trials peak rms * DEC 0, 30 10000 4.4e-17 6.3e-18 * IEEE 0, 30 60000 4.2e-16 1.1e-16 * */ /* y0.c * * Bessel function of the second kind, order zero * * * * SYNOPSIS: * * double x, y, y0(); * * y = y0( x ); * * * * DESCRIPTION: * * Returns Bessel function of the second kind, of order * zero, of the argument. * * The domain is divided into the intervals [0, 5] and * (5, infinity). In the first interval a rational approximation * R(x) is employed to compute * y0(x) = R(x) + 2 * log(x) * j0(x) / PI. * Thus a call to j0() is required. * * In the second interval, the Hankel asymptotic expansion * is employed with two rational functions of degree 6/6 * and 7/7. * * * * ACCURACY: * * Absolute error, when y0(x) < 1; else relative error: * * arithmetic domain # trials peak rms * DEC 0, 30 9400 7.0e-17 7.9e-18 * IEEE 0, 30 30000 1.3e-15 1.6e-16 * */ /* Cephes Math Library Release 2.1: January, 1989 Copyright 1984, 1987, 1989 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ /* Note: all coefficients satisfy the relative error criterion * except YP, YQ which are designed for absolute error. */ #include "mconf.h" static double PP[7] = { 7.96936729297347051624E-4, 8.28352392107440799803E-2, 1.23953371646414299388E0, 5.44725003058768775090E0, 8.74716500199817011941E0, 5.30324038235394892183E0, 9.99999999999999997821E-1, }; static double PQ[7] = { 9.24408810558863637013E-4, 8.56288474354474431428E-2, 1.25352743901058953537E0, 5.47097740330417105182E0, 8.76190883237069594232E0, 5.30605288235394617618E0, 1.00000000000000000218E0, }; static double QP[8] = { -1.13663838898469149931E-2, -1.28252718670509318512E0, -1.95539544257735972385E1, -9.32060152123768231369E1, -1.77681167980488050595E2, -1.47077505154951170175E2, -5.14105326766599330220E1, -6.05014350600728481186E0, }; static double QQ[7] = { /* 1.00000000000000000000E0,*/ 6.43178256118178023184E1, 8.56430025976980587198E2, 3.88240183605401609683E3, 7.24046774195652478189E3, 5.93072701187316984827E3, 2.06209331660327847417E3, 2.42005740240291393179E2, }; static double YP[8] = { 1.55924367855235737965E4, -1.46639295903971606143E7, 5.43526477051876500413E9, -9.82136065717911466409E11, 8.75906394395366999549E13, -3.46628303384729719441E15, 4.42733268572569800351E16, -1.84950800436986690637E16, }; static double YQ[7] = { /* 1.00000000000000000000E0,*/ 1.04128353664259848412E3, 6.26107330137134956842E5, 2.68919633393814121987E8, 8.64002487103935000337E10, 2.02979612750105546709E13, 3.17157752842975028269E15, 2.50596256172653059228E17, }; /* 5.783185962946784521175995758455807035071 */ static double DR1 = 5.78318596294678452118E0; /* 30.47126234366208639907816317502275584842 */ static double DR2 = 3.04712623436620863991E1; static double RP[4] = { -4.79443220978201773821E9, 1.95617491946556577543E12, -2.49248344360967716204E14, 9.70862251047306323952E15, }; static double RQ[8] = { /* 1.00000000000000000000E0,*/ 4.99563147152651017219E2, 1.73785401676374683123E5, 4.84409658339962045305E7, 1.11855537045356834862E10, 2.11277520115489217587E12, 3.10518229857422583814E14, 3.18121955943204943306E16, 1.71086294081043136091E18, }; double j0(x) double x; { double polevl(), p1evl(); double w, z, p, q, xn; double sin(), cos(), sqrt(); extern double PIO4, SQ2OPI; if( x < 0 ) x = -x; if( x <= 5.0 ) { z = x * x; if( x < 1.0e-5 ) return( 1.0 - z/4.0 ); p = (z - DR1) * (z - DR2); p = p * polevl( z, RP, 3)/p1evl( z, RQ, 8 ); return( p ); } w = 5.0/x; q = 25.0/(x*x); p = polevl( q, PP, 6)/polevl( q, PQ, 6 ); q = polevl( q, QP, 7)/p1evl( q, QQ, 7 ); xn = x - PIO4; p = p * cos(xn) - w * q * sin(xn); return( p * SQ2OPI / sqrt(x) ); } /* y0() 2 */ /* Bessel function of second kind, order zero */ /* Rational approximation coefficients YP[], YQ[] are used here. * The function computed is y0(x) - 2 * log(x) * j0(x) / PI, * whose value at x = 0 is 2 * ( log(0.5) + EUL ) / PI * = 0.073804295108687225. */ /* #define PIO4 .78539816339744830962 #define SQ2OPI .79788456080286535588 */ extern double MAXNUM; #ifdef MY_FIXY0 double fixy0(x) #else double y0(x) #endif double x; { double polevl(), p1evl(); double w, z, p, q, xn; double j0(), log(), sin(), cos(), sqrt(); extern double TWOOPI, SQ2OPI, PIO4; if( x <= 5.0 ) { if( x <= 0.0 ) { mtherr( "y0", DOMAIN ); return( -MAXNUM ); } z = x * x; w = polevl( z, YP, 7) / p1evl( z, YQ, 7 ); w += TWOOPI * log(x) * j0(x); return( w ); } w = 5.0/x; z = 25.0 / (x * x); p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); xn = x - PIO4; p = p * sin(xn) + w * q * cos(xn); return( p * SQ2OPI / sqrt(x) ); } PDL-2.018/Basic/Math/j1.c0000644060175006010010000001133612562522363012776 0ustar chmNone/* j1.c * * Bessel function of order one * * * * SYNOPSIS: * * double x, y, j1(); * * y = j1( x ); * * * * DESCRIPTION: * * Returns Bessel function of order one of the argument. * * The domain is divided into the intervals [0, 8] and * (8, infinity). In the first interval a 24 term Chebyshev * expansion is used. In the second, the asymptotic * trigonometric representation is employed using two * rational functions of degree 5/5. * * * * ACCURACY: * * Absolute error: * arithmetic domain # trials peak rms * DEC 0, 30 10000 4.0e-17 1.1e-17 * IEEE 0, 30 30000 2.6e-16 1.1e-16 * * */ /* y1.c * * Bessel function of second kind of order one * * * * SYNOPSIS: * * double x, y, y1(); * * y = y1( x ); * * * * DESCRIPTION: * * Returns Bessel function of the second kind of order one * of the argument. * * The domain is divided into the intervals [0, 8] and * (8, infinity). In the first interval a 25 term Chebyshev * expansion is used, and a call to j1() is required. * In the second, the asymptotic trigonometric representation * is employed using two rational functions of degree 5/5. * * * * ACCURACY: * * Absolute error: * arithmetic domain # trials peak rms * DEC 0, 30 10000 8.6e-17 1.3e-17 * IEEE 0, 30 30000 1.0e-15 1.3e-16 * * (error criterion relative when |y1| > 1). * */ /* Cephes Math Library Release 2.1: January, 1989 Copyright 1984, 1987, 1989 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ /* #define PIO4 .78539816339744830962 #define THPIO4 2.35619449019234492885 #define SQ2OPI .79788456080286535588 */ #include "mconf.h" static double RP[4] = { -8.99971225705559398224E8, 4.52228297998194034323E11, -7.27494245221818276015E13, 3.68295732863852883286E15, }; static double RQ[8] = { /* 1.00000000000000000000E0,*/ 6.20836478118054335476E2, 2.56987256757748830383E5, 8.35146791431949253037E7, 2.21511595479792499675E10, 4.74914122079991414898E12, 7.84369607876235854894E14, 8.95222336184627338078E16, 5.32278620332680085395E18, }; static double PP[7] = { 7.62125616208173112003E-4, 7.31397056940917570436E-2, 1.12719608129684925192E0, 5.11207951146807644818E0, 8.42404590141772420927E0, 5.21451598682361504063E0, 1.00000000000000000254E0, }; static double PQ[7] = { 5.71323128072548699714E-4, 6.88455908754495404082E-2, 1.10514232634061696926E0, 5.07386386128601488557E0, 8.39985554327604159757E0, 5.20982848682361821619E0, 9.99999999999999997461E-1, }; static double QP[8] = { 5.10862594750176621635E-2, 4.98213872951233449420E0, 7.58238284132545283818E1, 3.66779609360150777800E2, 7.10856304998926107277E2, 5.97489612400613639965E2, 2.11688757100572135698E2, 2.52070205858023719784E1, }; static double QQ[7] = { /* 1.00000000000000000000E0,*/ 7.42373277035675149943E1, 1.05644886038262816351E3, 4.98641058337653607651E3, 9.56231892404756170795E3, 7.99704160447350683650E3, 2.82619278517639096600E3, 3.36093607810698293419E2, }; static double YP[6] = { 1.26320474790178026440E9, -6.47355876379160291031E11, 1.14509511541823727583E14, -8.12770255501325109621E15, 2.02439475713594898196E17, -7.78877196265950026825E17, }; static double YQ[8] = { /* 1.00000000000000000000E0,*/ 5.94301592346128195359E2, 2.35564092943068577943E5, 7.34811944459721705660E7, 1.87601316108706159478E10, 3.88231277496238566008E12, 6.20557727146953693363E14, 6.87141087355300489866E16, 3.97270608116560655612E18, }; static double Z1 = 1.46819706421238932572E1; static double Z2 = 4.92184563216946036703E1; double j1(x) double x; { extern double THPIO4, SQ2OPI; double polevl(), p1evl(); double w, z, p, q, xn; double sin(), cos(), sqrt(); w = x; if( x < 0 ) w = -x; if( w <= 5.0 ) { z = x * x; w = polevl( z, RP, 3 ) / p1evl( z, RQ, 8 ); w = w * x * (z - Z1) * (z - Z2); return( w ); } w = 5.0/x; z = w * w; p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); xn = x - THPIO4; p = p * cos(xn) - w * q * sin(xn); return( p * SQ2OPI / sqrt(x) ); } extern double MAXNUM; double y1(x) double x; { extern double TWOOPI, THPIO4, SQ2OPI; double polevl(), p1evl(); double w, z, p, q, xn; double j1(), log(), sin(), cos(), sqrt(); if( x <= 5.0 ) { if( x <= 0.0 ) { mtherr( "y1", DOMAIN ); return( -MAXNUM ); } z = x * x; w = x * (polevl( z, YP, 5 ) / p1evl( z, YQ, 8 )); w += TWOOPI * ( j1(x) * log(x) - 1.0/x ); return( w ); } w = 5.0/x; z = w * w; p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); xn = x - THPIO4; p = p * sin(xn) + w * q * cos(xn); return( p * SQ2OPI / sqrt(x) ); } PDL-2.018/Basic/Math/jn.c0000644060175006010010000000356212562522363013075 0ustar chmNone/* jn.c * * Bessel function of integer order * * * * SYNOPSIS: * * int n; * double x, y, jn(); * * y = jn( n, x ); * * * * DESCRIPTION: * * Returns Bessel function of order n, where n is a * (possibly negative) integer. * * The ratio of jn(x) to j0(x) is computed by backward * recurrence. First the ratio jn/jn-1 is found by a * continued fraction expansion. Then the recurrence * relating successive orders is applied until j0 or j1 is * reached. * * If n = 0 or 1 the routine for j0 or j1 is called * directly. * * * * ACCURACY: * * Absolute error: * arithmetic range # trials peak rms * DEC 0, 30 5500 6.9e-17 9.3e-18 * IEEE 0, 30 5000 4.4e-16 7.9e-17 * * * Not suitable for large n or x. Use jv() instead. * */ /* jn.c Cephes Math Library Release 2.0: April, 1987 Copyright 1984, 1987 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double MACHEP; double jn( n, x ) int n; double x; { double pkm2, pkm1, pk, xk, r, ans; int k, sign; double fabs(), j0(), j1(); if( n < 0 ) { n = -n; if( (n & 1) == 0 ) /* -1**n */ sign = 1; else sign = -1; } else sign = 1; if( n == 0 ) return( sign * j0(x) ); if( n == 1 ) return( sign * j1(x) ); if( n == 2 ) return( sign * (2.0 * j1(x) / x - j0(x)) ); if( x < MACHEP ) return( 0.0 ); /* continued fraction */ #ifdef DEC k = 56; #else k = 53; #endif pk = 2 * (n + k); ans = pk; xk = x * x; do { pk -= 2.0; ans = pk - (xk/ans); } while( --k > 0 ); ans = x/ans; /* backward recurrence */ pk = 1.0; pkm1 = 1.0/ans; k = n-1; r = 2 * k; do { pkm2 = (pkm1 * r - pk * x) / x; pk = pkm1; pkm1 = pkm2; r -= 2.0; } while( --k > 0 ); if( fabs(pk) > fabs(pkm1) ) ans = j1(x)/pk; else ans = j0(x)/pkm1; return( sign * ans ); } PDL-2.018/Basic/Math/Makefile.PL0000644060175006010010000000744113036512174014270 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use File::Basename; use Config; use File::Spec; sub cdir { return File::Spec->catdir(@_)} sub cfile { return File::Spec->catfile(@_)} sub is_sys_func { my ( $code, $libs, $dir ) = @_; trylink( '', qq{#include "$dir/mconf.h"}, $code, $libs ); } # Files for each routine (.c assumed) my %source = qw( acosh acosh asinh asinh atanh atanh erf ndtr erfc ndtr j0 j0 j1 j1 jn jn y0 j0 y1 j1 yn yn erfi ndtri ndtri ndtri rint rint nan quiet_nan infinity infinity polyroots cpoly ); my @keys = sort keys %source; my %included = (); # test for library features my (@sfuncs) = qw(nan infinity); my (@ufuncs2) = qw(acosh asinh atanh erf erfc rint); my (@besufuncs) = qw(j0 j1 y0 y1); my (@besbifuncs) = qw(jn yn); my ($libs) = $^O =~ /MSWin/ ? '' : $^O =~ /cygwin/ ? getcyglib('m') : '-lm'; if ($^O eq 'solaris' or $^O eq 'sunos') { # try to guess where sunmath is my @d = split /:+/, $ENV{LD_LIBRARY_PATH}; my $ok = 0; for my $d (@d) { if (-e "$d/libsunmath.so" or -e "$d/libsunmath.a" ) { $libs = "-lsunmath $libs"; $ok = 1; last; } } if (!$ok) { print "libsunmath not found in LD_LIBRARY_PATH: looking elsewhere\n"; # get root directory of compiler; may be off of there my @dirs = (); foreach my $p ( split(':', $ENV{'PATH'} ) ) { next unless -e "$p/$Config{cc}"; push @dirs, dirname($p) . '/lib'; last; } push @dirs, '/opt/SUNWspro/lib'; # default location if all else fails for my $d ( @dirs ) { if (-e "$d/libsunmath.so") { $libs = "-R$d -L$d -lsunmath $libs"; $ok = 1; last; } if (-e "$d/libsunmath.a") { $libs = "-L$d -lsunmath $libs"; $ok = 1; last; } } } if (!$ok) { print "Couldn't find sunmath library in standard places\n"; print "If you can find libsunmath.a or libsunmath.so\n"; print "please let us know at pdl-devel\@lists.sourceforge.net\n"; } } # Test for absence of unary functions use Cwd; my $mmdir = my $mdir = cdir 'Basic','Math'; $mmdir =~ s/\\/\\\\/g; my $dir = File::Spec->canonpath(cwd); $dir = cdir $dir, $mdir unless $dir =~ /$mmdir$/; die "TEMPDIR not found in %PDL::Config" unless $PDL::Config{TEMPDIR} && $PDL::Config{TEMPDIR}; # avoid 'only once' foreach (@sfuncs) { $source{$_} = 'system' if is_sys_func( "$_();", $libs, $dir ); } foreach (@ufuncs2) { $source{$_} = 'system' if is_sys_func( "$_(1.);", $libs, $dir ); } # Test for absence of besfuncs foreach (@besufuncs) { if ( is_sys_func( "$_(1.);", $libs, $dir ) ) { $source{$_} = 'system'; next if $_ ne 'y0'; } } foreach (@besbifuncs) { next if ! exists $source{$_}; # May have been deleted in buggy case $source{$_} = 'system' if is_sys_func( "$_(1,1.);", $libs, $dir ); } print "Source of functions\nSystem: "; foreach (@keys) { print " $_" if $source{$_} eq 'system'; } print "\nDistribution:"; foreach (@keys) { print " $_" if $source{$_} ne 'system'; } print "\n"; my @pack = (["math.pd", qw(Math PDL::Math)]); my %hash = pdlpp_stdargs_int(@pack); my %seen = (); # Build object file list foreach my $func (@keys) { my $file = $source{$func}; next if $file eq 'system'; die "File for function $func not found\n" if $file eq ''; $hash{OBJECT} .= " $file\$(OBJ_EXT)" unless $seen{$file}++; $hash{DEFINE} .= ' -DMY_'.uc($func); } # Add support routines $hash{OBJECT} .= " const\$(OBJ_EXT) mtherr\$(OBJ_EXT) polevl\$(OBJ_EXT)"; $hash{LIBS}->[0] .= " $libs"; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Basic/Math/math.pd0000644060175006010010000002574513036512174013603 0ustar chmNone use strict; use Config; pp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::Math - extended mathematical operations and special functions =head1 SYNOPSIS use PDL::Math; use PDL::Graphics::TriD; imag3d [SURF2D,bessj0(rvals(zeroes(50,50))/2)]; =head1 DESCRIPTION This module extends PDL with more advanced mathematical functions than provided by standard Perl. All the functions have one input pdl, and one output, unless otherwise stated. Many of the functions are linked from the system maths library or the Cephes maths library (determined when PDL is compiled); a few are implemented entirely in PDL. =cut ### Kludge for backwards compatibility with older scripts ### This should be deleted at some point later than 21-Nov-2003. BEGIN {use PDL::MatrixOps;} EOD # Internal doc util my %doco; sub doco { my @funcs = @_; my $doc = pop @funcs; for (@funcs) { $doco{$_} = $doc } } doco (qw/acos asin atan tan/, 'The usual trigonometric function.'); doco (qw/cosh sinh tanh acosh asinh atanh/, 'The standard hyperbolic function.'); doco (qw/ceil floor/, 'Round to integer values in floating-point format.'); doco ('rint', q/=for ref Round to integer values in floating-point format. =for method rint uses the 'round half to even' rounding method (also known as banker's rounding). Half-integers are rounded to the nearest even number. This avoids a slight statistical bias inherent in always rounding half-integers up or away from zero. If you are looking to round half-integers up (regardless of sign), try C. If you want to round half-integers away from zero, try C<< floor(abs($x)+0.5)*($x<=>0) >>./); doco( 'pow',"Synonym for `**'."); doco ('erf',"The error function."); doco ('erfc',"The complement of the error function."); doco ('erfi',"The inverse of the error function."); doco ('ndtri', "=for ref The value for which the area under the Gaussian probability density function (integrated from minus infinity) is equal to the argument (cf L)."); doco(qw/bessj0 bessj1/, "The regular Bessel function of the first kind, J_n" ); doco(qw/bessy0 bessy1/, "The regular Bessel function of the second kind, Y_n." ); doco( qw/bessjn/, '=for ref The regular Bessel function of the first kind, J_n . This takes a second int argument which gives the order of the function required. '); doco( qw/bessyn/, '=for ref The regular Bessel function of the first kind, Y_n . This takes a second int argument which gives the order of the function required. '); if ($^O !~ /win32/i || $Config{cc} =~ /\bgcc/i) { # doesn't seem to be in the MS VC lib doco( 'lgamma' ,<<'EOD'); =for ref log gamma function This returns 2 piddles -- the first set gives the log(gamma) values, while the second set, of integer values, gives the sign of the gamma function. This is useful for determining factorials, amongst other things. EOD } # if: $^O !~ win32 pp_addhdr(' #include #include "protos.h" /* Change names when fixing glibc-2.1 bug */ #ifdef MY_FIXY0 #define y0(a) fixy0(a) extern double fixy0(double a); #endif #ifdef MY_FIXYN #define yn(a,b) fixyn(a,b) extern double fixyn(int a, double b); #endif '); ## handle various cases of 'finite' # if ($^O =~ /MSWin/) { # _finite in VC++ 4.0 pp_addhdr(' #define finite _finite #include #ifdef _MSC_VER double rint (double); #endif '); } # patch from Albert Chin if ($^O =~ /hpux|darwin/) { pp_addhdr(' #ifdef isfinite #define finite isfinite #endif '); } # Standard `-lm' my (@ufuncs1) = qw(acos asin atan cosh sinh tan tanh); # F,D only my (@ufuncs1g) = qw(ceil floor rint); # Any type # Note: # ops.pd has a power() function that does the same thing # (although it has OtherPars => 'int swap;' as well) # - left this in for now. # my (@bifuncs1) = qw(pow); # Any type # Extended `-lm' my (@ufuncs2) = qw(acosh asinh atanh erf erfc); # F,D only my (@besufuncs) = qw(j0 j1 y0 y1); # " my (@besbifuncs) = qw(jn yn); # " # Need igamma, ibeta, and a fall-back implementation of the above sub code_ufunc { return '$b() = ' . $_[0] . '($a());'; } sub badcode_ufunc { my $name = $_[0]; return 'if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = ' . $name . '($a()); }'; } sub code_bifunc { my $name = $_[0]; my $a = $_[1] || 'a'; my $b = $_[2] || 'b'; my $c = $_[3] || 'c'; return "\$$c() = $name(\$$a(),\$$b());"; } sub badcode_bifunc { my $name = $_[0]; my $a = $_[1] || 'a'; my $b = $_[2] || 'b'; my $c = $_[3] || 'c'; return 'if ( $ISBAD('.$a.'()) || $ISBAD('.$b.'()) ) { $SETBAD('.$c.'()); } else { ' . "\$$c() = $name(\$$a(),\$$b()); }"; } sub inplace_doc { my $func = shift; return "$doco{$func} Works inplace."; } my $func; foreach $func (@ufuncs1) { pp_def($func, HandleBad => 1, NoBadifNaN => 1, GenericTypes => ['F','D'], Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $func ), Code => code_ufunc($func), BadCode => badcode_ufunc($func), ); } foreach $func (@ufuncs1g) { pp_def($func, HandleBad => 1, NoBadifNaN => 1, Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $func ), Code => code_ufunc($func), BadCode => badcode_ufunc($func), ); } foreach $func (@bifuncs1) { pp_def($func, HandleBad => 1, NoBadifNaN => 1, Pars => 'a(); b(); [o]c();', Inplace => [ 'a' ], Doc => inplace_doc( $func ), Code => code_bifunc($func), BadCode => badcode_bifunc($func), ); } # Functions provided by extended -lm foreach $func (@ufuncs2) { pp_def($func, HandleBad => 1, NoBadifNaN => 1, GenericTypes => ['F','D'], Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $func ), Code => code_ufunc($func), BadCode => badcode_ufunc($func), ); } foreach $func (@besufuncs) { my $fname = "bess$func"; pp_def($fname, HandleBad => 1, NoBadifNaN => 1, GenericTypes => ['F','D'], Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $fname ), Code => code_ufunc($func), BadCode => badcode_ufunc($func), ); } foreach $func (@besbifuncs) { my $fname = "bess$func"; pp_def($fname, HandleBad => 1, NoBadifNaN => 1, GenericTypes => ['F','D'], Pars => 'a(); int n(); [o]b();', Inplace => [ 'a' ], Doc => inplace_doc( $fname ), Code => code_bifunc($func,'n','a','b'), BadCode => badcode_bifunc($func,'n','a','b'), ); } if ($^O !~ /win32/i) { pp_def("lgamma", HandleBad => 1, Pars => 'a(); [o]b(); int[o]s()', Doc => $doco{"lgamma"}, Code => 'extern int signgam; $b() = lgamma($a()); $s() = signgam;', # what happens to signgam if $a() is bad? BadCode => 'extern int signgam; if ( $ISBAD(a()) ) { $SETBAD(b()); $SETBAD(s()); } else { $b() = lgamma($a()); $s() = signgam; }', ); } # if: os !~ win32 elsif ($Config{cc} =~ /\bgcc/i) { pp_def("lgamma", HandleBad => 1, Pars => 'a(); [o]b(); int[o]s()', Doc => $doco{"lgamma"}, Code => '$b() = lgamma($a()); $s() = tgamma($a()) < 0 ? -1 : 1;', # what happens to signgam if $a() is bad? BadCode => 'if ( $ISBAD(a()) ) { $SETBAD(b()); $SETBAD(s()); } else { $b() = lgamma($a()); $s() = tgamma($a()) < 0 ? -1 : 1; }', ); } # elsif: cc =~ /\bgcc/i pp_def( 'badmask', Pars => 'a(); b(); [o]c();', Inplace => [ 'a' ], HandleBad => 1, Code => '$c() = finite($a()) ? $a() : $b();', BadCode => '$c() = ( finite($a()) && $ISGOOD(a()) ) ? $a() : $b();', CopyBadStatusCode => 'if ( a == c && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( c, 0 ); /* propagate badflag if inplace AND its changed */ $SETPDLSTATEGOOD(c); /* always make sure the output is "good" */ ', Doc => '=for ref Clears all C and C in C<$a> to the corresponding value in C<$b>. badmask can be run with C<$a> inplace: badmask($a->inplace,0); $a->inplace->badmask(0); ', BadDoc => 'If bad values are present, these are also cleared.', ); pp_def( 'isfinite', Pars => 'a(); int [o]mask();', Inplace => 1, HandleBad => 1, Code => '$mask() = finite((double) $a()) != 0;', BadCode => '$mask() = finite((double) $a()) != 0 && $ISGOOD($a());', CopyBadStatusCode => 'if ( a == mask && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( mask, 0 ); /* propagate badflag if inplace AND its changed */ $SETPDLSTATEGOOD(mask); /* always make sure the output is "good" */ ', Doc => 'Sets C<$mask> true if C<$a> is not a C or C (either positive or negative). Works inplace.', BadDoc => 'Bad values are treated as C or C.', ); # Extra functions from cephes pp_def( "erfi", HandleBad => 1, NoBadifNaN => 1, GenericTypes => ['F','D'], Pars => 'a(); [o]b()', Inplace => 1, Doc => inplace_doc( "erfi" ), Code => 'extern double ndtri(double), SQRTH; $b() = SQRTH*ndtri((1+(double)$a())/2);', BadCode => 'extern double ndtri(double), SQRTH; if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = SQRTH*ndtri((1+(double)$a())/2); }', ); pp_def( "ndtri", HandleBad => 1, NoBadifNaN => 1, GenericTypes => ['F','D'], Pars => 'a(); [o]b()', Inplace => 1, Doc => inplace_doc( "ndtri" ), Code => 'extern double ndtri(double); $b() = ndtri((double)$a());', BadCode => 'extern double ndtri(double); if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = ndtri((double)$a()); }', ); pp_def("polyroots", Pars => 'cr(n); ci(n); [o]rr(m); [o]ri(m);', RedoDimsCode => 'int sn = $PDL(cr)->dims[0]; $SIZE(m) = sn-1;', GenericTypes => ['D'], Code => ' extern int cpoly( double *cr, double *ci, int deg, double *rr, double *ri ); int deg = $SIZE(n)-1, i; if (cpoly($P(cr), $P(ci), deg, $P(rr), $P(ri))) barf("PDL::Math::polyroots failed"); ', , Doc => ' =for ref Complex roots of a complex polynomial, given coefficients in order of decreasing powers. =for usage ($rr, $ri) = polyroots($cr, $ci); ',); pp_addpm({At=>'Bot'},<<'EOD'); =head1 BUGS Hasn't been tested on all platforms to ensure Cephes versions are picked up automatically and used correctly. =head1 AUTHOR Copyright (C) R.J.R. Williams 1997 (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au) and Tuomas J. Lukka (Tuomas.Lukka@helsinki.fi). Portions (C) Craig DeForest 2002 (deforest@boulder.swri.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the PDL copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.018/Basic/Math/mconf.h0000644060175006010010000001102213036512174013557 0ustar chmNone/* mconf.h * * Common include file for math routines * * * * SYNOPSIS: * * #include "mconf.h" * * * * DESCRIPTION: * * This file contains definitions for error codes that are * passed to the common error handling routine mtherr() * (which see). * * The file also includes a conditional assembly definition * for the type of computer arithmetic (IEEE, DEC, Motorola * IEEE, or UNKnown). * * For Digital Equipment PDP-11 and VAX computers, certain * IBM systems, and others that use numbers with a 56-bit * significand, the symbol DEC should be defined. In this * mode, most floating point constants are given as arrays * of octal integers to eliminate decimal to binary conversion * errors that might be introduced by the compiler. * * For little-endian computers, such as IBM PC, that follow the * IEEE Standard for Binary Floating Point Arithmetic (ANSI/IEEE * Std 754-1985), the symbol IBMPC should be defined. These * numbers have 53-bit significands. In this mode, constants * are provided as arrays of hexadecimal 16 bit integers. * * Big-endian IEEE format is denoted MIEEE. On some RISC * systems such as Sun SPARC, double precision constants * must be stored on 8-byte address boundaries. Since integer * arrays may be aligned differently, the MIEEE configuration * may fail on such machines. * * To accommodate other types of computer arithmetic, all * constants are also provided in a normal decimal radix * which one can hope are correctly converted to a suitable * format by the available C language compiler. To invoke * this mode, define the symbol UNK. * * An important difference among these modes is a predefined * set of machine arithmetic constants for each. The numbers * MACHEP (the machine roundoff error), MAXNUM (largest number * represented), and several other parameters are preset by * the configuration symbol. Check the file const.c to * ensure that these values are correct for your computer. * * Configurations NANS, INFINITIES, MINUSZERO, and DENORMAL * may fail on many systems. Verify that they are supposed * to work on your computer. */ /* Cephes Math Library Release 2.3: June, 1995 Copyright 1984, 1987, 1989, 1995 by Stephen L. Moshier */ /* For PDL, use system defaults where possible */ #include #if !defined(WIN32) && !defined(_WIN32) && !defined(__APPLE__) /* values.h is gone on OpenBSD(?) and depracated on GNU systems */ /* can we use values.h on all UN*X systems? */ #if defined __GNUC__ #include #else #include #endif /* __GNUC__ */ #endif #if defined(_WIN32) || defined(WIN32) #include #define finite _finite #endif /* Now include system-specific stuff */ /* Look for system quiet_nan function */ #if defined __sun && ! defined __GNUC__ #include #include #include #define NANARG 1L #define NANARG_SIGNATURE long n #endif #if defined __alpha && ! defined __linux #include #include #endif #ifndef NANARG #define NANARG #define NANARG_SIGNATURE #endif /* Redefine nan so PDL doesn't die when we see one. OK, nasty, but means the C-code is still as in the original */ #define nan() quiet_nan(NANARG) /* Constant definitions for math error conditions */ #ifndef DOMAIN #define DOMAIN 1 /* argument domain error */ #endif #ifndef SING #define SING 2 /* argument singularity */ #endif #ifndef OVERFLOW #define OVERFLOW 3 /* overflow range error */ #endif #ifndef UNDERFLOW #define UNDERFLOW 4 /* underflow range error */ #endif #ifndef TLOSS #define TLOSS 5 /* total loss of precision */ #endif #ifndef PLOSS #define PLOSS 6 /* partial loss of precision */ #endif #ifndef EDOM #define EDOM 33 #endif #ifndef ERANGE #define ERANGE 34 #endif /* Complex numeral. */ typedef struct { double r; double i; } cmplx; /* Long double complex numeral. */ typedef struct { double r; double i; } cmplxl; /* Get ANSI function prototypes, if you want them. */ #ifdef __STDC__ #define ANSIPROT #include "protos.h" #else int mtherr(); #endif /* Variable for error reporting. See mtherr.c. */ extern int merror; #ifdef MY_QUIET_NAN extern double quiet_nan(NANARG_SIGNATURE); #endif #ifdef MY_INFINITY extern double infinity(); #endif extern double MACHEP; extern double UFLOWTHRESH; extern double MAXLOG; extern double MINLOG; extern double MAXNUM; #ifndef PI extern double PI; #endif extern double PIO2; extern double PIO4; extern double SQRT2; extern double SQRTH; extern double LOG2E; extern double SQ2OPI; extern double LOGE2; extern double LOGSQ2; extern double THPIO4; extern double TWOOPI; PDL-2.018/Basic/Math/mtherr.c0000644060175006010010000000447712562522363013775 0ustar chmNone/* mtherr.c * * Library common error handling routine * * * * SYNOPSIS: * * char *fctnam; * int code; * int mtherr(); * * mtherr( fctnam, code ); * * * * DESCRIPTION: * * This routine may be called to report one of the following * error conditions (in the include file mconf.h). * * Mnemonic Value Significance * * DOMAIN 1 argument domain error * SING 2 function singularity * OVERFLOW 3 overflow range error * UNDERFLOW 4 underflow range error * TLOSS 5 total loss of precision * PLOSS 6 partial loss of precision * EDOM 33 Unix domain error code * ERANGE 34 Unix range error code * * The default version of the file prints the function name, * passed to it by the pointer fctnam, followed by the * error condition. The display is directed to the standard * output device. The routine then returns to the calling * program. Users may wish to modify the program to abort by * calling exit() under severe error conditions such as domain * errors. * * Since all error conditions pass control to this function, * the display may be easily changed, eliminated, or directed * to an error logging device. * * SEE ALSO: * * mconf.h * */ /* Cephes Math Library Release 2.0: April, 1987 Copyright 1984, 1987 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include #include "mconf.h" int merror = 0; /* Notice: the order of appearance of the following * messages is bound to the error codes defined * in mconf.h. */ static char *ermsg[7] = { "unknown", /* error code 0 */ "domain", /* error code 1 */ "singularity", /* et seq. */ "overflow", "underflow", "total loss of precision", "partial loss of precision" }; int mtherr( name, code ) char *name; int code; { /* Display string passed by calling program, * which is supposed to be the name of the * function in which the error occurred: */ printf( "\n%s ", name ); /* Set global error message word */ merror = code; /* Display error message defined * by the code argument. */ if( (code <= 0) || (code >= 7) ) code = 0; printf( "%s error\n", ermsg[code] ); /* Return to calling * program */ return( 0 ); } PDL-2.018/Basic/Math/ndtr.c0000644060175006010010000001226612562522363013436 0ustar chmNone/* ndtr.c * * Normal distribution function * * * * SYNOPSIS: * * double x, y, ndtr(); * * y = ndtr( x ); * * * * DESCRIPTION: * * Returns the area under the Gaussian probability density * function, integrated from minus infinity to x: * * x * - * 1 | | 2 * ndtr(x) = --------- | exp( - t /2 ) dt * sqrt(2pi) | | * - * -inf. * * = ( 1 + erf(z) ) / 2 * = erfc(z) / 2 * * where z = x/sqrt(2). Computation is via the functions * erf and erfc. * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC -13,0 8000 2.1e-15 4.8e-16 * IEEE -13,0 30000 3.4e-14 6.7e-15 * * * ERROR MESSAGES: * * message condition value returned * erfc underflow x > 37.519379347 0.0 * */ /* erf.c * * Error function * * * * SYNOPSIS: * * double x, y, erf(); * * y = erf( x ); * * * * DESCRIPTION: * * The integral is * * x * - * 2 | | 2 * erf(x) = -------- | exp( - t ) dt. * sqrt(pi) | | * - * 0 * * The magnitude of x is limited to 9.231948545 for DEC * arithmetic; 1 or -1 is returned outside this range. * * For 0 <= |x| < 1, erf(x) = x * P4(x**2)/Q5(x**2); otherwise * erf(x) = 1 - erfc(x). * * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC 0,1 14000 4.7e-17 1.5e-17 * IEEE 0,1 30000 3.7e-16 1.0e-16 * */ /* erfc.c * * Complementary error function * * * * SYNOPSIS: * * double x, y, erfc(); * * y = erfc( x ); * * * * DESCRIPTION: * * * 1 - erf(x) = * * inf. * - * 2 | | 2 * erfc(x) = -------- | exp( - t ) dt * sqrt(pi) | | * - * x * * * For small x, erfc(x) = 1 - erf(x); otherwise rational * approximations are computed. * * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC 0, 9.2319 12000 5.1e-16 1.2e-16 * IEEE 0,26.6417 30000 5.7e-14 1.5e-14 * * * ERROR MESSAGES: * * message condition value returned * erfc underflow x > 9.231948545 (DEC) 0.0 * * */ /* Cephes Math Library Release 2.2: June, 1992 Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double SQRTH; extern double MAXLOG; static double P[] = { 2.46196981473530512524E-10, 5.64189564831068821977E-1, 7.46321056442269912687E0, 4.86371970985681366614E1, 1.96520832956077098242E2, 5.26445194995477358631E2, 9.34528527171957607540E2, 1.02755188689515710272E3, 5.57535335369399327526E2 }; static double Q[] = { /* 1.00000000000000000000E0,*/ 1.32281951154744992508E1, 8.67072140885989742329E1, 3.54937778887819891062E2, 9.75708501743205489753E2, 1.82390916687909736289E3, 2.24633760818710981792E3, 1.65666309194161350182E3, 5.57535340817727675546E2 }; static double R[] = { 5.64189583547755073984E-1, 1.27536670759978104416E0, 5.01905042251180477414E0, 6.16021097993053585195E0, 7.40974269950448939160E0, 2.97886665372100240670E0 }; static double S[] = { /* 1.00000000000000000000E0,*/ 2.26052863220117276590E0, 9.39603524938001434673E0, 1.20489539808096656605E1, 1.70814450747565897222E1, 9.60896809063285878198E0, 3.36907645100081516050E0 }; static double T[] = { 9.60497373987051638749E0, 9.00260197203842689217E1, 2.23200534594684319226E3, 7.00332514112805075473E3, 5.55923013010394962768E4 }; static double U[] = { /* 1.00000000000000000000E0,*/ 3.35617141647503099647E1, 5.21357949780152679795E2, 4.59432382970980127987E3, 2.26290000613890934246E4, 4.92673942608635921086E4 }; #define UTHRESH 37.519379347 #ifndef ANSIPROT double polevl(), p1evl(), exp(), log(), fabs(); double erf(), erfc(); #endif double ndtr(a) double a; { double x, y, z; x = a * SQRTH; z = fabs(x); if( z < SQRTH ) y = 0.5 + 0.5 * erf(x); else { y = 0.5 * erfc(z); if( x > 0 ) y = 1.0 - y; } return(y); } double erfc(a) double a; { double p,q,x,y,z; if( a < 0.0 ) x = -a; else x = a; if( x < 1.0 ) return( 1.0 - erf(a) ); z = -a * a; if( z < -MAXLOG ) { under: mtherr( "erfc", UNDERFLOW ); if( a < 0 ) return( 2.0 ); else return( 0.0 ); } z = exp(z); if( x < 8.0 ) { p = polevl( x, P, 8 ); q = p1evl( x, Q, 8 ); } else { p = polevl( x, R, 5 ); q = p1evl( x, S, 6 ); } y = (z * p)/q; if( a < 0 ) y = 2.0 - y; if( y == 0.0 ) goto under; return(y); } double erf(x) double x; { double y, z; if( fabs(x) > 1.0 ) return( 1.0 - erfc(x) ); z = x * x; y = x * polevl( z, T, 4 ) / p1evl( z, U, 5 ); return( y ); } PDL-2.018/Basic/Math/ndtri.c0000644060175006010010000001012112562522363013573 0ustar chmNone/* ndtri.c * * Inverse of Normal distribution function * * * * SYNOPSIS: * * double x, y, ndtri(); * * x = ndtri( y ); * * * * DESCRIPTION: * * Returns the argument, x, for which the area under the * Gaussian probability density function (integrated from * minus infinity to x) is equal to y. * * * For small arguments 0 < y < exp(-2), the program computes * z = sqrt( -2.0 * log(y) ); then the approximation is * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z). * There are two rational functions P/Q, one for 0 < y < exp(-32) * and the other for y up to exp(-2). For larger arguments, * w = y - 0.5, and x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)). * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC 0.125, 1 5500 9.5e-17 2.1e-17 * DEC 6e-39, 0.135 3500 5.7e-17 1.3e-17 * IEEE 0.125, 1 20000 7.2e-16 1.3e-16 * IEEE 3e-308, 0.135 50000 4.6e-16 9.8e-17 * * * ERROR MESSAGES: * * message condition value returned * ndtri domain x <= 0 -MAXNUM * ndtri domain x >= 1 MAXNUM * */ /* Cephes Math Library Release 2.1: January, 1989 Copyright 1984, 1987, 1989 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double MAXNUM; /* sqrt(2pi) */ static double s2pi = 2.50662827463100050242E0; /* approximation for 0 <= |y - 0.5| <= 3/8 */ static double P0[5] = { -5.99633501014107895267E1, 9.80010754185999661536E1, -5.66762857469070293439E1, 1.39312609387279679503E1, -1.23916583867381258016E0, }; static double Q0[8] = { /* 1.00000000000000000000E0,*/ 1.95448858338141759834E0, 4.67627912898881538453E0, 8.63602421390890590575E1, -2.25462687854119370527E2, 2.00260212380060660359E2, -8.20372256168333339912E1, 1.59056225126211695515E1, -1.18331621121330003142E0, }; /* Approximation for interval z = sqrt(-2 log y ) between 2 and 8 * i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14. */ static double P1[9] = { 4.05544892305962419923E0, 3.15251094599893866154E1, 5.71628192246421288162E1, 4.40805073893200834700E1, 1.46849561928858024014E1, 2.18663306850790267539E0, -1.40256079171354495875E-1, -3.50424626827848203418E-2, -8.57456785154685413611E-4, }; static double Q1[8] = { /* 1.00000000000000000000E0,*/ 1.57799883256466749731E1, 4.53907635128879210584E1, 4.13172038254672030440E1, 1.50425385692907503408E1, 2.50464946208309415979E0, -1.42182922854787788574E-1, -3.80806407691578277194E-2, -9.33259480895457427372E-4, }; /* Approximation for interval z = sqrt(-2 log y ) between 8 and 64 * i.e., y between exp(-32) = 1.27e-14 and exp(-2048) = 3.67e-890. */ static double P2[9] = { 3.23774891776946035970E0, 6.91522889068984211695E0, 3.93881025292474443415E0, 1.33303460815807542389E0, 2.01485389549179081538E-1, 1.23716634817820021358E-2, 3.01581553508235416007E-4, 2.65806974686737550832E-6, 6.23974539184983293730E-9, }; static double Q2[8] = { /* 1.00000000000000000000E0,*/ 6.02427039364742014255E0, 3.67983563856160859403E0, 1.37702099489081330271E0, 2.16236993594496635890E-1, 1.34204006088543189037E-2, 3.28014464682127739104E-4, 2.89247864745380683936E-6, 6.79019408009981274425E-9, }; #ifndef ANSIPROT double polevl(), p1evl(), log(), sqrt(); #endif double ndtri(y0) double y0; { double x, y, z, y2, x0, x1; int code; if( y0 <= 0.0 ) { mtherr( "ndtri", DOMAIN ); return( -MAXNUM ); } if( y0 >= 1.0 ) { mtherr( "ndtri", DOMAIN ); return( MAXNUM ); } code = 1; y = y0; if( y > (1.0 - 0.13533528323661269189) ) /* 0.135... = exp(-2) */ { y = 1.0 - y; code = 0; } if( y > 0.13533528323661269189 ) { y = y - 0.5; y2 = y * y; x = y + y * (y2 * polevl( y2, P0, 4)/p1evl( y2, Q0, 8 )); x = x * s2pi; return(x); } x = sqrt( -2.0 * log(y) ); x0 = x - log(x)/x; z = 1.0/x; if( x < 8.0 ) /* y > exp(-32) = 1.2664165549e-14 */ x1 = z * polevl( z, P1, 8 )/p1evl( z, Q1, 8 ); else x1 = z * polevl( z, P2, 8 )/p1evl( z, Q2, 8 ); x = x0 - x1; if( code != 0 ) x = -x; return( x ); } PDL-2.018/Basic/Math/NOTES0000644060175006010010000000247612562522363013140 0ustar chmNoneNotes ----- Fixed to -DUNK (for reasons given below), but tried to get as much information on system specifics as possible from header files (may need to reconfigure mconf.h on systems other than Linux/Sun/Dec). Altered handling of nan and infinity to try to provide a consistent interface through function calls (system dependencies go in Makefile.PL, mconf.h: infinity.c and quiet_nan.c may need more obscure fallback ways of generating Inf and NaN for clever-clever compilers). More work will now be necessary to include extra cephes routines, but should be easier to configure what's there for new OSs. RJRW 29/10/98 - added linalg.shar TJL 5/1/98 Cephes lib config ----------------- I leave the default as -DUNK (mconf.h). This is OK as all it means is that the important constants are in floating point format rather than binary hex. The only advantage of the latter is that it is exact, however we prefer portability to exactly the same numbers at the epsilon level. (After all PDL also uses system routines). We can ignore the comments about BIGENDIAN - it is not used in any of the .c files we have taken from cephes, **AT LEAST SO FAR**. The PP code includes protos.h whether or not the system routines are used. Since the prototypes for system and cephes versions should be the same this is not a big deal. KGB 28/11/97 PDL-2.018/Basic/Math/polevl.c0000644060175006010010000000311412562522363013760 0ustar chmNone/* polevl.c * p1evl.c * XXX * * Evaluate polynomial * * * * SYNOPSIS: * * int N; * double x, y, coef[N+1], polevl[]; * * y = polevl( x, coef, N ); * * * * DESCRIPTION: * * Evaluates polynomial of degree N: * * 2 N * y = C + C x + C x +...+ C x * 0 1 2 N * * Coefficients are stored in reverse order: * * coef[0] = C , ..., coef[N] = C . * N 0 * * The function p1evl() assumes that coef[N] = 1.0 and is * omitted from the array. Its calling arguments are * otherwise the same as polevl(). * * * SPEED: * * In the interest of speed, there are no checks for out * of bounds arithmetic. This routine is used by most of * the functions in the library. Depending on available * equipment features, the user may wish to rewrite the * program in microcode or assembly language. * */ /* Cephes Math Library Release 2.1: December, 1988 Copyright 1984, 1987, 1988 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ double polevl( x, coef, N ) double x; double coef[]; int N; { double ans; int i; double *p; p = coef; ans = *p++; i = N; do ans = ans * x + *p++; while( --i ); return( ans ); } /* p1evl() */ /* N * Evaluate polynomial when coefficient of x is 1.0. * Otherwise same as polevl. */ double p1evl( x, coef, N ) double x; double coef[]; int N; { double ans; double *p; int i; p = coef; ans = x + *p++; i = N-1; do ans = ans * x + *p++; while( --i ); return( ans ); } PDL-2.018/Basic/Math/protos.h0000644060175006010010000000264012562522363014015 0ustar chmNone/* * This file was automatically generated by version 1.7 of cextract. * Manual editing not recommended. * * Created: Fri Nov 28 17:00:03 1997 */ #ifndef __CEXTRACT__ #if __STDC__ extern double asinh ( double xx ); extern double j0 ( double x ); extern double y0 ( double x ); extern double jn ( int n, double x ); extern double ndtr ( double a ); extern double erfc ( double a ); extern double erf ( double x ); extern double acosh ( double x ); extern double atanh ( double x ); extern double j1 ( double x ); extern double y1 ( double x ); extern int mtherr ( char *name, int code ); extern double polevl ( double x, double coef[], int N ); extern double p1evl ( double x, double coef[], int N ); extern double yn ( int n, double x ); #else /* __STDC__ */ extern double asinh (/* double xx */); extern double j0 (/* double x */); extern double y0 (/* double x */); extern double jn (/* int n, double x */); extern double ndtr (/* double a */); extern double erfc (/* double a */); extern double erf (/* double x */); extern double acosh (/* double x */); extern double atanh (/* double x */); extern double j1 (/* double x */); extern double y1 (/* double x */); extern int mtherr (/* char *name, int code */); extern double polevl (/* double x, double coef[], int N */); extern double p1evl (/* double x, double coef[], int N */); extern double yn (/* int n, double x */); #endif /* __STDC__ */ #endif /* __CEXTRACT__ */ PDL-2.018/Basic/Math/quiet_nan.c0000644060175006010010000000034313036512174014437 0ustar chmNone#include "mconf.h" /* Patch NaN function where no system NaN is available */ double quiet_nan(NANARG_SIGNATURE) { #ifdef NaN double a; return NaN(a); #else double a=0; return 0./a; /* Expect bad value error */ #endif } PDL-2.018/Basic/Math/rint.c0000644060175006010010000000263412562522363013441 0ustar chmNone/* * Round to neareast integer * * SYNOPSIS: * * double rint(double x); * * DESCRIPTION: * * Returns the integer (represented as a double precision number) * nearest to x. For half-integers, this implements "banker's * rounding", or round-half-to-even, in which half integers are * rounded to the nearest even integer. For other floating-point * numbers, returns floor(x + 0.5); * * Copyright (c) 1998, Raphael Manfredi * (c) 2010, Derek Lamb Note that other functions in PDL::Math use code from the Cephes math library. If this new Banker's rounding code causes some problems, it is possible to rename the round.c provided therein and use it here. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. */ #include "mconf.h" double rint(x) double x; { //could do recursion but this is probably more memory efficient. int i = x; //just get the integer part if (x<0 && (i==x+0.5)){//if it is a neg half integer return i-(i&1); //subtract one if it is odd } else if (x>0 && (i==x-0.5)){//if it is a pos half integer return i+(i&1); //add one if it is odd } else return floor(x+0.5); } PDL-2.018/Basic/Math/yn.c0000644060175006010010000000344212562522363013111 0ustar chmNone/* yn.c * * Bessel function of second kind of integer order * * * * SYNOPSIS: * * double x, y, yn(); * int n; * * y = yn( n, x ); * * * * DESCRIPTION: * * Returns Bessel function of order n, where n is a * (possibly negative) integer. * * The function is evaluated by forward recurrence on * n, starting with values computed by the routines * y0() and y1(). * * If n = 0 or 1 the routine for y0 or y1 is called * directly. * * * * ACCURACY: * * * Absolute error, except relative * when y > 1: * arithmetic domain # trials peak rms * DEC 0, 30 2200 2.9e-16 5.3e-17 * IEEE 0, 30 30000 3.4e-15 4.3e-16 * * * ERROR MESSAGES: * * message condition value returned * yn singularity x = 0 MAXNUM * yn overflow MAXNUM * * Spot checked against tables for x, n between 0 and 100. * */ /* Cephes Math Library Release 2.1: December, 1988 Copyright 1984, 1987 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double MAXNUM, MAXLOG; #ifdef MY_FIXYN double fixyn( n, x ) #else double yn( n, x ) #endif int n; double x; { double an, anm1, anm2, r; double y0(), y1(), log(); int k, sign; if( n < 0 ) { n = -n; if( (n & 1) == 0 ) /* -1**n */ sign = 1; else sign = -1; } else sign = 1; if( n == 0 ) return( sign * y0(x) ); if( n == 1 ) return( sign * y1(x) ); /* test for overflow */ if( x <= 0.0 ) { mtherr( "yn", SING ); return( -MAXNUM ); } /* forward recurrence on n */ anm2 = y0(x); anm1 = y1(x); k = 1; r = 2 * k; do { an = r * anm1 / x - anm2; anm2 = anm1; anm1 = an; r += 2.0; ++k; } while( k < n ); return( sign * an ); } PDL-2.018/Basic/Matrix.pm0000644060175006010010000002262512562522363013234 0ustar chmNone=head1 NAME PDL::Matrix -- a convenience matrix class for column-major access =head1 VERSION This document refers to version PDL::Matrix 0.5 of PDL::Matrix =head1 SYNOPSIS use PDL::Matrix; $m = mpdl [[1,2,3],[4,5,6]]; $m = PDL::Matrix->pdl([[1,2,3],[4,5,6]]); $m = msequence(4,3); @dimsa = $a->mdims; # 'dims' is not overloaded $v = vpdl [0,1,2,3] $v = vzeroes(4); =head1 DESCRIPTION =head2 Overview This package tries to help people who want to use PDL for 2D matrix computation with lots of indexing involved. It provides a PDL subclass so one- and two-dimensional piddles that are used as vectors resp and matrices can be typed in using traditional matrix convention. If you want to know more about matrix operation support in PDL, you want to read L or L. The original pdl class refers to the first index as the first row, the second index as the first column of a matrix. Consider print $B = sequence(3,2) [ [0 1 2] [3 4 5] ] which gives a 2x3 matrix in terms of the matrix convention, but the constructor used (3,2). This might get more confusing when using slices like sequence(3,2)->slice("1:2,(0)") : with traditional matrix convention one would expect [2 4] instead of [1 2]. This subclass PDL::Matrix overloads the constructors and indexing functions of pdls so that they are compatible with the usual matrix convention, where the first dimension refers to the row of a matrix. So now, the above example would be written as print $B = PDL::Matrix->sequence(3,2) # or $B = msequence(3,2) [ [0 1] [2 3] [4 5] ] Routines like L or L can be used without any changes. Furthermore one can construct and use vectors as n x 1 matrices without mentioning the second index '1'. =head2 Implementation C works by overloading a number of PDL constructors and methods such that first and second args (corresponding to first and second dims of corresponding matrices) are effectively swapped. It is not yet clear if PDL::Matrix achieves a consistent column-major look-and-feel in this way. =head1 NOTES As of version 0.5 (rewrite by CED) the matrices are stored in the usual way, just constructed and stringified differently. That way indexing and everything else works the way you think it should. =head1 FUNCTIONS =cut package PDL::Matrix; @EXPORT_OK = (); #use PDL::Core; #use PDL::Slatec; use PDL::Exporter; use Carp; @ISA = qw/PDL::Exporter PDL/; our $VERSION = "0.5"; $VERSION = eval $VERSION; #######################################################################= ######### # # overloads use overload( '""' => \&string, 'x' => sub {my $foo = $_[0]->null(); &PDL::Primitive::matmult(@_[1,0],$foo); $foo;} ); sub string { my ($me,@a) = shift; return $me->SUPER::string(@a) unless($me->ndims > 0); $me = $me->dummy(1,1) unless($me->ndims > 1); $me->xchg(0,1)->SUPER::string(@a); } # --------> constructors =head2 mpdl, PDL::Matrix::pdl =for ref constructs an object of class PDL::Matrix which is a piddle child class. =for example $m = mpdl [[1,2,3],[4,5,6]]; $m = PDL::Matrix->pdl([[1,2,3],[4,5,6]]); =cut sub pdl { my $class = shift; my $pdl = $class->SUPER::pdl(@_); if($pdl->ndims > 0) { $pdl = $pdl->dummy(1,1) unless $pdl->ndims > 1; $pdl = $pdl->xchg(0,1); } bless $pdl, ref $class || $class; } =head2 mzeroes, mones, msequence =for ref constructs a PDL::Matrix object similar to the piddle constructors zeroes, ones, sequence. =cut for my $func (qw /pdl zeroes ones sequence dims/) { push @EXPORT_OK, "m$func"; eval " sub m$func { PDL::Matrix->$func(\@_) }; "; } =head2 vpdl =for ref constructs an object of class PDL::Matrix which is of matrix dimensions (n x 1) =for example print $v = vpdl [0,1]; [ [0] [1] ] =cut sub vpdl { my $pdl = PDL->pdl(@_); bless $pdl, PDL::Matrix; } push @EXPORT_OK, "vpdl"; =head2 vzeroes, vones, vsequence =for ref constructs a PDL::Matrix object with matrix dimensions (n x 1), therefore only the first scalar argument is used. =for example print $v = vsequence(2); [ [0] [1] ] =cut for my $func (qw /zeroes ones sequence/) { push @EXPORT_OK, "v$func"; my $code = << "EOE"; sub v$func { my \@arg = \@_; ref(\$arg[0]) ne 'PDL::Type' ? (\@arg = (\$arg[0],1)) : (\@arg = (\$arg[0],\$arg[1],1)); PDL::Matrix->$func(\@arg); } EOE # print "evaluating $code\n"; eval $code; } eval "use PDL::Slatec"; my $has_slatec = ($@ ? 0 : 1); sub inv { my $self = shift; croak "inv: PDL::Slatec not available" unless $has_slatec; return $self->matinv; } =head2 kroneckerproduct =for ref returns kroneckerproduct of two matrices. This is not efficiently implemented. =for example print kroneckerproduct(msequence(2,2),mones(2,2)) [ [0 0 1 1] [0 0 1 1] [2 2 3 3] [2 2 3 3] ] =cut # returns kroneckerproduct of two matrices sub kroneckerproduct { my @arg = @_; my ($r0,$c0) = $arg[0]->mdims; my ($r1,$c1) = $arg[1]->mdims; my $out = mzeroes($r0*$r1,$c0*$c1); for (my $i=0;$i<$r0;$i++) { for (my $j=0;$j<$c0;$j++) { ($_ = $out->slice(($i*$r1).":".(($i+1)*$r1-1).",". ($j*$c1).":".(($j+1)*$c1-1)) ) .= $arg[0]->at($i,$j) * $arg[1]; } } return $out; } push @EXPORT_OK, "kroneckerproduct"; sub rotate { my ($self,@args) = @_; return $self->transpose->SUPER::rotate(@args)->transpose; } sub msumover { my ($mpdl) = @_; return PDL::sumover(transpose($mpdl)->xchg(0,2)); } push @EXPORT_OK, "msumover"; =head2 det_general =for ref returns a generalized determinant of a matrix. If the matrix is not regular, one can specify the rank of the matrix and the corresponding subdeterminant is returned. This is implemented using the C function. =for example print msequence(3,3)->determinant(2) # determinant of # regular 2x2 submatrix -24 =cut # sub det_general { my ($mpdl,$rank) = @_; my $eigenvalues = (PDL::Math::eigens($mpdl))[1]; my @sort = list(PDL::Ufunc::qsorti(abs($eigenvalues))); $eigenvalues = $eigenvalues->dice([@sort[-$rank..-1]]); PDL::Ufunc::dprod($eigenvalues); } =head2 trace =for ref returns the trace of a matrix (sum of diagonals) =cut sub trace { my ($mpdl) = @_; $mpdl->diagonal(0,1)->sum; } # this has to be overloaded so that the PDL::slice # is called and not PDL::Matrix::slice :-( sub dummy($$;$) { my ($pdl,$dim) = @_; $dim = $pdl->getndims+1+$dim if $dim < 0; barf ("too high/low dimension in call to dummy, allowed min/max=0/" . $_[0]->getndims) if $dim>$pdl->getndims || $dim < 0; $_[2] = 1 if ($#_ < 2); $pdl->PDL::slice((','x$dim)."*$_[2]"); } # now some of my very own helper functions... # stupid function to print a PDL::Matrix object in Maple code sub stringifymaple { my ($self,@args) = @_; my ($dimR,$dimC) = mdims($self); my $s; $s .= $args[0].":=" unless $args[0] eq ""; if (defined($dimR)) { $s .= "matrix($dimR,$dimC,["; for(my $i=0;$i<$dimR;++$i) { $s .= "["; for(my $j=0;$j<$dimC;++$j) { $s .= $self->at($i,$j); $s .= "," if $j+1<$dimC; } $s .= "]"; $s .= "," if $i+1<$dimR; } $s .= "])"; } else { $s = "vector($dimC,["; for(my $i=0;$i<$dimC;++$i) { $s .= $self->at($i); $s .= "," if $i+1<$dimC; } $s .= "])"; } return $s; } sub printmaple { print stringifymaple(@_).";\n"; } # stupid function to print a PDL::Matrix object in (La)TeX code sub stringifyTeX { my ($self,@args) = @_; my ($dimR,$dimC) = mdims($self); my $s; $s .= $args[0]."=" unless $args[0] eq ""; $s .= "\\begin{pmatrix}\n"; for(my $i=0;$i<$dimR;++$i) { for(my $j=0;$j<$dimC;++$j) { $s .= $self->at($i,$j); $s .= " & " if $j+1<$dimC; } $s .= " \\\\ \n" if $i+1<$dimR; } $s .= "\n \\end{pmatrix}\n"; return $s; } sub printTeX { print stringifyTeX(@_)."\n"; } =pod =begin comment DAL commented this out 17-June-2008. It didn't work, it used the outmoded (and incorrect) ~-is-transpose convention, and it wasn't necessary since the regular cross product worked fine. =head2 vcrossp, PDL::Matrix::crossp =for ref similar to PDL::crossp, however reflecting PDL::Matrix notations #=cut # crossp for my special vectors sub crossp { my ($pdl1,$pdl2) = @_; return PDL::transpose(PDL::crossp(~$pdl1,~$pdl2)); } sub vcrossp { PDL::Matrix->crossp(\@_) } push @EXPORT_OK, "vcrossp"; =end comment =cut %EXPORT_TAGS = (Func=>[@EXPORT_OK]); 1; =head1 BUGS AND PROBLEMS Because we change the way piddles are constructed, not all pdl operators may be applied to piddle-matrices. The inner product is not redefined. We might have missed some functions/methods. Internal consistency of our approach needs yet to be established. Because PDL::Matrix changes the way slicing behaves, it breaks many operators, notably those in MatrixOps. =head1 TODO check all PDL functions, benchmarks, optimization, lots of other things ... =head1 AUTHOR(S) Stephan Heuel (stephan@heuel.org), Christian Soeller (c.soeller@auckland.ac.nz). =head1 COPYRIGHT All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut PDL-2.018/Basic/MatrixOps/0000755060175006010010000000000013110402046013332 5ustar chmNonePDL-2.018/Basic/MatrixOps/blas.c0000644060175006010010000000474112562522363014444 0ustar chmNone/* Assorted matrix functions. */ /* Multiply r (rows) by c (columns) matrix A on the left * by column vector V of dimension c on the right * to produce a (column) vector Y output of dimension r. */ void mvmpy( r, c, A, V, Y ) int r, c; double *A, *V, *Y; { register double s; double *pA, *pV, *pY; int i, j; pA = A; pY = Y; for( i=0; i e ) e = x; } } return( e ); } /* Unpack symmetric matrix T stored in lower triangular form * into a symmetric n by n square matrix S. */ void tritosquare( n, T, S ) int n; double T[], S[]; { double *pT; int i, j, ni, nj; /* offset to (i,j) element is (j*j+j)/2 + i */ pT = T; ni = 0; for( i=0; i #include "complex.h" void SSL_ComplexAssign(double re, double im, SSL_Complex *z) { z->re=re; z->im=im; } /* SSL_ComplexAssign */ void SSL_ComplexAdd(SSL_Complex z1, SSL_Complex z2, SSL_Complex *res) { res->re=z1.re+z2.re; res->im=z1.im+z2.im; } /* SSL_ComplexAdd */ void SSL_ComplexSub(SSL_Complex z1, SSL_Complex z2, SSL_Complex *res) { res->re=z1.re-z2.re; res->im=z1.im-z2.im; } /* SSL_ComplexSub */ void SSL_ComplexMul(SSL_Complex z1, SSL_Complex z2, SSL_Complex *res) { res->re=z1.re*z2.re-z1.im*z2.im; res->im=z1.re*z2.im+z1.im*z2.re; } /* SSL_ComplexMul */ void SSL_ComplexDiv(SSL_Complex a, SSL_Complex b, SSL_Complex *res) { double temp; temp=b.re*b.re+b.im*b.im; res->re=(a.re*b.re+a.im*b.im)/temp; res->im=(a.im*b.re-a.re*b.im)/temp; } /* SSL_ComplexDiv */ double SSL_ComplexNorm(SSL_Complex z) { return (sqrt(z.re*z.re+z.im*z.im)); } /* SSL_ComplexNorm */ double SSL_ComplexArg(SSL_Complex z) { return (atan2(z.im, z.re)); } /* SSL_ComplexArg */ PDL-2.018/Basic/MatrixOps/complex.h0000644060175006010010000000210112562522363015163 0ustar chmNone/* complex.h - a small library for doing complex algebra in C. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * */ #ifndef SSL_COMPLEX_H_ #define SSL_COMPLEX_H_ struct SSL_ComplexStruct { double re, im; }; /* struct SSL_ComplexStruct */ typedef struct SSL_ComplexStruct SSL_Complex; extern void SSL_ComplexAssign(double, double, SSL_Complex *); extern void SSL_ComplexAdd(SSL_Complex, SSL_Complex, SSL_Complex *); extern void SSL_ComplexSub(SSL_Complex, SSL_Complex, SSL_Complex *); extern void SSL_ComplexMul(SSL_Complex, SSL_Complex, SSL_Complex *); extern void SSL_ComplexDiv(SSL_Complex, SSL_Complex, SSL_Complex *); extern double SSL_ComplexNorm(SSL_Complex); extern double SSL_ComplexArg(SSL_Complex); #endif /* SSL_COMPLEX_H_ */ PDL-2.018/Basic/MatrixOps/eigen.c0000644060175006010010000004612312562522363014612 0ustar chmNone/* * eigen.c - calculation of eigen values and vectors. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * * Eigen is a library for computing eigenvalues and eigenvectors of general * matrices. There is only one routine exported, namely Eigen. * * The meaning of the arguments to Eigen is: * 1. The dimension of the general matrix (n). * 2. A general matrix (A). * 3. The maximal number of iterations. * 4. The precision. * 5. A vector with the eigenvalues. * 6. A matrix with the eigenvectors. * */ #include "complex.h" #include "matrix.h" #include #include void BlockCheck(double **A, int n, int i, int *block, double epsx) { /* block == 1 <=> TRUE, block == 0 <=> FALSE */ if (i==n) *block=0; else { if ((fabs(A[i-1][i]-A[i][i-1])>epsx) && (fabs(A[i-1][i-1]-A[i][i])<=epsx)) *block=1; else *block=0; } /* else */ } /* BlockCheck */ void PrintEigen(int n, double **A, double **B, double eps, FILE *outfile) { int i, j; int block; fprintf(outfile, "\nEigenvalues:\t\t\tRe\t\t\tIm\n"); i=1; do { BlockCheck(A, n, i, &block, eps); if (block==1) { fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i-1][i-1], A[i-1][i]); fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i][i], A[i][i-1]); i+=2; } else { fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i-1][i-1], 0.0); i++; } /* if else */ } while (i!=(n+1)); fprintf(outfile, "\nEigenvectors:\t\t\tRe\t\t\tIm\n"); i=1; do { BlockCheck(A, n, i, &block, eps); if (block==1) { for(j=1; j<=n; j++) fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j-1][i-1], B[j-1][i]); fprintf(outfile, "\n"); for(j=1; j<=n; j++) fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j-1][i-1], -B[j-1][i]); fprintf(outfile, "\n"); i+=2; } else { for(j=1; j<=n; j++) fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j-1][i-1], 0.0); fprintf(outfile, "\n"); i++; } /* if else */ } while (i!=(n+1)); } /* PrintEigen */ void NormalizingMatrix(int n, double **A, int fixedref, int *ref, double **V, double eps) { int j, col, block; SSL_Complex c1, c2, c3; double cd1, cd2, sqrnorm, norm, normi, max; col=1; do { if (fixedref==0) { *ref=1; SSL_ComplexAssign(V[*ref-1][col-1], V[*ref-1][col], &c1); max=SSL_ComplexNorm(c1); for(j=2; j<=n; j++) { SSL_ComplexAssign(V[j-1][col-1], V[j-1][col], &c2); sqrnorm=SSL_ComplexNorm(c2); if (sqrnorm>max) { *ref=j; max=sqrnorm; } /* if */ } /* for j */ } /* if fixedref */ BlockCheck(A, n, col, &block, eps); if (block==1) { SSL_ComplexAssign(V[*ref-1][col-1], V[*ref-1][col], &c1); for(j=1; j<=n; j++) { SSL_ComplexAssign(V[j-1][col-1], V[j-1][col], &c2); SSL_ComplexDiv(c2, c1, &c3); V[j-1][col-1]=c3.re; V[j-1][col]=c3.im; } /* for j */ col+=2; } /* if */ else { norm=fabs(V[*ref-1][col-1]); if (norm!=0.0) for(j=1; j<=n; j++) V[j-1][col-1]/=norm; col++; } /* else */ } while (col<=n); } /* NormalizingMatrix */ void Permutation(int n, double **P, double **A, double **B, int colon, double eps) { int *nr; int block, OK; double max, y, x; int im, j, ki, u, v, i, k, ii; double **AA; nr=IntVectorAlloc(n); AA=MatrixAlloc(n); MatrixCopy(n, AA, A); for(i=1; i<=n; i++) { nr[i-1]=i; for(k=1; k<=n; k++) P[i-1][k-1]=0.0; } /* for i */ i=ii=ki=1; while (i0.0) { A[i][i-1]=A[i-1][i]; A[i-1][i]=-A[i][i-1]; AA[i][i-1]=AA[i-1][i]; AA[i-1][i]=-AA[i][i-1]; for(j=1; j<=n; j++) B[j-1][i]=-B[j-1][i]; } else { A[i][i-1]=-A[i-1][i]; AA[i][i-1]=-AA[i-1][i]; } /* else */ j=i; for(k=ii; k<=(ii+1); k++) { x=AA[k-1][k-1]; AA[k-1][k-1]=A[j-1][j-1]; AA[j-1][j-1]=x; u=nr[k-1]; nr[k-1]=nr[j-1]; nr[j-1]=u; j++; } /* for k */ if (ii>1) { if (AA[ii-1][ii-1]>AA[0][0]) { j=ii; for(k=1; k<=2; k++) { x=AA[k-1][k-1]; AA[k-1][k-1]=A[j-1][j-1]; AA[j-1][j-1]=x; u=nr[k-1]; nr[k-1]=nr[j-1]; nr[j-1]=u; j++; } /* for k */ } /* if */ } /* if */ ki=i; i+=2; ii+=2; } /* if */ else i++; } /* while */ if (n>3) { do { im=ii; i=ii; max=AA[im-1][im-1]; do { i++; if (AA[i-1][i-1]>max) { im=i; max=AA[i-1][i-1]; } /* if */ } while (iii) { x=AA[ii-1][ii-1]; u=nr[ii-1]; AA[ii-1][ii-1]=max; nr[ii-1]=nr[im-1]; AA[im-1][im-1]=x; nr[im-1]=u; } /* if */ ii++; } while (ii=1; j--) { r=0.0; for(i=1; i<=(j-1); i++) r+=fabs(a[j-1][i-1]); for(i=(j+1); i<=k; i++) r+=fabs(a[j-1][i-1]); if (r==0.0) { d[k-1]=(double)j; if (j!=k) { for(i=1; i<=k; i++) { f=a[i-1][j-1]; a[i-1][j-1]=a[i-1][k-1]; a[i-1][k-1]=f; } for(i=l; i<=n; i++) { f=a[j-1][i-1]; a[j-1][i-1]=a[k-1][i-1]; a[k-1][i-1]=f; } } k--; goto L110; } /* if */ } /* for j */ L120: for(j=l; j<=k; j++) { c=0.0; for (i=l; i<=(j-1); i++) c+=fabs(a[i-1][j-1]); for(i=(j+1); i<=k; i++) c+=fabs(a[i-1][j-1]); if (c==0.0) { d[l-1]=(double)j; if (j!=l) { for(i=1; i<=k; i++) { f=a[i-1][j-1]; a[i-1][j-1]=a[i-1][l-1]; a[i-1][l-1]=f; } for(i=l; i<=n; i++) { f=a[j-1][i-1]; a[j-1][i-1]=a[l-1][i-1]; a[l-1][i-1]=f; } } l++; goto L120; } /* if */ } /* for j */ *low=l; *hi=k; for(i=l; i<=k; i++) d[i-1]=1.0; L130: noconv=0; for(i=l; i<=k; i++) { r=c=0.0; for(j=l; j<=(i-1); j++) { c+=fabs(a[j-1][i-1]); r+=fabs(a[i-1][j-1]); } /* for j */ for(j=(i+1); j<=k; j++) { c+=fabs(a[j-1][i-1]); r+=fabs(a[i-1][j-1]); } /* for j */ g=r/((double) b); f=1.0; s=c+r; L140: if (c=g) { f/=(double) b; c/=(double) b2; goto L150; } /* if */ if ((c+r)/f<(0.95*s)) { g=1.0/f; d[i-1]*=f; noconv=1; for(j=l; j<=n; j++) a[i-1][j-1]*=g; for(j=1; j<=k; j++) a[j-1][i-1]*=f; } /* if */ } /* for i */ if (noconv==1) goto L130; } /* Balance */ void BalBak(int n, int low, int hi, int m, double **z, double *d) { int i, j, k; double s; for(i=low; i<=hi; i++) { s=d[i-1]; for(j=1; j<=m; j++) z[i-1][j-1]*=s; } /* for i */ for(i=(low-1); i>=1; i--) { k=(int)floor(d[i-1]+0.5); if (k!=i) for(j=1; j<=m; j++) { s=z[i-1][j-1]; z[i-1][j-1]=z[k-1][j-1]; z[k-1][j-1]=s; } /* for j */ } /* for i */ for(i=(hi+1); i<=n; i++) { k=(int)floor(d[i-1]+0.5); if (k!=i) for(j=1; j<=m; j++) { s=z[i-1][j-1]; z[i-1][j-1]=z[k-1][j-1]; z[k-1][j-1]=s; } /* for j */ } /* for i */ } /* BalBak */ void Elmhes(int n, int k, int l, double **a, int *index) { int i, j, la, m; double x, y; la=l-1; for(m=(k+1); m<=la; m++) { i=m; x=0.0; for(j=m; j<=l; j++) if (fabs(a[j-1][m-2])>fabs(x)) { x=a[j-1][m-2]; i=j; } /* if */ index[m-1]=i; if (i!=m) { for(j=(m-1); j<=n; j++) { y=a[i-1][j-1]; a[i-1][j-1]=a[m-1][j-1]; a[m-1][j-1]=y; } /* for j */ for(j=1; j<=l; j++) { y=a[j-1][i-1]; a[j-1][i-1]=a[j-1][m-1]; a[j-1][m-1]=y; } /* for j */ } /* if */ if (x!=0.0) for(i=(m+1); i<=l; i++) { y=a[i-1][m-2]; if (y!=0.0) { a[i-1][m-2]=y/x; y/=x; for(j=m; j<=n; j++) a[i-1][j-1]-=y*a[m-1][j-1]; for(j=1; j<=l; j++) a[j-1][m-1]+=y*a[j-1][i-1]; } /* if */ } /* for i */ } /* for m */ } /* Elmhes */ void Elmtrans(int n, int low, int upp, double **h, int *index, double **v) { int i, j, k; for(i=1; i<=n; i++) { for(j=1; j<=n; j++) v[i-1][j-1]=0.0; v[i-1][i-1]=1.0; } /* for i */ for(i=(upp-1); i>=(low+1); i--) { j=index[i-1]; for(k=(i+1); k<=upp; k++) v[k-1][i-1]=h[k-1][i-2]; if (i!=j) { for(k=i; k<=upp; k++) { v[i-1][k-1]=v[j-1][k-1]; v[j-1][k-1]=0.0; } /* for k */ v[j-1][i-1]=1.0; } /* if */ } /* for i */ } /* Elmtrans */ void hqr2(int n, int low, int upp, int maxits, double macheps, double **h, double **vecs, double *wr, double *wi, int *cnt, int *fail) { int i, j, k, l, m, na, its, en, dummy; double p, q, r, s, t, w, x, y, z, ra, sa, vr, vi, norm; int notlast; SSL_Complex c1, c2, c3; *fail=0; for(i=1; i<=(low-1); i++) { wr[i-1]=h[i-1][i-1]; wi[i-1]=0.0; cnt[i-1]=0; } /* for i */ for(i=(upp+1); i<=n; i++) { wr[i-1]=h[i-1][i-1]; wi[i-1]=0.0; cnt[i-1]=0; } /* for i */ en=upp; t=0.0; L210: if (en=(low+1); l--) if (fabs(h[l-1][l-2])<= macheps*(fabs(h[l-2][l-2])+fabs(h[l-1][l-1]))) goto L231; l=low; L231: x=h[en-1][en-1]; if (l==en) goto L240; y=h[na-1][na-1]; w=h[en-1][na-1]*h[na-1][en-1]; if (l==na) goto L250; if (its==maxits) { cnt[en-1]=maxits+1; *fail=1; goto L270; } /* if */ if ((its % 10)==0) { t+=x; for(i=low; i<=en; i++) h[i-1][i-1]-=x; s=fabs(h[en-1][na-1])+fabs(h[na-1][en-3]); y=0.75*s; x=y; w=-0.4375*s*s; } /* if */ its++; for(m=(en-2); m>=l; m--) { z=h[m-1][m-1]; r=x-z; s=y-z; p=(r*s-w)/h[m][m-1]+h[m-1][m]; q=h[m][m]-z-r-s; r=h[m+1][m]; s=fabs(p)+fabs(q)+fabs(r); p/=s; q/=s; r/=s; if (m==1) goto L232; if ((fabs(h[m-1][m-2])*(fabs(q)+fabs(r)))<= (macheps*fabs(p)*(fabs(h[m-2][m-2])+fabs(z)+fabs(h[m][m])))) goto L232; } /* for m */ L232: for(i=(m+2); i<=en; i++) h[i-1][i-3]=0.0; for(i=(m+3); i<=en; i++) h[i-1][i-4]=0.0; for(k=m; k<=na; k++) { if (k!=na) notlast=1; else notlast=0; if (k!=m) { p=h[k-1][k-2]; q=h[k][k-2]; if (notlast==1) r=h[k+1][k-2]; else r=0.0; x=fabs(p)+fabs(q)+fabs(r); if (x==0.0) goto L233; p/=x; q/=x; r/=x; } /* if */ s=sqrt(p*p+q*q+r*r); if (p<0) s=-s; if (k!=m) h[k-1][k-2]=-s*x; else if (l!=m) h[k-1][k-2]=-h[k-1][k-2]; p+=s; x=p/s; y=q/s; z=r/s; q/=p; r/=p; for(j=k; j<=n; j++) { p=h[k-1][j-1]+q*h[k][j-1]; if (notlast==1) { p+=r*h[k+1][j-1]; h[k][j-1]-=p*z; } /* if */ h[k][j-1]-=p*y; h[k-1][j-1]-=p*x; } /* for j */ if ((k+3)0.0) { if (p<0.0) z=p-z; else z+=p; wr[na-1]=x+z; s=x-w/z; wr[en-1]=s; wi[na-1]=0.0; wi[en-1]=0.0; x=h[en-1][na-1]; r=sqrt(x*x+z*z); p=x/r; q=z/r; for(j=na; j<=n; j++) { z=h[na-1][j-1]; h[na-1][j-1]=q*z+p*h[en-1][j-1]; /* h[en-1][j-1]=q*h[en-1][j-1]-p*z */ h[en-1][j-1]*=q; h[en-1][j-1]-=p*z; } /* for j */ for(i=1; i<=en; i++) { z=h[i-1][na-1]; h[i-1][na-1]=q*z+p*h[i-1][en-1]; /* h[i-1][en-1]=q*h[i-1][en-1]-p*z */ h[i-1][en-1]*=q; h[i-1][en-1]-=p*z; } /* for i */ for(i=low; i<=upp; i++) { z=vecs[i-1][na-1]; vecs[i-1][na-1]=q*z+p*vecs[i-1][en-1]; /* vecs[i-1][en-1]=q*vecs[i-1][en-1]-p*z */ vecs[i-1][en-1]*=q; vecs[i-1][en-1]-=p*z; } /* for i */ } /* if */ else { wr[na-1]=x+p; wr[en-1]=x+p; wi[na-1]=z; wi[en-1]=-z; } /* else */ en-=2; goto L210; L260: norm=0.0; k=1; for(i=1; i<=n; i++) { for(j=k; j<=n; j++) norm+=fabs(h[i-1][j-1]); k=i; } /* for i */ for(en=n; en>=1; en--) { p=wr[en-1]; q=wi[en-1]; na=en-1; if (q==0.0) { m=en; h[en-1][en-1]=1.0; for(i=na; i>=1; i--) { w=h[i-1][i-1]-p; r=h[i-1][en-1]; for(j=m; j<=na; j++) r+=h[i-1][j-1]*h[j-1][en-1]; if (wi[i-1]<0.0) { z=w; s=r; } /* if */ else { m=i; if (wi[i-1]==0.0) { if (w!=0.0) h[i-1][en-1]=-r/w; else h[i-1][en-1]=-r/macheps/norm; } else { x=h[i-1][i]; y=h[i][i-1]; q=pow(wr[i-1]-p, 2.0)+wi[i-1]*wi[i-1]; t=(x*s-z*r)/q; h[i-1][en-1]=t; if (fabs(x)>fabs(z)) h[i][en-1]=(-r-w*t)/x; else h[i][en-1]=(-s-y*t)/z; } /* else */ } /* else */ } /* i */ } else if (q<0.0) { m=na; if (fabs(h[en-1][na-1])>fabs(h[na-1][en-1])) { h[na-1][na-1]=-(h[en-1][en-1]-p)/h[en-1][na-1]; h[na-1][en-1]=-q/h[en-1][na-1]; } /* if */ else { SSL_ComplexAssign(-h[na-1][en-1], 0.0, &c1); SSL_ComplexAssign(h[na-1][na-1]-p, q, &c2); SSL_ComplexDiv(c1, c2, &c3); h[na-1][na-1]=c3.re; h[na-1][en-1]=c3.im; } /* else */ h[en-1][na-1]=1.0; h[en-1][en-1]=0.0; for(i=(na-1); i>=1; i--) { w=h[i-1][i-1]-p; ra=h[i-1][en-1]; sa=0.0; for(j=m; j<=na; j++) { ra+=h[i-1][j-1]*h[j-1][na-1]; sa+=h[i-1][j-1]*h[j-1][en-1]; } /* for j */ if (wi[i-1]<0.0) { z=w; r=ra; s=sa; } /* if */ else { m=i; if (wi[i-1]==0.0) { SSL_ComplexAssign(-ra, -sa, &c1); SSL_ComplexAssign(w, q, &c2); SSL_ComplexDiv(c1, c2, &c3); h[i-1][na-1]=c3.re; h[i-1][en-1]=c3.im; } /* if */ else { x=h[i-1][i]; y=h[i][i-1]; vr=pow(wr[i-1]-p, 2.0)+wi[i-1]*wi[i-1]-q*q; vi=(wr[i-1]-p)*2.0*q; if ((vr==0.0) && (vi==0.0)) vr=macheps*norm*(fabs(w)+fabs(q)+fabs(x)+fabs(y)+fabs(z)); SSL_ComplexAssign(x*r-z*ra+q*sa, x*s-z*sa-q*ra, &c1); SSL_ComplexAssign(vr, vi, &c2); SSL_ComplexDiv(c1, c2, &c3); h[i-1][na-1]=c3.re; h[i-1][en-1]=c3.im; if (fabs(x)>(fabs(z)+fabs(q))) { h[i][na-1]=(-ra-w*h[i-1][na-1]+q*h[i-1][en-1])/x; h[i][en-1]=(-sa-w*h[i-1][en-1]-q*h[i-1][na-1])/x; } /* if */ else { SSL_ComplexAssign(-r-y*h[i-1][na-1], -s-y*h[i-1][en-1], &c1); SSL_ComplexAssign(z, q, &c2); SSL_ComplexDiv(c1, c2, &c3); h[i][na-1]=c3.re; h[i][en-1]=c3.im; } /* else */ } /* else */ } /* else */ } /* for i */ } /* if */ } /* for en */ for(i=1; i<=(low-1); i++) for(j=(i+1); j<=n; j++) vecs[i-1][j-1]=h[i-1][j-1]; for(i=(upp+1); i<=n; i++) for(j=(i+1); j<=n; j++) vecs[i-1][j-1]=h[i-1][j-1]; for(j=n; j>=low; j--) { if (j<=upp) m=j; else m=upp; l=j-1; if (wi[j-1]<0.0) { for(i=low; i<=upp; i++) { y=z=0.0; for(k=low; k<=m; k++) { y+=vecs[i-1][k-1]*h[k-1][l-1]; z+=vecs[i-1][k-1]*h[k-1][j-1]; } /* for k */ vecs[i-1][l-1]=y; vecs[i-1][j-1]=z; } /* for i */ } /* if */ else if (wi[j-1]==0.0) for(i=low; i<=upp; i++) { z=0.0; for(k=low; k<=m; k++) z+=vecs[i-1][k-1]*h[k-1][j-1]; vecs[i-1][j-1]=z; } /* for i */ } /* for j */ L270: dummy=0; } /* hqr2 */ void Eigen(int n, int ref, double **AJAC, int maxit, double eps, int fixedref, SSL_Complex *values, SSL_Complex **vectors) { double *wr, *wi, *bald, **T, **A; int i, j, ballow, balhi, max, block; int *intout; int fail; intout=IntVectorAlloc(n); wr=VectorAlloc(n); wi=VectorAlloc(n); bald=VectorAlloc(n); T=MatrixAlloc(n); A=MatrixAlloc(n); for(i=1; i<=n; i++) for(j=1; j<=n; j++) A[i-1][j-1]=AJAC[i-1][j-1]; Balance(n, 10, A, &ballow, &balhi, bald); Elmhes(n, ballow, balhi, A, intout); Elmtrans(n, ballow, balhi, A, intout, T); hqr2(n, ballow, balhi, maxit, eps, A, T, wr, wi, intout, &fail); if (fail==1) (void) fprintf(stderr, "Failure in hqr2 function. Do not trust the given eigenvectors and -values\n"); /* tmxx=0; for(i=1; i<=n; i++) if (abs(intout[i-1])>tmxx) tmxx=(int)ceil(abs(intout[i-1])); */ for(i=1; i<=n; i++) for(j=1; j<=n; j++) A[i-1][j-1]=0.0; i=1; do { if (wi[i-1]!=0.0) { A[i-1][i-1]=wr[i-1]; A[i][i]=wr[i-1]; A[i-1][i]=wi[i-1]; A[i][i-1]=wi[i]; i+=2; } /* if */ else { A[i-1][i-1]=wr[i-1]; i++; } /* else */ } while (i #include "complex.h" extern void Eigen(int, int, double **, int, double, int, SSL_Complex *, SSL_Complex **); #endif /* SSL_EIGEN_SSL */ PDL-2.018/Basic/MatrixOps/eigens.c0000644060175006010010000000623612562522363014776 0ustar chmNone/* eigens.c * * Eigenvalues and eigenvectors of a real symmetric matrix * * * * SYNOPSIS: * * int n; * double A[n*(n+1)/2], EV[n*n], E[n]; * void eigens( A, EV, E, n ); * * * * DESCRIPTION: * * The algorithm is due to J. vonNeumann. * - - * A[] is a symmetric matrix stored in lower triangular form. * That is, A[ row, column ] = A[ (row*row+row)/2 + column ] * or equivalently with row and column interchanged. The * indices row and column run from 0 through n-1. * * EV[] is the output matrix of eigenvectors stored columnwise. * That is, the elements of each eigenvector appear in sequential * memory order. The jth element of the ith eigenvector is * EV[ n*i+j ] = EV[i][j]. * * E[] is the output matrix of eigenvalues. The ith element * of E corresponds to the ith eigenvector (the ith row of EV). * * On output, the matrix A will have been diagonalized and its * orginal contents are destroyed. * * ACCURACY: * * The error is controlled by an internal parameter called RANGE * which is set to 1e-10. After diagonalization, the * off-diagonal elements of A will have been reduced by * this factor. * * ERROR MESSAGES: * * None. * */ /* Copyright 1973, 1991 by Stephen L. Moshier Copyleft version. */ void eigens( A, RR, E, N ) double A[], RR[], E[]; int N; { int IND, L, LL, LM, M, MM, MQ, I, J, K, IA, LQ; int IQ, IM, IL, NLI, NMI; double ANORM, ANORMX, AIA, THR, ALM, QI, ALL, AMM, X, Y; double SINX, SINX2, COSX, COSX2, SINCS, AIL, AIM; double RLI, RMI, Q, V; double sqrt(), fabs(); static double RANGE = 1.0e-10; /*3.0517578e-5;*/ /* Initialize identity matrix in RR[] */ for( J=0; J ANORMX ) { THR=THR/N; do { /* while IND != 0 */ IND = 0; for( L=0; L M) IM=M+IQ; else IM=I+MQ; if(I >= L) IL=L+IQ; else IL=I+LQ; AIL=A[IL]; AIM=A[IM]; X=AIL*COSX-AIM*SINX; A[IM]=AIL*SINX+AIM*COSX; A[IL]=X; } NLI = N*L + I; NMI = N*M + I; RLI = RR[ NLI ]; RMI = RR[ NMI ]; RR[NLI]=RLI*COSX-RMI*SINX; RR[NMI]=RLI*SINX+RMI*COSX; } X=2.0*ALM*SINCS; A[LL]=ALL*COSX2+AMM*SINX2-X; A[MM]=ALL*SINX2+AMM*COSX2+X; A[LM]=(ALL-AMM)*SINCS+ALM*(COSX2-SINX2); } /* for M=L+1 to N-1 */ } /* for L=0 to N-2 */ } while( IND != 0 ); } /* while THR > ANORMX */ done: ; /* Extract eigenvalues from the reduced matrix */ L=0; for( J=1; J<=N; J++ ) { L=L+J; E[J-1]=A[L-1]; } } PDL-2.018/Basic/MatrixOps/Makefile.PL0000644060175006010010000000072712562522363015331 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["matrixops.pd", qw(MatrixOps PDL::MatrixOps)]); my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} = "" unless exists $hash{OBJECT}; foreach my $file (qw (blas eigens simq svd eigen complex matrix sslib)) { $hash{OBJECT} .= " $file\$(OBJ_EXT)"; } $hash{LIBS}->[0] .= " -lm "; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile( %hash ); PDL-2.018/Basic/MatrixOps/matrix.c0000644060175006010010000003151212562522363015023 0ustar chmNone/* * matrix.c - misc. routines for manipulating matrices and vectors. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * * * The matrices and vectors are indexed in C-style, i.e. from 0 to * N-1. A matrix is assumed to be declared as double **, and it is * allocated by MatrixAlloc. * * * References: * [1] Numerical Recipes in C, 2nd edition, * W.H. Press, S.A. Teukolsky, W.T. Vitterling, and B.P. Flannery, * Cambridge University Press, 1992. * [2] Numerical Analysis, * D. Kincaid and W. Cheney, * Brooks/Cole Publishing Company, 1991. * [3] The C Programming Language, 2nd edition, * B.W. Kernighan and D.M. Ritchie, * Prentice Hall, 1988. * [4] Advanced Engineering Mathematics, 6th edition, * E. Kreyszig, * Wiley and Sons, 1988. * */ #include #include #include #ifndef TINY # define TINY 1.0e-18 #endif #include "sslib.h" #include "matrix.h" /* * MatrixAlloc allocates storage for a square matrix with dimension * n*n. An error message is printed, if it was impossible to allocate * the neccesary space, [3]. * */ double **MatrixAlloc(const int n) { double **matrix; int i; matrix=(double **)calloc(n, sizeof(double *)); if (matrix==NULL) SSLerror("No memory available in routine MatrixAlloc"); else for(i=0; i=k so ... */ not_finished=1; while (not_finished) { j++; temp=fabs(a[p[j]][k]/s[p[j]]); for(i=k; i=(fabs(a[p[i]][k])/s[p[i]])) not_finished=0; /* end loop */ } /* while */ i_swap=p[k]; p[k]=p[j]; p[j]=i_swap; temp=1.0/a[p[k]][k]; for(i=(k+1); i=0; i--) { /* back subst */ sum=b[p[i]]; for(j=(i+1); j=eps)); VectorFree(n, x_old); } /* GaussSeidel */ /* * Jacobi is an iterative equation solver, [2, pp. 185-189]. The algorithm * can be optimised a bit, which is done in this implementation. The method * is suitable for parallel computers. * * The arguments are the same as in GaussSeidel. * */ void Jacobi(const int n, double **a, double *b, double *x, double eps, int max_iter) { double d; /* temporary real */ int i, j, iter; /* counters */ double **a_new; /* a is altered */ double *b_new; /* b is altered */ double *u; /* new solution */ double norm; /* L1-norm */ a_new=MatrixAlloc(3); b_new=VectorAlloc(3); u=VectorAlloc(3); for(i=0; i=eps)); MatrixFree(3, a_new); VectorFree(3, b_new); VectorFree(3, u); } /* Jacobi */ /* * DotProd computes the dot product between two vectors. They are assumed to * be of the same dimension. * */ double DotProd(const int n, double *u, double *v) { int i; /* counter */ double sum=0.0; /* temporary real */ for(i=0; i */ for(i=0; i #include "protos.h" /* Change names when fixing glibc-2.1 bug */ #ifdef MY_FIXY0 #define y0(a) fixy0(a) extern double fixy0(double a); #endif #ifdef MY_FIXYN #define yn(a,b) fixyn(a,b) extern double fixyn(int a, double b); #endif '); ## handle various cases of 'finite' # if ($^O =~ /MSWin/) { # _finite in VC++ 4.0 pp_addhdr(' #define finite _finite #include '); } # patch from Albert Chin if ($^O =~ /hpux|darwin/) { pp_addhdr(' #ifdef isfinite #define finite isfinite #endif '); } use strict; pp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::MatrixOps -- Some Useful Matrix Operations =head1 SYNOPSIS $inv = $a->inv; $det = $a->det; ($lu,$perm,$par) = $a->lu_decomp; $x = lu_backsub($lu,$perm,$b); # solve $a x $x = $b =head1 DESCRIPTION PDL::MatrixOps is PDL's built-in matrix manipulation code. It contains utilities for many common matrix operations: inversion, determinant finding, eigenvalue/vector finding, singular value decomposition, etc. PDL::MatrixOps routines are written in a mixture of Perl and C, so that they are reliably present even when there is no FORTRAN compiler or external library available (e.g. L or any of the PDL::GSL family of modules). Matrix manipulation, particularly with large matrices, is a challenging field and no one algorithm is suitable in all cases. The utilities here use general-purpose algorithms that work acceptably for many cases but might not scale well to very large or pathological (near-singular) matrices. Except as noted, the matrices are PDLs whose 0th dimension ranges over column and whose 1st dimension ranges over row. The matrices appear correctly when printed. These routines should work OK with L objects as well as with normal PDLs. =head1 TIPS ON MATRIX OPERATIONS Like most computer languages, PDL addresses matrices in (column,row) order in most cases; this corresponds to (X,Y) coordinates in the matrix itself, counting rightwards and downwards from the upper left corner. This means that if you print a PDL that contains a matrix, the matrix appears correctly on the screen, but if you index a matrix element, you use the indices in the reverse order that you would in a math textbook. If you prefer your matrices indexed in (row, column) order, you can try using the L object, which includes an implicit exchange of the first two dimensions but should be compatible with most of these matrix operations. TIMTOWDTI.) Matrices, row vectors, and column vectors can be multiplied with the 'x' operator (which is, of course, threadable): $m3 = $m1 x $m2; $col_vec2 = $m1 x $col_vec1; $row_vec2 = $row_vec1 x $m1; $scalar = $row_vec x $col_vec; Because of the (column,row) addressing order, 1-D PDLs are treated as _row_ vectors; if you want a _column_ vector you must add a dummy dimension: $rowvec = pdl(1,2); # row vector $colvec = $rowvec->(*1); # 1x2 column vector $matrix = pdl([[3,4],[6,2]]); # 2x2 matrix $rowvec2 = $rowvec x $matrix; # right-multiplication by matrix $colvec = $matrix x $colvec; # left-multiplication by matrix $m2 = $matrix x $rowvec; # Throws an error Implicit threading works correctly with most matrix operations, but you must be extra careful that you understand the dimensionality. In particular, matrix multiplication and other matrix ops need nx1 PDLs as row vectors and 1xn PDLs as column vectors. In most cases you must explicitly include the trailing 'x1' dimension in order to get the expected results when you thread over multiple row vectors. When threading over matrices, it's very easy to get confused about which dimension goes where. It is useful to include comments with every expression, explaining what you think each dimension means: $a = xvals(360)*3.14159/180; # (angle) $rot = cat(cat(cos($a),sin($a)), # rotmat: (col,row,angle) cat(-sin($a),cos($a))); =head1 ACKNOWLEDGEMENTS MatrixOps includes algorithms and pre-existing code from several origins. In particular, C is the work of Stephen Moshier, C uses an SVD subroutine written by Bryant Marks, and C uses a subset of the Small Scientific Library by Kenneth Geisshirt. They are free software, distributable under same terms as PDL itself. =head1 NOTES This is intended as a general-purpose linear algebra package for small-to-mid sized matrices. The algorithms may not scale well to large matrices (hundreds by hundreds) or to near singular matrices. If there is something you want that is not here, please add and document it! =cut use Carp; use PDL::NiceSlice; use strict; EOD ###################################################################### pp_add_exported('','identity'); pp_addpm(<<'EOD'); =head2 identity =for sig Signature: (n; [o]a(n,n)) =for ref Return an identity matrix of the specified size. If you hand in a scalar, its value is the size of the identity matrix; if you hand in a dimensioned PDL, the 0th dimension is the size of the matrix. =cut sub identity { my $n = shift; my $out = ((UNIVERSAL::isa($n,'PDL')) ? ( ($n->getndims > 0) ? zeroes($n->dim(0),$n->dim(0)) : zeroes($n->at(0),$n->at(0)) ) : zeroes($n,$n) ); my $tmp; # work around perl -d "feature" ($tmp = $out->diagonal(0,1))++; $out; } EOD ###################################################################### pp_add_exported('','stretcher'); pp_addpm(<<'EOD'); =head2 stretcher =for sig Signature: (a(n); [o]b(n,n)) =for usage $mat = stretcher($eigenvalues); =for ref Return a diagonal matrix with the specified diagonal elements =cut sub stretcher { my $in = shift; my $out = zeroes($in->dim(0),$in->dims); my $tmp; # work around for perl -d "feature" ($tmp = $out->diagonal(0,1)) += $in; $out; } EOD ###################################################################### pp_add_exported('','inv'); pp_addpm(<<'EOD'); =head2 inv =for sig Signature: (a(m,m); sv opt ) =for usage $a1 = inv($a, {$opt}); =for ref Invert a square matrix. You feed in an NxN matrix in $a, and get back its inverse (if it exists). The code is inplace-aware, so you can get back the inverse in $a itself if you want -- though temporary storage is used either way. You can cache the LU decomposition in an output option variable. C uses C by default; that is a numerically stable (pivoting) LU decomposition method. OPTIONS: =over 3 =item * s Boolean value indicating whether to complain if the matrix is singular. If this is false, singular matrices cause inverse to barf. If it is true, then singular matrices cause inverse to return undef. =item * lu (I/O) This value contains a list ref with the LU decomposition, permutation, and parity values for C<$a>. If you do not mention the key, or if the value is undef, then inverse calls C. If the key exists with an undef value, then the output of C is stashed here (unless the matrix is singular). If the value exists, then it is assumed to hold the LU decomposition. =item * det (Output) If this key exists, then the determinant of C<$a> get stored here, whether or not the matrix is singular. =back =cut *PDL::inv = \&inv; sub inv { my $a = shift; my $opt = shift; $opt = {} unless defined($opt); barf "inverse needs a square PDL as a matrix\n" unless(UNIVERSAL::isa($a,'PDL') && $a->dims >= 2 && $a->dim(0) == $a->dim(1) ); my ($lu,$perm,$par); if(exists($opt->{lu}) && ref $opt->{lu} eq 'ARRAY' && ref $opt->{lu}->[0] eq 'PDL') { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($a); @{$opt->{lu}} = ($lu,$perm,$par) if(ref $opt->{lu} eq 'ARRAY'); } my $det = (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : pdl(0); $opt->{det} = $det if exists($opt->{det}); unless($det->nelem > 1 || $det) { return undef if $opt->{s}; barf("PDL::inv: got a singular matrix or LU decomposition\n"); } my $idenA = $a->zeros; $idenA->diagonal(0,1) .= 1; my $out = lu_backsub($lu,$perm,$par,$idenA)->xchg(0,1)->sever; return $out unless($a->is_inplace); $a .= $out; $a; } EOD ###################################################################### pp_add_exported('','det'); pp_addpm(<<'EOD'); =head2 det =for sig Signature: (a(m,m); sv opt) =for usage $det = det($a,{opt}); =for ref Determinant of a square matrix using LU decomposition (for large matrices) You feed in a square matrix, you get back the determinant. Some options exist that allow you to cache the LU decomposition of the matrix (note that the LU decomposition is invalid if the determinant is zero!). The LU decomposition is cacheable, in case you want to re-use it. This method of determinant finding is more rapid than recursive-descent on large matrices, and if you reuse the LU decomposition it's essentially free. OPTIONS: =over 3 =item * lu (I/O) Provides a cache for the LU decomposition of the matrix. If you provide the key but leave the value undefined, then the LU decomposition goes in here; if you put an LU decomposition here, it will be used and the matrix will not be decomposed again. =back =cut *PDL::det = \&det; sub det { my($a) = shift; my($opt) = shift; $opt = {} unless defined($opt); my($lu,$perm,$par); if(exists ($opt->{u}) and (ref $opt->{lu} eq 'ARRAY')) { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($a); $opt->{lu} = [$lu,$perm,$par] if(exists($opt->{lu})); } ( (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : 0 ); } EOD ###################################################################### pp_add_exported('','determinant'); pp_addpm(<<'EOD'); =head2 determinant =for sig Signature: (a(m,m)) =for usage $det = determinant($a); =for ref Determinant of a square matrix, using recursive descent (threadable). This is the traditional, robust recursive determinant method taught in most linear algebra courses. It scales like C (and hence is pitifully slow for large matrices) but is very robust because no division is involved (hence no division-by-zero errors for singular matrices). It's also threadable, so you can find the determinants of a large collection of matrices all at once if you want. Matrices up to 3x3 are handled by direct multiplication; larger matrices are handled by recursive descent to the 3x3 case. The LU-decomposition method L is faster in isolation for single matrices larger than about 4x4, and is much faster if you end up reusing the LU decomposition of C<$a> (NOTE: check performance and threading benchmarks with new code). =cut *PDL::determinant = \&determinant; sub determinant { my($a) = shift; my($n); return undef unless( UNIVERSAL::isa($a,'PDL') && $a->getndims >= 2 && ($n = $a->dim(0)) == $a->dim(1) ); return $a->clump(2) if($n==1); if($n==2) { my($b) = $a->clump(2); return $b->index(0)*$b->index(3) - $b->index(1)*$b->index(2); } if($n==3) { my($b) = $a->clump(2); my $b3 = $b->index(3); my $b4 = $b->index(4); my $b5 = $b->index(5); my $b6 = $b->index(6); my $b7 = $b->index(7); my $b8 = $b->index(8); return ( $b->index(0) * ( $b4 * $b8 - $b5 * $b7 ) + $b->index(1) * ( $b5 * $b6 - $b3 * $b8 ) + $b->index(2) * ( $b3 * $b7 - $b4 * $b6 ) ); } my($i); my($sum) = zeroes($a->((0),(0))); # Do middle submatrices for $i(1..$n-2) { my $el = $a->(($i),(0)); next if( ($el==0)->all ); # Optimize away unnecessary recursion $sum += $el * (1-2*($i%2)) * determinant( $a->(0:$i-1,1:-1)-> append($a->($i+1:-1,1:-1))); } # Do beginning and end submatrices $sum += $a->((0),(0)) * determinant($a->(1:-1,1:-1)); $sum -= $a->((-1),(0)) * determinant($a->(0:-2,1:-1)) * (1 - 2*($n % 2)); return $sum; } EOD ###################################################################### ### eigens_sym ### pp_def("eigens_sym", HandleBad => 0, Pars => '[phys]a(m); [o,phys]ev(n,n); [o,phys]e(n)', GenericTypes => ['D'], Code => ' extern void eigens( double *A, double *RR, double *E, int N ); register int sn = $SIZE (n); if($SIZE (m) != (sn * (sn + 1))/2) { barf("Wrong sized args for eigens_sym"); } eigens($P (a), $P (ev), $P (e), sn); ', PMCode =>' sub PDL::eigens_sym { my ($a) = @_; my (@d) = $a->dims; barf "Need real square matrix for eigens_sym" if $#d < 1 or $d[0] != $d[1]; my ($n) = $d[0]; my ($sym) = 0.5*($a + $a->mv(0,1)); my ($err) = PDL::max(abs($sym)); barf "Need symmetric component non-zero for eigens_sym" if $err == 0; $err = PDL::max(abs($a-$sym))/$err; warn "Using symmetrized version of the matrix in eigens_sym" if $err > 1e-5 && $PDL::debug; ## Get lower diagonal form ## Use whichND/indexND because whereND doesn\'t exist (yet?) and ## the combo is threadable (unlike where). Note that for historical ## reasons whichND needs a scalar() around it to give back a ## nice 2xn PDL index. my $lt = PDL::indexND($sym, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($sym->dims); my $e = PDL->zeroes($sym->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->xchg(0,1), $e if(wantarray); $e; #just eigenvalues } ' , Doc => ' =for ref Eigenvalues and -vectors of a symmetric square matrix. If passed an asymmetric matrix, the routine will warn and symmetrize it, by taking the average value. That is, it will solve for 0.5*($a+$a->mv(0,1)). It\'s threadable, so if C<$a> is 3x3x100, it\'s treated as 100 separate 3x3 matrices, and both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context it hands back only the eigenvalues. Ultimately, it should switch to a faster algorithm in this case (as discarding the eigenvectors is wasteful). The algorithm used is due to J. vonNeumann, which was a rediscovery of L . The eigenvectors are returned in COLUMNS of the returned PDL. That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens_sym $a; # Make eigenvector matrix $vector = $ev->($n); # Select nth eigenvector as a column-vector $vector = $ev->(($n)); # Select nth eigenvector as a row-vector =for usage ($ev, $e) = eigens_sym($a); # e-vects & e-values $e = eigens_sym($a); # just eigenvalues =cut ',); ###################################################################### ### eigens ### pp_def("eigens", HandleBad => 0, Pars => '[phys]a(m); [o,phys]ev(l,n,n); [o,phys]e(l,n)', GenericTypes => ['D'], Code => ' #include "complex.h" #include "eigen.h" register int sn = $SIZE(n); int i,j; void **foo; void **bar; New(42, foo, sn, void*); New(111, bar, sn, void*); if($SIZE (l) != 2) { barf("eigens internal error..."); } if($SIZE (m) != (sn * sn )) { fprintf(stderr,"m=%"IND_FLAG", sn=%d\n",$SIZE(m),sn); barf("Wrong sized args for eigens"); } for( i=j=0; i<$SIZE(m); i += sn ) { foo[j] = &( ($P(a))[ i ] ); bar[j] = &( ($P(ev))[ i+i ] ); j++; } Eigen( sn, 0, (double **) foo, 20*sn, 1e-13, 0, (SSL_Complex *)( $P(e) ), (SSL_Complex **) bar ); Safefree(foo); Safefree(bar); /* Check for invalid values: convenience block */ { int k; char ok, flag; PDL_Double eps = 0; /* First: find maximum eigenvalue */ for(i=0; i< sn; i++ ) { PDL_Double z = fabs ( ($P(e))[i*2] ); if( z > eps ) eps = z; } eps *= 1e-10; /* Next: scan for non-real terms and parallel vectors */ for( i=0; i < sn; i++ ) { ok = ( fabs( ($P(e))[i*2+1] ) < eps ); for( j=0; ok && j< sn; j++) ok &= fabs( ($P(ev))[ 2* (i*sn + j) + 1] ) < eps; for( k=0; ok && k < i; k++ ) { if( finite( ($P(ev))[ 2 * (k*sn) ] ) ) { for( flag=1, j=0; ok && flag && j< sn; j++) flag &= ( fabs( ($P(ev))[ 2 * (i*sn + j) ] - ($P(ev))[ 2 * (k*sn + j) ] ) < 1e-10 * ( fabs(($P(ev))[ 2 * (k*sn + j) ]) + fabs(($P(ev))[ 2 * (i*sn + j) ]) ) ); ok &= !flag; } } if (ok) { for(j=0; ok && jNaN_double; ($P(e))[i*2] = PDL->NaN_double; } } } ', PMCode =>' sub PDL::eigens { my ($a) = @_; my (@d) = $a->dims; my $n = $d[0]; barf "Need real square matrix for eigens" if $#d < 1 or $d[0] != $d[1]; my $deviation = PDL::max(abs($a - $a->mv(0,1)))/PDL::max(abs($a)); if ( $deviation <= 1e-5 ) { #taken from eigens_sym code my $lt = PDL::indexND($a, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($a->dims); my $e = PDL->zeroes($a->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->xchg(0,1), $e if wantarray; return $e; #just eigenvalues } else { if($PDL::verbose || $PDL::debug) { print "eigens: using the asymmetric case from SSL\n"; } if( !$PDL::eigens_bug_ack && !$ENV{PDL_EIGENS_ACK} ) { print STDERR "WARNING: using sketchy algorithm for PDL::eigens asymmetric case -- you might\n". " miss an eigenvector or two\nThis should be fixed in PDL v2.5 (due 2009), \n". " or you might fix it yourself (hint hint). You can shut off this warning\n". " by setting the variable $PDL::eigens_bug_ack, or the environment variable\n". " PDL_EIGENS_HACK prior to calling eigens() with a non-symmetric matrix.\n"; $PDL::eigens_bug_ack = 1; } my $ev = PDL->zeroes(2, $a->dims); my $e = PDL->zeroes(2, $a->index(0)->dims); &PDL::_eigens_int($a->clump(0,1), $ev, $e); return $ev->index(0)->xchg(0,1)->sever, $e->index(0)->sever if(wantarray); return $e->index(0)->sever; #just eigenvalues } } ' , Doc => ' =for ref Real eigenvalues and -vectors of a real square matrix. (See also L<"eigens_sym"|/eigens_sym>, for eigenvalues and -vectors of a real, symmetric, square matrix). The eigens function will attempt to compute the eigenvalues and eigenvectors of a square matrix with real components. If the matrix is symmetric, the same underlying code as L<"eigens_sym"|/eigens_sym> is used. If asymmetric, the eigenvalues and eigenvectors are computed with algorithms from the sslib library. If any imaginary components exist in the eigenvalues, the results are currently considered to be invalid, and such eigenvalues are returned as "NaN"s. This is true for eigenvectors also. That is if there are imaginary components to any of the values in the eigenvector, the eigenvalue and corresponding eigenvectors are all set to "NaN". Finally, if there are any repeated eigenvectors, they are replaced with all "NaN"s. Use of the eigens function on asymmetric matrices should be considered experimental! For asymmetric matrices, nearly all observed matrices with real eigenvalues produce incorrect results, due to errors of the sslib algorithm. If your assymmetric matrix returns all NaNs, do not assume that the values are complex. Also, problems with memory access is known in this library. Not all square matrices are diagonalizable. If you feed in a non-diagonalizable matrix, then one or more of the eigenvectors will be set to NaN, along with the corresponding eigenvalues. C is threadable, so you can solve 100 eigenproblems by feeding in a 3x3x100 array. Both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context C hands back only the eigenvalues. This is somewhat wasteful, as it calculates the eigenvectors anyway. The eigenvectors are returned in COLUMNS of the returned PDL (ie the the 0 dimension). That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens $a; # Make eigenvector matrix $vector = $ev->($n); # Select nth eigenvector as a column-vector $vector = $ev->(($n)); # Select nth eigenvector as a row-vector DEVEL NOTES: For now, there is no distinction between a complex eigenvalue and an invalid eigenvalue, although the underlying code generates complex numbers. It might be useful to be able to return complex eigenvalues. =for usage ($ev, $e) = eigens($a); # e\'vects & e\'vals $e = eigens($a); # just eigenvalues =cut ',); ###################################################################### ### svd pp_def( "svd", HandleBad => 0, Pars => 'a(n,m); [o]u(n,m); [o,phys]z(n); [o]v(n,n);', GenericTypes => ['D'], Code => ' extern void SVD( double *W, double *Z, int nRow, int nCol ); int sm = $SIZE (m), sn = $SIZE (n), i; if (sm= n (you have m=%d and n=%d). Try inputting the transpose. See the docs for svd.",sm,sn); } double *w, *t, zv; t = w = (double *) malloc(sn*(sm+sn)*sizeof(double)); loop (m) %{ loop(n) %{ *t++ = $a (); %} %} SVD(w, $P (z), sm, sn); t = w; loop (n) %{ zv = sqrt($z ()); $z () = zv; %} loop (m) %{ loop (n) %{ $u () = *t++/$z (); %} %} loop (n) %{ for (i=0;ii, n1=>n) = *t++; } %} free(w); ', , Doc => q{ =for usage ($u, $s, $v) = svd($a); =for ref Singular value decomposition of a matrix. C is threadable. Given an m x n matrix C<$a> that has m rows and n columns (m >= n), C computes matrices C<$u> and C<$v>, and a vector of the singular values C<$s>. Like most implementations, C computes what is commonly referred to as the "thin SVD" of C<$a>, such that C<$u> is m x n, C<$v> is n x n, and there are <=n singular values. As long as m >= n, the original matrix can be reconstructed as follows: ($u,$s,$v) = svd($a); $ess = zeroes($a->dim(0),$a->dim(0)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$a->dim(0)-1); #generic diagonal $a_copy = $u x $ess x $v->transpose; If m==n, C<$u> and C<$v> can be thought of as rotation matrices that convert from the original matrix's singular coordinates to final coordinates, and from original coordinates to singular coordinates, respectively, and $ess is a diagonal scaling matrix. If n>m, C will barf. This can be avoided by passing in the transpose of C<$a>, and reconstructing the original matrix like so: ($u,$s,$v) = svd($a->transpose); $ess = zeroes($a->dim(1),$a->dim(1)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$a->dim(1)-1); #generic diagonal $a_copy = $v x $ess x $u->transpose; EXAMPLE The computing literature has loads of examples of how to use SVD. Here's a trivial example (used in L) of how to make a matrix less, er, singular, without changing the orientation of the ellipsoid of transformation: { my($r1,$s,$r2) = svd $a; $s++; # fatten all singular values $r2 *= $s; # implicit threading for cheap mult. $a .= $r2 x $r1; # a gets r2 x ess x r1 } =cut },); ###################################################################### pp_add_exported('','lu_decomp'); pp_addpm(<<'EOD'); =head2 lu_decomp =for sig Signature: (a(m,m); [o]lu(m,m); [o]perm(m); [o]parity) =for ref LU decompose a matrix, with row permutation =for usage ($lu, $perm, $parity) = lu_decomp($a); $lu = lu_decomp($a, $perm, $par); # $perm and $par are outputs! lu_decomp($a->inplace,$perm,$par); # Everything in place. =for description C returns an LU decomposition of a square matrix, using Crout's method with partial pivoting. It's ported from I. The partial pivoting keeps it numerically stable but means a little more overhead from threading. C decomposes the input matrix into matrices L and U such that LU = A, L is a subdiagonal matrix, and U is a superdiagonal matrix. By convention, the diagonal of L is all 1's. The single output matrix contains all the variable elements of both the L and U matrices, stacked together. Because the method uses pivoting (rearranging the lower part of the matrix for better numerical stability), you have to permute input vectors before applying the L and U matrices. The permutation is returned either in the second argument or, in list context, as the second element of the list. You need the permutation for the output to make any sense, so be sure to get it one way or the other. LU decomposition is the answer to a lot of matrix questions, including inversion and determinant-finding, and C is used by L. If you pass in C<$perm> and C<$parity>, they either must be predeclared PDLs of the correct size ($perm is an n-vector, C<$parity> is a scalar) or scalars. If the matrix is singular, then the LU decomposition might not be defined; in those cases, C silently returns undef. Some singular matrices LU-decompose just fine, and those are handled OK but give a zero determinant (and hence can't be inverted). C uses pivoting, which rearranges the values in the matrix for more numerical stability. This makes it really good for large and even near-singular matrices. There is a non-pivoting version C available which is from 5 to 60 percent faster for typical problems at the expense of failing to compute a result in some cases. Now that the C is threaded, it is the recommended LU decomposition routine. It no longer falls back to C. C is ported from I to PDL. It should probably be implemented in C. =cut *PDL::lu_decomp = \&lu_decomp; sub lu_decomp { my($in) = shift; my($permute) = shift; my($parity) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $permute) { barf('lu_decomp: permutation vector must match the matrix') if(!UNIVERSAL::isa($permute,'PDL') || $permute->ndims != 1 || $permute->dim(0) != $out->dim(0)); $permute .= PDL->xvals($in->dim(0)); } else { $permute = $in->((0))->xvals; } if(defined $parity) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($parity,'PDL') || $parity->dim(0) != 1); $parity .= 1.0; } else { $parity = $in->((0),(0))->ones; } my($scales) = $in->abs->maximum; # elementwise by rows if(($scales==0)->sum) { return undef; } # Some holding tanks my($tmprow) = $out->((0))->double->zeroes; my($tmpval) = $tmprow->((0))->sever; my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->(($col),0:$klim) * $out->(0:$klim,($row)) )->sumover; } } # Figure a_ij, with pivoting if($col < $n1) { # Find the maximum value in the rest of the row my $sl = $out->(($col),$col:$n1); my $wh = $sl->abs->maximum_ind; my $big = $sl->index($wh)->sever; # Permute if necessary to make the diagonal the maximum # if($wh != 0) { # Permute rows to place maximum element on diagonal. my $whc = $wh+$col; # my $sl1 = $out->(:,($whc)); my $sl1 = $out->mv(1,0)->index($whc(*$n)); my $sl2 = $out->(:,($col)); $tmprow .= $sl1; $sl1 .= $sl2; $sl2 .= $tmprow; $sl1 = $permute->index($whc); $sl2 = $permute->index($col); $tmpval .= $sl1; $sl1 .= $sl2; $sl2 .= $tmpval; { my $tmp; ($tmp = $parity->where($wh>0)) *= -1.0; } } # Sidestep near-singularity (NR does this; not sure if it is helpful) my $notbig = $big->where(abs($big) < $TINY); $notbig .= $TINY * (1.0 - 2.0*($notbig < 0)); # Divide by the diagonal element (which is now the largest element) my $tout; ($tout = $out->(($col),$col+1:$n1)) /= $big->(*1); } # end of pivoting part } # end of column loop if(wantarray) { return ($out,$permute,$parity); } $out; } EOD ###################################################################### pp_add_exported('','lu_decomp2'); pp_addpm(<<'EOD'); =head2 lu_decomp2 =for sig Signature: (a(m,m); [o]lu(m,m)) =for ref LU decompose a matrix, with no row permutation =for usage ($lu, $perm, $parity) = lu_decomp2($a); $lu = lu_decomp2($a,$perm,$parity); # or $lu = lu_decomp2($a); # $perm and $parity are optional lu_decomp($a->inplace,$perm,$parity); # or lu_decomp($a->inplace); # $perm and $parity are optional =for description C works just like L, but it does B pivoting at all. For compatibility with L, it will give you a permutation list and a parity scalar if you ask for them -- but they are always trivial. Because C does not pivot, it is numerically B -- that means it is less precise than L, particularly for large or near-singular matrices. There are also specific types of non-singular matrices that confuse it (e.g. ([0,-1,0],[1,0,0],[0,0,1]), which is a 90 degree rotation matrix but which confuses C). On the other hand, if you want to invert rapidly a few hundred thousand small matrices and don't mind missing one or two, it could be the ticket. It can be up to 60% faster at the expense of possible failure of the decomposition for some of the input matrices. The output is a single matrix that contains the LU decomposition of C<$a>; you can even do it in-place, thereby destroying C<$a>, if you want. See L for more information about LU decomposition. C is ported from I into PDL. =cut *PDL::lu_decomp2 = \&lu_decomp2; sub lu_decomp2 { my($in) = shift; my($perm) = shift; my($par) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp2 requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $perm) { barf('lu_decomp2: permutation vector must match the matrix') if(!UNIVERSAL::isa($perm,'PDL') || $perm->ndims != 1 || $perm->dim(0) != $out->dim(0)); $perm .= PDL->xvals($in->dim(0)); } else { $perm = PDL->xvals($in->dim(0)); } if(defined $par) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($par,'PDL') || $par->nelem != 1); $par .= 1.0; } else { $par = pdl(1.0); } my $diagonal = $out->diagonal(0,1); my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->(($col),0:$klim) * $out->(0:$klim,($row)) )->sumover; } } # Figure a_ij, with no pivoting if($col < $n1) { # Divide the rest of the column by the diagonal element my $tmp; # work around for perl -d "feature" ($tmp = $out->(($col),$col+1:$n1)) /= $diagonal->index($col)->dummy(0,$n1-$col); } } # end of column loop if(wantarray) { return ($out,$perm,$par); } $out; } EOD ###################################################################### pp_add_exported('','lu_backsub'); pp_addpm(<<'EOD'); =head2 lu_backsub =for sig Signature: (lu(m,m); perm(m); b(m)) =for ref Solve a x = b for matrix a, by back substitution into a's LU decomposition. =for usage ($lu,$perm,$par) = lu_decomp($a); $x = lu_backsub($lu,$perm,$par,$b); # or $x = lu_backsub($lu,$perm,$b); # $par is not required for lu_backsub lu_backsub($lu,$perm,$b->inplace); # modify $b in-place $x = lu_backsub(lu_decomp($a),$b); # (ignores parity value from lu_decomp) =for description Given the LU decomposition of a square matrix (from L), C does back substitution into the matrix to solve C for given vector C. It is separated from the C method so that you can call the cheap C multiple times and not have to do the expensive LU decomposition more than once. C acts on single vectors and threads in the usual way, which means that it treats C<$b> as the I of the input. If you want to process a matrix, you must hand in the I of the matrix, and then transpose the output when you get it back. that is because pdls are indexed by (col,row), and matrices are (row,column) by convention, so a 1-D pdl corresponds to a row vector, not a column vector. If C<$lu> is dense and you have more than a few points to solve for, it is probably cheaper to find C with L, and just multiply C.) in fact, L works by calling C with the identity matrix. C is ported from section 2.3 of I. It is written in PDL but should probably be implemented in C. =cut *PDL::lu_backsub = \&lu_backsub; sub lu_backsub { my ($lu, $perm, $b, $par); print STDERR "lu_backsub: entering debug version...\n" if $PDL::debug; if(@_==3) { ($lu, $perm, $b) = @_; } elsif(@_==4) { ($lu, $perm, $par, $b) = @_; } barf("lu_backsub: LU decomposition is undef -- probably from a singular matrix.\n") unless defined($lu); barf("Usage: \$x = lu_backsub(\$lu,\$perm,\$b); all must be PDLs\n") unless(UNIVERSAL::isa($lu,'PDL') && UNIVERSAL::isa($perm,'PDL') && UNIVERSAL::isa($b,'PDL')); my $n = $b->dim(0); my $n1 = $n; $n1--; # Make sure threading dimensions are compatible. # There are two possible sources of thread dims: # # (1) over multiple LU (i.e., $lu,$perm) instances # (2) over multiple B (i.e., $b) column instances # # The full dimensions of the function call looks like # # lu_backsub( lu(m,m,X), perm(m,X), b(m,Y) ) # # where X is the list of extra LU dims and Y is # the list of extra B dims. We have several possible # cases: # # (1) Check that m dims are compatible my $ludims = pdl($lu->dims); my $permdims = pdl($perm->dims); my $bdims = pdl($b->dims); print STDERR "lu_backsub: called with args: \$lu$ludims, \$perm$permdims, \$b$bdims\n" if $PDL::debug; my $m = $ludims((0)); # this is the sig dimension unless ( ($ludims(0) == $m) and ($ludims(1) == $m) and ($permdims(0) == $m) and ($bdims(0) == $m)) { barf "lu_backsub: mismatched sig dimensions"; } my $lunumthr = $ludims->dim(0)-2; my $permnumthr = $permdims->dim(0)-1; my $bnumthr = $bdims->dim(0)-1; unless ( ($lunumthr == $permnumthr) and ($ludims(1:-1) == $permdims)->all ) { barf "lu_backsub: \$lu and \$perm thread dims not equal! \n"; } # (2) If X == Y then default threading is ok if ( ($bnumthr==$permnumthr) and ($bdims==$permdims)->all) { print STDERR "lu_backsub: have explicit thread dims, goto THREAD_OK\n" if $PDL::debug; goto THREAD_OK; } # (3) If X == (x,Y) then add x dummy to lu,perm # (4) If ndims(X) > ndims(Y) then must have #3 # (5) If ndims(X) < ndims(Y) then foreach # non-trivial leading dim in X (x0,x1,..) # insert dummy (x0,x1) into lu and perm # This means that threading occurs over all # leading non-trivial (not length 1) dims of # B unless all the thread dims are explicitly # matched to the LU dims. THREAD_OK: # Permute the vector and make a copy if necessary. my $out; # my $nontrivial = ! (($perm==(PDL->xvals($perm->dims)))->all); my $nontrivial = ! (($perm==$perm->xvals)->clump(-1)->andover); if($nontrivial) { if($b->is_inplace) { $b .= $b->dummy(1,$b->dim(0))->index($perm->dummy(1,1))->sever; # TODO: check threading $out = $b; } else { $out = $b->dummy(1,$b->dim(0))->index($perm->dummy(1,1))->sever; # TODO: check threading } } else { # should check for more matrix dims to thread over # but ignore the issue for now $out = ($b->is_inplace ? $b : $b->copy); } print STDERR "lu_backsub: starting with \$out" . pdl($out->dims) . "\n" if $PDL::debug; # Make sure threading over lu happens OK... if($out->ndims < $lu->ndims-1) { print STDERR "lu_backsub: adjusting dims for \$out" . pdl($out->dims) . "\n" if $PDL::debug; do { $out = $out->dummy(-1,$lu->dim($out->ndims+1)); } while($out->ndims < $lu->ndims-1); $out = $out->sever; } ## Do forward substitution into L my $row; my $r1; for $row(1..$n1) { $r1 = $row-1; my $tmp; # work around perl -d "feature ($tmp = $out->index($row)) -= ($lu->(0:$r1,$row) * $out->(0:$r1) )->sumover; } ## Do backward substitution into U, and normalize by the diagonal my $ludiag = $lu->diagonal(0,1); { my $tmp; # work around for perl -d "feature" ($tmp = $out->index($n1)) /= $ludiag->index($n1)->dummy(0,1); # TODO: check threading } for ($row=$n1; $row>0; $row--) { $r1 = $row-1; my $tmp; # work around for perl -d "feature" ($tmp = $out->index($r1)) -= ($lu->($row:$n1,$r1) * # TODO: check thread dims $out->($row:$n1) )->sumover; ($tmp = $out->index($r1)) /= $ludiag->index($r1)->dummy(0,1); # TODO: check thread dims } $out; } EOD ###################################################################### ### simq ### # XXX Destroys a!!! # To use the new a again, must store both a and ips. pp_def("simq", HandleBad => 0, Pars => '[phys]a(n,n); [phys]b(n); [o,phys]x(n); int [o,phys]ips(n)', OtherPars => 'int flag;', GenericTypes => ['D'], Code => ' extern int simq( double *A, double *B, double *X, int n, int flag, int *IPS ); simq($P (a),$P (b),$P (x),$SIZE (n),$COMP (flag),$P (ips)); ', Doc => ' =for ref Solution of simultaneous linear equations, C. C<$a> is an C matrix (i.e., a vector of length C), stored row-wise: that is, C, where C. While this is the transpose of the normal column-wise storage, this corresponds to normal PDL usage. The contents of matrix a may be altered (but may be required for subsequent calls with flag = -1). C<$b>, C<$x>, C<$ips> are vectors of length C. Set C to solve. Set C to do a new back substitution for different C<$b> vector using the same a matrix previously reduced when C (the C<$ips> vector generated in the previous solution is also required). See also L, which does the same thing with a slightly less opaque interface. =cut '); ###################################################################### ### squaretotri ### # this doesn't need to be changed to support bad values # I could put 'HandleBad => 1', but it would just cause an # unnecessary increase (admittedly small) in the amount of # code # pp_def("squaretotri", Pars => 'a(n,n); b(m)', Code => ' register int mna=0, nb=0, ns = $SIZE (n); #if (PERL_VERSION >= 5) && (PERL_SUBVERSION >= 57) dXSARGS; #endif if($SIZE (m) != (ns * (ns+1))/2) { barf("Wrong sized args for squaretotri"); } threadloop %{ loop(m) %{ $b () = $a (n0 => mna, n1 => nb); mna++; if(mna > nb) {mna = 0; nb ++;} %} %} ', Doc => ' =for ref Convert a symmetric square matrix to triangular vector storage. =cut ', ); pp_addpm({At=>'Bot'},<<'EOD'); sub eigen_c { print STDERR "eigen_c is no longer part of PDL::MatrixOps or PDL::Math; use eigens instead.\n"; ## my($mat) = @_; ## my $s = $mat->getdim(0); ## my $z = zeroes($s * ($s+1) / 2); ## my $ev = zeroes($s); ## squaretotri($mat,$z); ## my $k = 0 * $mat; ## PDL::eigens($z, $k, $ev); ## return ($ev, $k); } =head1 AUTHOR Copyright (C) 2002 Craig DeForest (deforest@boulder.swri.edu), R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au). There is no warranty. You are allowed to redistribute and/or modify this work under the same conditions as PDL itself. If this file is separated from the PDL distribution, then the PDL copyright notice should be included in this file. =cut EOD pp_done(); PDL-2.018/Basic/MatrixOps/NOTES0000644060175006010010000000147712562522363014175 0ustar chmNone20-Jun-2006 Moved the "Small Science Libraty" code from ssl/ into this directory to avoid having to deal with OS/system-specific make files. Changed nan("") to atof("NaN") on Solaris machines (done in a quick way; should be handled in Basic/Core/ or top-level Makefile.PL). --Doug Burke 7-Jan-2004 Added a subset of the "Small Science Library" available from geisshirt.dk, to handle eigens work. The former 'eigens.c' is now relegated to 'eigens_sym'. 19-Nov-2002 This is intended to be a useful repository of self-contained linear algebra routines. Some of the stuff has been stolen from ../Math, which in turn used the Cephes maths library sources. Some of it was ported to PDL from the algorithms in _Numerical_Recipes_, but the original C code should probably be used if the copyrights allow it. --Craig DeForest PDL-2.018/Basic/MatrixOps/protos.h0000644060175006010010000000264012562522363015052 0ustar chmNone/* * This file was automatically generated by version 1.7 of cextract. * Manual editing not recommended. * * Created: Fri Nov 28 17:00:03 1997 */ #ifndef __CEXTRACT__ #if __STDC__ extern double asinh ( double xx ); extern double j0 ( double x ); extern double y0 ( double x ); extern double jn ( int n, double x ); extern double ndtr ( double a ); extern double erfc ( double a ); extern double erf ( double x ); extern double acosh ( double x ); extern double atanh ( double x ); extern double j1 ( double x ); extern double y1 ( double x ); extern int mtherr ( char *name, int code ); extern double polevl ( double x, double coef[], int N ); extern double p1evl ( double x, double coef[], int N ); extern double yn ( int n, double x ); #else /* __STDC__ */ extern double asinh (/* double xx */); extern double j0 (/* double x */); extern double y0 (/* double x */); extern double jn (/* int n, double x */); extern double ndtr (/* double a */); extern double erfc (/* double a */); extern double erf (/* double x */); extern double acosh (/* double x */); extern double atanh (/* double x */); extern double j1 (/* double x */); extern double y1 (/* double x */); extern int mtherr (/* char *name, int code */); extern double polevl (/* double x, double coef[], int N */); extern double p1evl (/* double x, double coef[], int N */); extern double yn (/* int n, double x */); #endif /* __STDC__ */ #endif /* __CEXTRACT__ */ PDL-2.018/Basic/MatrixOps/README.ssl0000644060175006010010000000257012562522363015035 0ustar chmNoneFiles in this directory are a subset, slightly modified, of the Small Scientific Library by Kenneth Geisshirt. They may be distributed and modified under the same terms as PDL itself. ------------------------------ From kenneth@geisshirt.dk Thu Jan 13 14:40:30 2005 Message-ID: <41E6EACE.6010600@geisshirt.dk> Date: Thu, 13 Jan 2005 22:40:30 +0100 From: Kenneth Geisshirt To: deforest@boulder.swri.edu Subject: Re: Small Scientific Library use within Perl/PDL? Craig DeForest wrote: > I notice that, while you have made SSL available for download, there is no > indication that it is free software. Are you willing to distribute SSL under > the Perl Artistic License (or some other free software license)? That's my mistake: SSLib is free software. I'll create a new tar ball this weekend (including a license). I'll probably use the MIT X License since it's the less restricted license I know. If you decide to use some of my routines in PDL I'll be very happy. And if you need any help please let me know. SSLib is a very simple library - not that the routines are simple but the API is on a basic level and the application programmer must be very aware of how to call routines and use the data structure. /kneth -- Kenneth Geisshirt, M.Sc., Ph.D. -- http://kenneth.geisshirt.dk/ GPG Fingerprint: CEC4 7449 1B9B C8A5 7679 F062 DDDF 020E F812 4EE3 PDL-2.018/Basic/MatrixOps/simq.c0000644060175006010010000000557213036512174014473 0ustar chmNone/* simq.c * * Solution of simultaneous linear equations AX = B * by Gaussian elimination with partial pivoting * * * * SYNOPSIS: * * double A[n*n], B[n], X[n]; * int n, flag; * int IPS[]; * int simq(); * * ercode = simq( A, B, X, n, flag, IPS ); * * * * DESCRIPTION: * * B, X, IPS are vectors of length n. * A is an n x n matrix (i.e., a vector of length n*n), * stored row-wise: that is, A(i,j) = A[ij], * where ij = i*n + j, which is the transpose of the normal * column-wise storage. * * The contents of matrix A are destroyed. * * Set flag=0 to solve. * Set flag=-1 to do a new back substitution for different B vector * using the same A matrix previously reduced when flag=0. * * The routine returns nonzero on error; messages are printed. * * * ACCURACY: * * Depends on the conditioning (range of eigenvalues) of matrix A. * * * REFERENCE: * * Computer Solution of Linear Algebraic Systems, * by George E. Forsythe and Cleve B. Moler; Prentice-Hall, 1967. * */ /* simq 2 */ #include int simq( A, B, X, n, flag, IPS ) double A[], B[], X[]; int n, flag; int IPS[]; { int i, j, ij, ip, ipj, ipk, ipn; int idxpiv, iback; int k, kp, kp1, kpj, kpk, kpn; int nip, nkp, nm1; double em, q, rownrm, big, size, pivot, sum; double fabs(); if( flag < 0 ) goto solve; /* Initialize IPS and X */ ij=0; for( i=0; i big ) { big = size; idxpiv = i; } } if( big == 0.0 ) { puts( "SIMQ BIG=0" ); return(2); } if( idxpiv != k ) { j = IPS[k]; IPS[k] = IPS[idxpiv]; IPS[idxpiv] = j; } kp = IPS[k]; kpk = n*kp + k; pivot = A[kpk]; kp1 = k+1; for( i=kp1; i /* * SSLerror is an error handling routine. * */ void SSLerror(char *msg) { fprintf(stderr, "Fatal error in SSL.\n%s\n", msg); } /* SSLerror */ /* * Sqr and Cube is two simple power-raising routines. * */ double Sqr(double x) { return x*x; } /* Sqr */ double Cube(double x) { return x*x*x; } /* Cube */ PDL-2.018/Basic/MatrixOps/sslib.h0000644060175006010010000000167712562522363014651 0ustar chmNone/* * ssl.h - Small Scientific Library. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.2 2001/07/11 08:06:01 kneth * Added SWAP macro * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * */ #ifndef SSL_H_ #define SSL_H_ #ifndef PI # define PI 3.141592653589793238462643 #endif /***** A boolean type *****/ typedef enum {false=0, true=1} bool; /***** Pratical macros *****/ #define min(x, y) ((x)>(y))?(y):(x) #define max(x, y) ((x)>(y))?(x):(y) #define SWAP(x, y) { double tmp; tmp=x; x=y; y=tmp; } /***** General functions *****/ extern void SSLerror(char *); extern double Sqr(double); extern double Cube(double); #endif /* SSL_H_ */ PDL-2.018/Basic/MatrixOps/svd.c0000644060175006010010000001750613036512174014316 0ustar chmNone/* From bryant@sioux.stanford.edu Sat Apr 3 14:57:54 1993 Return-Path: Received: from sioux.stanford.edu by alnitak.usc.edu (4.1/SMI-4.1+ucs-3.6) id AA12724; Sat, 3 Apr 93 14:57:52 PST Received: from oglala.ice (oglala.Stanford.EDU) by sioux.stanford.edu (4.1/inc-1.0) id AA07300; Sat, 3 Apr 93 14:53:25 PST Date: Sat, 3 Apr 93 14:53:25 PST From: bryant@sioux.stanford.edu (Bryant Marks) Message-Id: <9304032253.AA07300@sioux.stanford.edu> To: ajayshah@rcf.usc.edu Subject: Re: SVD Status: ORr > Hi! Long ago you sent me an svd routine in C based on code > from Nash in Pascal. Has this changed any over the years? (Your > email is dated July 1992). Is your code available by anon ftp? Hi Ajay, I don't think I have changed the code -- but here's my most recent version of the code, you can check to see if it's any different. Currently it's not available via anonymous ftp but feel free to redistribute the code -- it seems to work well in the application I'm using it in. Bryant */ /* This SVD routine is based on pgs 30-48 of "Compact Numerical Methods for Computers" by J.C. Nash (1990), used to compute the pseudoinverse. Modifications include: Translation from Pascal to ANSI C. Array indexing from 0 rather than 1. Float replaced by double everywhere. Support for the Matrix structure. I changed the array indexing so that the matricies (float [][]) could be replaced be a single list (double *) for more efficient communication with Mathematica. */ /* rjrw 7/7/99: changed z back to a vector, moved one line... */ /* Derek A. Lamb 2016: added comments to aid understanding, since Nash's book will only get more difficult to find in the future. */ /* Form a singular value decomposition of matrix A which is stored in the first nRow*nCol elements of working array W. Upon return, the first nRow*nCol elements of W will become the product U x S of a thin svd, where S is the diagonal (rectangular) matrix of singular values. The last nCol*nCol elements of W will be the square matrix V of a thin svd. On return, Z will contain the squares of the singular values. The input matrix A is assumed to have nRows >= nCol. If it does not, one should input the transpose of A, A", to find the the svd of A, since A = U x S x V" and A" = V x S x U". (The " means transpose.) */ #include #define TOLERANCE 1.0e-22 #ifdef MAIN #include #define NC 2 #define NR 2 int main() { int i,j,n,m; double w[NC*(NR+NC)], z[NC*NC]; void SVD(double *W, double *Z, int nRow, int nCol); for (i=0;i=0) { cos(phi) = sqrt((v+q)/(2*v)); sin(phi) = p/(v*cos(phi)); } else if (q<0) {, (sgn(p)=+1 for p>=0, -1 for p<0); sin(phi) = sgn(p)*sqrt((v-q)/(2*v)); cos(phi) = p/(v*sin(phi)); } This formulation avoids the subtraction of two nearly equal numbers, which is bound to happen to q and v as the matrix approaches orthogonality. */ for (i=0; i= r) /* check if columns are ordered */ { /* columns are ordered, so try convergence test */ if (q<=e2*Z[0] || fabs(p)<=tol*q) RotCount--; /* There is no more work on this particular pair of columns in the current sweep. The first condition checks for very small column norms in BOTH columns, for which no rotation makes sense. The second condition determines if the inner product is small with respect to the larger of the columns, which implies a very small rotation angle. */ else {/* columns are in order, but their inner product is not small */ p /= q; r = 1 - r/q; vt = sqrt(4*p*p+r*r); /* DAL thinks the fabs is unnecessary in the next line: vt is non-negative; q>=r, r/q <=1 so after the assignment 0<= r <=1, so r/vt is positive, so everything inside the sqrt should be positive even without the fabs. abs isn't in Nash's book. c0 and s0 are cos(phi) and sin(phi) as above for q>=0*/ c0 = sqrt(fabs(.5*(1+r/vt))); s0 = p/(vt*c0); /* this little for loop (and the one below) is just rotation, inlined here for efficiency */ for (i=0; iq, and cannot be zero since both are sums of squares for the svd. In the case of a real symmetric matrix, this assumption must be questioned. */ p /= r; q = q/r-1; vt = sqrt(4*p*p+q*q); s0 = sqrt(fabs(.5*(1-q/vt))); /* DAL wondering about the fabs again, since after assignment q is <0 and vt is again positive, so everything inside the fabs should be positive already */ if (p<0) s0 = -s0; /*s0 and c0 are sin(phi) and cos(phi) as above for q<0 */ c0 = p/(vt*s0); for (i=0; i=3 && Z[(EstColRank-1)]<=Z[0]*tol+tol*tol) EstColRank--; } #if DEBUG if (SweepCount > slimit) fprintf(stderr, "Sweeps = %d\n", SweepCount); #endif } PDL-2.018/Basic/Ops/0000755060175006010010000000000013110402046012145 5ustar chmNonePDL-2.018/Basic/Ops/Makefile.PL0000644060175006010010000000043012562522363014133 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["ops.pd",qw(Ops PDL::Ops)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS}->[0] .= ' -lm '; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Basic/Ops/ops.pd0000644060175006010010000003356213036512174013317 0ustar chmNonepp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::Ops - Fundamental mathematical operators =head1 DESCRIPTION This module provides the functions used by PDL to overload the basic mathematical operators (C<+ - / *> etc.) and functions (C etc.) It also includes the function C, which should be a perl function so that we can overload it! Matrix multiplication (the operator C) is handled by the module L. =head1 SYNOPSIS none =cut EOD pp_addpm({At=>'Bot'},<<'EOPM'); =head1 AUTHOR Tuomas J. Lukka (lukka@fas.harvard.edu), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Doug Hunt (dhunt@ucar.edu), Christian Soeller (c.soeller@auckland.ac.nz), Doug Burke (burke@ifa.hawaii.edu), and Craig DeForest (deforest@boulder.swri.edu). =cut EOPM pp_addhdr(' #include /* MOD requires hackage to map properly into the positive-definite numbers. */ /* Note that this code causes some warning messages in the compile, because */ /* the unsigned data types always fail the ((foo)<0) tests. I believe that */ /* gcc optimizes those tests away for those data types. --CED 7-Aug-2002 */ /* Resurrect the old MOD operator as the unsigned BU_MOD to get around this. --DAL 27-Jun-2008 */ /* Q_MOD is the same as MOD except the internal casts are to longlong. -DAL 18-Feb-2015 */ /* Also changed the typecast in MOD to (long), and added a N==0 conditional to BU_MOD. -DAL 06-Mar-2015 */ #define MOD(X,N) ( ((N) == 0) ? 0 : ( (X) - (ABS(N)) * ((long )((X)/(ABS(N))) + ( ( ((N) * ((long )((X)/(N)))) != (X) ) ? ( ( ((N)<0) ? 1 : 0 ) + ( (((X)<0) ? -1 : 0))) : 0 )))) /* We assume that "long long" is ok for all Microsoft Compiler versions >= 1400. */ #if defined(_MSC_VER) && _MSC_VER < 1400 #define Q_MOD(X,N) (((N) == 0) ? 0 : ( (X) - (ABS(N)) * ((__int64 )((X)/(ABS(N))) + ( ( ((N) * ((__int64 )((X)/(N)))) != (X) ) ? ( ( ((N)<0) ? 1 : 0 ) + ( (((X)<0) ? -1 : 0))) : 0 )))) #else #define Q_MOD(X,N) (((N) == 0) ? 0 : ( (X) - (ABS(N)) * ((long long)((X)/(ABS(N))) + ( ( ((N) * ((long long)((X)/(N)))) != (X) ) ? ( ( ((N)<0) ? 1 : 0 ) + ( (((X)<0) ? -1 : 0))) : 0 )))) #endif #define BU_MOD(X,N)(((N) == 0) ? 0 : ( (X)-(N)*((int)((X)/(N))) )) #define SPACE(A,B) ( ((A)<(B)) ? -1 : ((A)!=(B)) ) #define ABS(A) ( (A)>=0 ? (A) : -(A) ) #define NOTHING '); sub protect_chars { my ($txt) = @_; $txt =~ s/>/E;gt#/g; $txt =~ s//g; return $txt; } # simple binary operators sub biop { my ($name,$op,$swap,$doc,%extra) = @_; my $optxt = protect_chars ref $op eq 'ARRAY' ? $op->[1] : $op; $op = $op->[0] if ref $op eq 'ARRAY'; if ($swap) { $extra{HdrCode} = << 'EOH'; pdl *tmp; if (swap) { tmp = a; a = b; b = tmp; } EOH } # handle exceptions my $badcode = ' ( $PDLSTATEISBAD(a) && $ISBAD(a()) ) || ( $PDLSTATEISBAD(b) && $ISBAD(b()) )'; if ( exists $extra{Exception} ) { # NOTE This option is unused ($badcode is not set). # See also `ufunc()`. delete $extra{Exception}; } if( exists $extra{Comparison} && $PDL::Config{WITH_BADVAL} ) { # *append* to header $extra{HdrCode} .= <<'EOH'; { double bad_a, bad_b; ANYVAL_TO_CTYPE(bad_a, double, PDL->get_pdl_badvalue(a)); ANYVAL_TO_CTYPE(bad_b, double, PDL->get_pdl_badvalue(b)); if( bad_a == 0 || bad_a == 1 || bad_b == 0 || bad_b == 1 ) { warn("Badvalue is set to 0 or 1. This will cause data loss when using badvalues for comparison operators."); } } EOH } pp_def($name, Pars => 'a(); b(); [o]c();', OtherPars => 'int swap', HandleBad => 1, NoBadifNaN => 1, Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its job Code => "\$c() = \$a() $op \$b();", BadCode => qq{ if ( $badcode ) \$SETBAD(c()); else \$c() = \$a() $op \$b(); }, CopyBadStatusCode => 'if ( $BADFLAGCACHE() ) { if ( a == c && $ISPDLSTATEGOOD(a) ) { PDL->propagate_badflag( c, 1 ); /* have inplace op AND badflag has changed */ } $SETPDLSTATEBAD(c); }', %extra, Doc => << "EOD"); =for ref $doc =for example \$c = $name \$a, \$b, 0; # explicit call with trailing 0 \$c = \$a $op \$b; # overloaded call \$a->inplace->$name(\$b,0); # modify \$a inplace It can be made to work inplace with the C<\$a-Einplace> syntax. This function is used to overload the binary C<$optxt> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =cut EOD } # sub: biop() #simple binary functions sub bifunc { my ($name,$func,$swap,$doc,%extra) = @_; my $funcov = ref $func eq 'ARRAY' ? $func->[1] : $func; my $isop=0; if ($funcov =~ s/^op//) { $isop = 1; } my $funcovp = protect_chars $funcov; $func = $func->[0] if ref $func eq 'ARRAY'; if ($swap) { $extra{HdrCode} .= << 'EOH'; pdl *tmp; if (swap) { tmp = a; a = b; b = tmp; } EOH } my $ovcall; # is this one to be used as a function or operator ? if ($isop) { $ovcall = "\$c = \$a $funcov \$b; # overloaded use"; } else { $ovcall = "\$c = $funcov \$a, \$b; # overloaded use"; } #a little dance to avoid the MOD macro warnings for byte & ushort datatypes my $codestr; my $badcodestr; if ($extra{unsigned}){ $codestr = << "ENDCODE"; types(BU) %{ \$c() = BU_$func(\$a(),\$b()); %} types(SLNFD) %{ \$c() = $func(\$a(),\$b()); %} types(Q) %{ \$c() = Q_$func(\$a(),\$b()); %} ENDCODE } else { $codestr = "\$c() = $func(\$a(),\$b());"; } delete $extra{unsigned}; #remove the key so it doesn't get added in pp_def. $badcodestr = 'if ( $ISBAD(a()) || $ISBAD(b()) ) $SETBAD(c()); else {' . $codestr . " } \n"; #end dance pp_def($name, HandleBad => 1, NoBadifNaN => 1, Pars => 'a(); b(); [o]c();', OtherPars => 'int swap', Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its job Code => $codestr, BadCode => $badcodestr, CopyBadStatusCode => 'if ( $BADFLAGCACHE() ) { if ( a == c && $ISPDLSTATEGOOD(a) ) { PDL->propagate_badflag( c, 1 ); /* have inplace op AND badflag has changed */ } $SETPDLSTATEBAD(c); }', %extra, Doc => << "EOD"); =for ref $doc =for example \$c = \$a->$name(\$b,0); # explicit function call $ovcall \$a->inplace->$name(\$b,0); # modify \$a inplace It can be made to work inplace with the C<\$a-Einplace> syntax. This function is used to overload the binary C<$funcovp> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =cut EOD } # sub: bifunc() # simple unary functions and operators sub ufunc { my ($name,$func,$doc,%extra) = @_; my $funcov = ref $func eq 'ARRAY' ? $func->[1] : $func; my $funcovp = protect_chars $funcov; $func = $func->[0] if ref $func eq 'ARRAY'; # handle exceptions my $badcode = '$ISBAD(a())'; if ( exists $extra{Exception} ) { # $badcode .= " || $extra{Exception}"; # print "Warning: ignored exception for $name\n"; # NOTE This option is unused ($badcode is commented out above). # See also `biop()`. delete $extra{Exception}; } # do not have to worry about propagation of the badflag when # inplace since only input piddle is a, hence its badflag # won't change # UNLESS an exception occurs... pp_def($name, Pars => 'a(); [o]b()', HandleBad => 1, NoBadifNaN => 1, Inplace => 1, Code => "\$b() = $func(\$a());", BadCode => 'if ( ' . $badcode . ' ) $SETBAD(b()); else' . "\n \$b() = $func(\$a());\n", %extra, Doc => << "EOD"); =for ref $doc =for example \$b = $funcov \$a; \$a->inplace->$name; # modify \$a inplace It can be made to work inplace with the C<\$a-Einplace> syntax. This function is used to overload the unary C<$funcovp> operator/function. =cut EOD } # sub: ufunc() ###################################################################### # we trap some illegal operations here -- see the Exception option # note, for the ufunc()'s, the checks do not work too well # for unsigned integer types (ie < 0) # # XXX needs thinking about # - have to integrate into Code section as well (so # 12/pdl(2,4,0,3) is trapped and flagged bad) # --> complicated # - perhaps could use type %{ %} ? # # ==> currently have commented out the exception code, since # want to see if can use NaN/Inf for bad values # (would solve many problems for F,D types) # # there is an issue over how we handle comparison operators # - see Primitive/primitive.pd/zcover() for more discussion # ## arithmetic ops # no swap needed but set anyway fixing sf bug #391 biop('plus','+',1,'add two piddles'); biop('mult','*',1,'multiply two piddles'); # all those need swapping biop('minus','-',1,'subtract two piddles'); biop('divide','/',1,'divide two piddles', Exception => '$b() == 0' ); ## note: divide should perhaps trap division by zero as well ## comparison ops # need swapping biop('gt','>',1,'the binary E (greater than) operation', Comparison => 1 ); biop('lt','<',1,'the binary E (less than) operation', Comparison => 1 ); biop('le','<=',1,'the binary E= (less equal) operation', Comparison => 1 ); biop('ge','>=',1,'the binary E= (greater equal) operation', Comparison => 1 ); # no swap required but set anyway fixing sf bug #391 biop('eq','==',1,'binary I operation (C<==>)', Comparison => 1 ); biop('ne','!=',1,'binary I operation (C)', Comparison => 1 ); ## bit ops # those need to be limited to the right types my $T = [B,U,S,L,N,Q]; # the sensible types here biop('shiftleft','<<',1,'leftshift C<$a> by C<$b>',GenericTypes => $T); biop('shiftright','>>',1,'rightshift C<$a> by C<$b>',GenericTypes => $T); biop('or2','|',1,'binary I of two piddles',GenericTypes => $T); biop('and2','&',1,'binary I of two piddles',GenericTypes => $T); biop('xor','^',1,'binary I of two piddles',GenericTypes => $T); # really an ufunc ufunc('bitnot','~','unary bit negation',GenericTypes => $T); # some standard binary functions bifunc('power',['pow','op**'],1,'raise piddle C<$a> to the power C<$b>',GenericTypes => [D]); bifunc('atan2','atan2',1,'elementwise C of two piddles',GenericTypes => [D]); bifunc('modulo',['MOD','op%'],1,'elementwise C operation',unsigned=>1); bifunc('spaceship',['SPACE','op<=>'],1,'elementwise "<=>" operation'); # some standard unary functions ufunc('sqrt','sqrt','elementwise square root', Exception => '$a() < 0' ); ufunc('abs',['ABS','abs'],'elementwise absolute value',GenericTypes => [D,F,S,L]); ufunc('sin','sin','the sin function'); ufunc('cos','cos','the cos function'); ufunc('not','!','the elementwise I operation'); ufunc('exp','exp','the exponential function',GenericTypes => [D]); ufunc('log','log','the natural logarithm',GenericTypes => [D], Exception => '$a() <= 0' ); pp_export_nothing(); # make log10() work on scalars (returning scalars) # as well as piddles ufunc('log10','log10','the base 10 logarithm', GenericTypes => [D], Exception => '$a() <= 0', PMCode => ' sub PDL::log10 { my $x = shift; if ( ! UNIVERSAL::isa($x,"PDL") ) { return log($x) / log(10); } my $y; if ( $x->is_inplace ) { $x->set_inplace(0); $y = $x; } elsif( ref($x) eq "PDL"){ #PDL Objects, use nullcreate: $y = PDL->nullcreate($x); }else{ #PDL-Derived Object, use copy: (Consistent with # Auto-creation docs in Objects.pod) $y = $x->copy; } &PDL::_log10_int( $x, $y ); return $y; }; ' ); # note: the extra code that adding 'HandleBad => 1' creates is # unneeded here. Things could be made clever enough to work this out, # but it's very low priority. # It does add doc information though, and lets people know it's been # looked at for bad value support # DJB adds: not completely sure about this now that I have added code # to avoid a valgrind-reported error (see the CacheBadFlagInit rule # in PP.pm) # # Can't this be handled in Core.pm when '.=' is overloaded ? # pp_def( 'assgn', # HandleBad => 1, Pars => 'a(); [o]b();', Code => '$b() = $a();', # BadCode => # 'if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = $a(); }', Doc => 'Plain numerical assignment. This is used to implement the ".=" operator', ); # pp_def assgn pp_def('ipow', Doc => qq{ =for ref raise piddle C<\$a> to integer power C<\$b> =for example \$c = \$a->ipow(\$b,0); # explicit function call \$c = ipow \$a, \$b; \$a->inplace->ipow(\$b,0); # modify \$a inplace It can be made to work inplace with the C<\$a-Einplace> syntax. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. Algorithm from L =cut }, Pars => 'a(); b(); [o] ans()', Code => pp_line_numbers(__LINE__, q{ PDL_Indx n = $b(); $GENERIC() y = 1; $GENERIC() x = $a(); if (n < 0) { x = 1 / x; n = -n; } if (n == 0) { $ans() = 1; } else { while (n > 1) { if (n % 2 == 0) { x = x * x; n = n / 2; } else { y = x * y; x = x * x; n = (n - 1) / 2; } } $ans() = x * y; } }) ); #pp_export_nothing(); pp_done(); PDL-2.018/Basic/Options.pm0000644060175006010010000005765313036512174013430 0ustar chmNone package PDL::Options; =head1 NAME PDL::Options - simplifies option passing by hash in PerlDL =head1 SYNOPSIS use PDL::Options; %hash = parse( \%defaults, \%user_options); use PDL::Options (); $opt = new PDL::Options; $opt = new PDL::Options ( \%defaults ); $opt->defaults ( \%defaults ); $opt->synonyms ( { 'COLOR' => 'COLOUR' } ); $hashref = $opt->defaults; $opt->options ( \%user_options ); $hashref = $opt->options; $opt->incremental(1); $opt->full_options(0); =head1 DESCRIPTION Object to simplify option passing for PerlDL subroutines. Allows you to merge a user defined options with defaults. A simplified (non-OO) interface is provided. =cut use strict; use Carp; use vars qw/$VERSION %EXPORT_TAGS %DEF_SYNS @ISA/; require Exporter; # difference to 0.91 is that added CENTRE/CENTER as default # synonymns (patch by Diab Jerius [ #469110 ]) our $VERSION = '0.92'; $VERSION = eval $VERSION; @ISA = qw(Exporter); %EXPORT_TAGS = ( 'Func' => [qw/ parse iparse ifhref /] ); Exporter::export_tags('Func'); # List of default synonyms %DEF_SYNS = ( COLOR => 'COLOUR', COLOUR => 'COLOR', CENTER => 'CENTRE', CENTRE => 'CENTER', ); my $default = { WarnOnMissing => 1, FullOptions => 1, DEBUG => 0, }; =head1 Utility functions =head2 ifhref parse({Ext => 'TIF', ifhref($opt)}); just return the argument if it is a hashref otherwise return an empty hashref. Useful in conjunction with parse to return just the default values if argument is not a hash ref =head1 NON-OO INTERFACE A simplified non-object oriented interface is provided. These routines are exported into the callers namespace by default. =over 4 =item parse( \%defaults, \%user_options) This will parse user options by using the defaults. The following settings are used for parsing: The options are case-sensitive, a default synonym table is consulted (see L), minimum-matching is turned on, and translation of values is not performed. A hash (not hash reference) containing the processed options is returned. %options = parse( { LINE => 1, COLOUR => 'red'}, { COLOR => 'blue'}); =item iparse( \%defaults, \%user_options) Same as C but matching is case insensitive =cut sub ifhref { my ($href) = @_; return defined $href && ref $href eq 'HASH' ? $href : {}; } sub parse { return _parse(1,@_) } sub iparse { return _parse(0,@_) } sub _parse { croak 'Usage: parse( \%defaults, \%user )' if scalar(@_) != 3; my $casechk = shift; my $defaults = shift; croak ("First argument is not a hash reference") unless ref($defaults) eq "HASH"; my $user = shift; croak ("Second argument is not a hash reference") unless ref($user) eq "HASH"; # Create new object my $opt = new PDL::Options ( $defaults ); # Set up default behaviour $opt->minmatch(1); $opt->casesens($casechk); $opt->synonyms( \%DEF_SYNS ); # Process the options my $optref = $opt->options( $user ); return %$optref; } =back =head2 Default Synonyms The following default synonyms are available in the non-OO interface: COLOR => COLOUR COLOUR => COLOR CENTER => CENTRE CENTRE => CENTER =head1 METHODS The following methods are available to PDL::Options objects. =over 4 =item new() Constructor. Creates the object. With an optional argument can also set the default options. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $opt = {}; # Set up object structure $opt->{DEFAULTS} = {}; # Default options $opt->{CURRENT} = {}; # Current options $opt->{CurrKeys} = []; # list of selected keys if full_options(0) $opt->{SYNONYMS} = {}; # List of synonyms $opt->{INC} = 0; # Flag to decide whether we are incremental on cur $opt->{CaseSens} = 0; # Are options case sensitive $opt->{MinMatch} = 1; # Minimum matching on keys $opt->{Translation} = {};# Translation from eg 'RED' to 1 $opt->{AutoTranslate}= 1;# Automatically translate options when processing $opt->{MinMatchTrans} = 0; # Min matching during translation $opt->{CaseSensTrans} = 0; # Case sensitive during translation # Return full options list $opt->{FullOptions} = $default->{FullOptions}; # Whether to warn for options that are invalid or not $opt->{WarnOnMissing}= $default->{WarnOnMissing}; $opt->{DEBUG} = $default->{DEBUG}; # Turn on debug messages # Bless into class bless ( $opt, $class); # If we were passed arguments, pass to defaults method if (@_) { $opt->defaults( @_ ); } return $opt; } =item extend (\%options) This will copy the existing options object and extend it with the requested extra options. =cut sub extend { my ($self, $opt)=@_; my $class = ref($self); my $h = {%{$self}}; croak ("Argument is not reference to hash!\n") unless ref($opt) eq 'HASH'; # # The next step is to perform a deep copy of the hash # references since we might want to change these without # changing the originals. # $h->{SYNONYMS}={%{$self->{SYNONYMS}}}; $h->{Translation}={%{$self->{Translation}}}; $h->{CurrKeys}=[@{$self->{CurrKeys}}]; # # Create the extended option list. # my %all_options = (%{$opt}, %{$self->{DEFAULTS}}); # Bless it bless ($h, $class); # And parse the default options $h->defaults(\%all_options); return $h; } # =item change_defaults (\%options) # This will merge the options given with the defaults hash and hence change # the default hash. This is not normally a good idea, but in certain dynamic # situations you might want to adjust a default parameter for future calls # to the routine. # =cut # sub change_defaults { # my $self=shift; # my $arg = shift; # croak("Argument is not a hash reference!\n") unless ref($arg) eq 'HASH'; # my $defs = $self->defaults($arg); # $self->defaults($) # } =item defaults( \%defaults ) Method to set or return the current defaults. The argument should be a reference to a hash. The hash reference is returned if no arguments are supplied. The current values are reset whenever the defaults are changed. =cut sub defaults { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{DEFAULTS} = $arg; # Reset the current state (making sure that I disconnect the # hashes my %hash = %$arg; $self->curr_full(\%hash); } # Decouple the hash to protect it from being modified outside the # object my %hash = %{$self->{DEFAULTS}}; return \%hash; } =item add_synonym (\%synonyms) Method to add another synonym to an option set The argument should be a reference to a hash. =cut sub add_synonym { my $self=shift; return unless @_; my $arg = shift; croak("Synonym argument is not a hash reference") unless ref($arg) eq "HASH"; foreach (keys %$arg) { $self->{SYNONYMS}{$_}=$arg->{$_}; } my %hash = %{$self->{SYNONYMS}}; return \%hash; } =item add_translation (\%translation) Method to add another translation rule to an option set. The argument should be a reference to a hash. =cut sub add_translation { my $self = shift; return unless @_; my $arg = shift; croak("Translation argument is not a hash reference") unless ref($arg) eq 'HASH'; foreach (keys %$arg) { $self->{Translation}{$_}=$arg->{$_}; } my %hash = %{$self->{Translation}}; return \%hash; } =item synonyms( \%synonyms ) Method to set or return the current synonyms. The argument should be a reference to a hash. The hash reference is returned if no arguments are supplied. This allows you to provide alternate keywords (such as allowing 'COLOR' as an option when your defaults uses 'COLOUR'). =cut sub synonyms { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{SYNONYMS} = $arg; } # Decouple the hash to protect it from being modified outside the # object my %hash = %{$self->{SYNONYMS}}; return \%hash; } =item current Returns the current state of the options. This is returned as a hash reference (although it is not a reference to the actual hash stored in the object). If full_options() is true the full options hash is returned, if full_options() is false only the modified options are returned (as set by the last call to options()). =cut sub current { my $self = shift; if ($self->full_options) { return $self->curr_full; } else { my @keys = $self->curr_keys; my %hash = (); my $curr = $self->curr_full; foreach my $key (@keys) { $hash{$key} = $$curr{$key} if exists $$curr{$key}; } return \%hash; } } =item clear_current This routine clears the 'state' of the C object so that the next call to current will return an empty list =cut sub clear_current { my $self = shift; @{$self->{CurrKeys}}=(); } # Method to set the 'mini' state of the object # This is just a list of the keys in %defaults that were selected # by the user. current() returns the hash with these keys if # called with full_options(0). # Not publicising this sub curr_keys { my $self = shift; if (@_) { @{$self->{CurrKeys}} = @_; } return @{$self->{CurrKeys}}; } # Method to set the full state of the object # Not publicising this sub curr_full { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{CURRENT} = $arg; } # Decouple the hash my %hash = %{$self->{CURRENT}}; return \%hash; } =item translation Provide translation of options to more specific values that are recognised by the program. This allows, for example, the automatic translation of the string 'red' to '#ff0000'. This method can be used to setup the dictionary and is hash reference with the following structure: OPTIONA => { 'string1' => decode1, 'string2' => decode2 }, OPTIONB => { 's4' => decodeb1, } etc.... Where OPTION? corresponds to the top level option name as stored in the defaults array (eg LINECOLOR) and the anonymous hashes provide the translation from string1 ('red') to decode1 ('#ff0000'). An options string will be translated automatically during the main options() processing if autotrans() is set to true. Else translation can be initiated by the user using the translate() method. =cut sub translation { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{Translation} = $arg; } # Decouple the hash to protect it from being modified outside the # object my %hash = %{$self->{Translation}}; return \%hash; } =item incremental Specifies whether the user defined options will be treated as additions to the current state of the object (1) or modifications to the default values only (0). Can be used to set or return this value. Default is false. =cut sub incremental { my $self = shift; if (@_) { $self->{INC} = shift; } return $self->{INC}; } =item full_options Governs whether a complete set of options is returned (ie defaults + expanded user options), true, or if just the expanded user options are returned, false (ie the values specified by the user). This can be useful when you are only interested in the changes to the options rather than knowing the full state. (For example, if defaults contains keys for COLOUR and LINESTYLE and the user supplied a key of COL, you may simply be interested in the modification to COLOUR rather than the state of LINESTYLE and COLOUR.) Default is true. =cut sub full_options { my $self = shift; if (@_) { $self->{FullOptions} = shift; } return $self->{FullOptions}; } =item casesens Specifies whether the user defined options will be processed independent of case (0) or not (1). Default is to be case insensitive. Can be used to set or return this value. =cut sub casesens { my $self = shift; if (@_) { $self->{CaseSens} = shift; } return $self->{CaseSens}; } =item minmatch Specifies whether the user defined options will be minimum matched with the defaults (1) or whether the user defined options should match the default keys exactly. Defaults is true (1). If a particular key matches exactly (within the constraints imposed bby case sensitivity) this key will always be taken as correct even if others are similar. For example COL would match COL and COLOUR but this implementation will always return COL in this case (note that for CO it will return both COL and COLOUR and pick one at random. Can be used to set or return this value. =cut sub minmatch { my $self = shift; if (@_) { $self->{MinMatch} = shift; } return $self->{MinMatch}; } =item autotrans Specifies whether the user defined options will be processed via the translate() method immediately following the main options parsing. Default is to autotranslate (1). Can be used to set or return this value. =cut sub autotrans { my $self = shift; if (@_) { $self->{AutoTranslate} = shift; } return $self->{AutoTranslate}; } =item casesenstrans Specifies whether the keys in the options hash will be matched insensitive of case (0) during translation() or not (1). Default is to be case insensitive. Can be used to set or return this value. =cut sub casesenstrans { my $self = shift; if (@_) { $self->{CaseSensTrans} = shift; } return $self->{CaseSensTrans}; } =item minmatchtrans Specifies whether the keys in the options hash will be minimum matched during translation(). Default is false (0). If a particular key matches exactly (within the constraints imposed bby case sensitivity) this key will always be taken as correct even if others are similar. For example COL would match COL and COLOUR but this implementation will always return COL in this case (note that for CO it will return both COL and COLOUR and pick one at random. Can be used to set or return this value. =cut sub minmatchtrans { my $self = shift; if (@_) { $self->{MinMatchTrans} = shift; } return $self->{MinMatchTrans}; } =item warnonmissing Turn on or off the warning message printed when an options is not in the options hash. This can be convenient when a user passes a set of options that has to be parsed by several different option objects down the line. =cut sub warnonmissing { my $self = shift; if (ref $self) { if (@_) { $self->{WarnOnMissing}=shift;} return $self->{WarnOnMissing}; } else { $default->{WarnOnMissing} = shift if @_; return $default->{WarnOnMissing}; } } =item debug Turn on or off debug messages. Default is off (0). Can be used to set or return this value. =cut sub debug { my $self = shift; if (ref $self) { if (@_) { $self->{DEBUG} = shift; } return $self->{DEBUG}; } else { $default->{DEBUG} = shift if @_; return $default->{DEBUG}; } } =item options Takes a set of user-defined options (as a reference to a hash) and merges them with the current state (or the defaults; depends on the state of incremental()). The user-supplied keys will be compared with the defaults. Case sensitivity and minimum matching can be configured using the mimatch() and casesens() methods. A warning is raised if keys present in the user options are not present in the defaults unless warnonmissing is set. A reference to a hash containing the merged options is returned. $merged = $opt->options( { COL => 'red', Width => 1}); The state of the object can be retrieved after this by using the current() method or by using the options() method with no arguments. If full_options() is true, all options are returned (options plus overrides), if full_options() is false then only the modified options are returned. Synonyms are supported if they have been configured via the synonyms() method. =cut sub options { my $self = shift; # If there is an argument do something clever if (@_) { # check that the arg is a hash my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; # Turn the options into a real hash my %user = %$arg; # Now read in the base options my $base; if ($self->incremental) { $base = $self->curr_full; } else { $base = $self->defaults; } # Turn into a real hash for convenience my %base = %$base; # Store a list of all the expanded user keys my @list = (); # Read in synonyms my %syn = %{$self->synonyms}; # Now go through the keys in the user hash and compare with # the defaults foreach my $userkey (sort keys %user) { # Check for matches in the default set my @matched = $self->compare_with_list(0, $userkey, keys %base); # If we had no matches, check the synonyms list if ($#matched == -1) { @matched = $self->compare_with_list(0, $userkey, keys %syn); # If we have matched then convert the key to the actual # value stored in the object for (my $i =0; $i <= $#matched; $i++) { $matched[$i] = $syn{$matched[$i]}; } } # At this point we have matched the userkey to a key in the # defaults list (or if not say so) if ($#matched == -1) { print "Warning: $userkey is not a valid option\n" if $self->{WarnOnMissing}; } else { if ( $#matched > 0 ) { print "Warning: Multiple matches for option $userkey\n"; print "Warning: Could be any of the following:\n"; print join("\n",@matched) . "\n"; print "Accepting the first match ($matched[0])\n"; } # Modify the value in %base and keep track of a separate # array containing only the matched keys $base{$matched[0]} = $user{$userkey}; push(@list, $matched[0]); print "Matched: $userkey for $matched[0]\n" if $self->debug; } } # Finished matching so set this as the current state of the # object $self->curr_keys(@list); $self->curr_full(\%base); # Now process the values via the provided translation # if required. Note that the current design means that # We have to run this after we have set the current state. # Otherwise the translation() method would not work directly # and we would have to provide a public version and a private one. # Note that translate updates the current state of the object # So we don't need to catch the return value $self->translate if $self->autotrans; } # Current state should now be in current. # Simply return it return $self->current; } =item translate Translate the current option values (eg those set via the options() method) using the provided translation(). This method updates the current state of the object and returns the updated options hash as a reference. $ref = $opt->translate; =cut sub translate { my $self = shift; my %trans = %{$self->translation}; my %opt = %{$self->curr_full}; # Process all options # Now need to go through each of the keys # and if the corresponding key exists in the translation # hash we need to check that a valid translation exists foreach my $key ( keys %opt ) { if (exists $trans{$key}) { # Okay so a translation might exist # Now compare keys in the hash in the hash my %subhash = %{$trans{$key}}; my @matched = $self->compare_with_list(1, $opt{$key}, keys %subhash); # At this point we have matched the userkey to a key in the # dictionary. If there is no translation dont say anything # since it may be a 'REAL' answer (ie 1 instead of 'red') if ($#matched > -1) { if ( $#matched > 0 ) { print "Warning: Multiple matches for $opt{$key} in option $key\n"; print "Warning: Could be any of the following:\n"; print join("\n",@matched) . "\n"; print "Accepting the first match ($matched[0])\n"; } # Modify the value in the options set print "Translation: $opt{$key} translated to $subhash{$matched[0]}\n" if $self->debug; $opt{$key} = $subhash{$matched[0]}; } } } # Update the current state return $self->curr_full( \%opt ); } # Private method to compare a key with a list of keys. # The object controls whether case-sensitivity of minimum matching # are required # Arguments: flag to determine whether I am matchin options or translations # this is needed since both methods are configurable with # regards to minimum matching and case sensitivity. # 0 - use $self->minmatch and $self->casesens # 1 - use $self->minmatchtrans and $self->casesenstrans # $key: Key to be compared # @keys: List of keys # Returns: Array of all keys that match $key taking into account the # object state. # # There must be a more compact way of doing this sub compare_with_list { my $self = shift; my $flag = shift; my $key = shift; my @list = @_; my @result = (); my ($casesens, $minmatch); if ($flag == 0) { $casesens = $self->casesens; $minmatch = $self->minmatch; } else { $casesens = $self->casesenstrans; $minmatch = $self->minmatchtrans; } # Do matches # Case Sensitive if ($casesens) { # Always start with the exact match before proceding to minimum # match. # We want to make sure that we will always match on the # exact match even if alternatives exist (eg COL will always # match just COL if the keys are COL and COLOUR) # Case insensitive @result = grep { /^$key$/ } @list; # Proceed to minimum match if we detected nothing # Minumum match/ Case sensitive if ($#result == -1 && $minmatch) { @result = grep { /^$key/ } @list; } } else { # We want to make sure that we will always match on the # exact match even if alternatives exist (eg COL will always # match just COL if the keys are COL and COLOUR) # First do the exact match (case insensitive) { local $^W = undef; # To silence warnings about uninitialised values @result = grep { /^$key$/i } @list; } # If this match came up with something then we will use it # Else we will try a minimum match (assuming flag is true) # Minumum match/ Case insensitive if ($#result == -1 && $minmatch) { @result = grep { /^$key/i } @list; } } return @result; } =back =head1 EXAMPLE Two examples are shown. The first uses the simplified interface and the second uses the object-oriented interface. =head1 Non-OO use PDL::Options (':Func'); %options = parse( { LINE => 1, COLOUR => 'red', }, { COLOR => 'blue' } ); This will return a hash containing %options = ( LINE => 1, COLOUR => 'blue' ) =head1 Object oriented The following example will try to show the main points: use PDL::Options (); # Create new object and supply defaults $opt = new PDL::Options( { Colour => 'red', LineStyle => 'dashed', LineWidth => 1 } ); # Create synonyms $opt->synonyms( { Color => 'Colour' } ); # Create translation dictionary $opt->translation( { Colour => { 'blue' => '#0000ff', 'red' => '#ff0000', 'green'=> '#00ff00' }, LineStyle => { 'solid' => 1, 'dashed' => 2, 'dotted' => 3 } } ); # Generate and parse test hash $options = $opt->options( { Color => 'green', lines => 'solid', } ); When this code is run, $options will be the reference to a hash containing the following: Colour => '#00ff00', LineStyle => 1, LineWidth => 1 If full_options() was set to false (0), $options would be a reference to a hash containing: Colour => '#00ff00', LineStyle => 1 Minimum matching and case insensitivity can be configured for both the initial parsing and for the subsequent translating. The translation can be turned off if not desired. Currently synonyms are not available for the translation although this could be added quite simply. =head1 AUTHOR Copyright (C) Tim Jenness 1998 (t.jenness@jach.hawaii.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut 1; PDL-2.018/Basic/PDL.pm0000644060175006010010000001445113110400215012362 0ustar chmNone=head1 NAME PDL - the Perl Data Language =head1 DESCRIPTION (For the exported PDL constructor, pdl(), see L) PDL is the Perl Data Language, a perl extension that is designed for scientific and bulk numeric data processing and display. It extends perl's syntax and includes fully vectorized, multidimensional array handling, plus several paths for device-independent graphics output. PDL is fast, comparable and often outperforming IDL and MATLAB in real world applications. PDL allows large N-dimensional data sets such as large images, spectra, etc to be stored efficiently and manipulated quickly. =head1 VECTORIZATION For a description of the vectorization (also called "threading"), see L. =head1 INTERACTIVE SHELL The PDL package includes an interactive shell. You can learn about it, run C, or run the shell C or C and type C. =head1 LOOKING FOR A FUNCTION? If you want to search for a function name, you should use the PDL shell along with the "help" or "apropos" command (to do a fuzzy search). For example: pdl> apropos xval xlinvals X axis values between endpoints (see xvals). xlogvals X axis values logarithmicly spaced... xvals Fills a piddle with X index values... yvals Fills a piddle with Y index values. See the CAVEAT for xvals. zvals Fills a piddle with Z index values. See the CAVEAT for xvals. To learn more about the PDL shell, see L or L. =head1 LANGUAGE DOCUMENTATION Most PDL documentation describes the language features. The number of PDL pages is too great to list here. The following pages offer some guidance to help you find the documentation you need. =over 5 =item L Frequently asked questions about PDL. This page covers a lot of questions that do not fall neatly into any of the documentation categories. =item L A guide to PDL's tutorial-style documentation. With topics from beginner to advanced, these pages teach you various aspects of PDL step by step. =item L A guide to PDL's module reference. Modules are organized by level (foundation to advanced) and by category (graphics, numerical methods, etc) to help you find the module you need as quickly as possible. =item L This page compiles PDL's tutorial and reference pages into a comprehensive course that takes you from a complete beginner level to expert. =item L List of all available documentation, sorted alphabetically. If you cannot find what you are looking for, try here. =back =head1 MODULES PDL includes about a dozen perl modules that form the core of the language, plus additional modules that add further functionality. The perl module "PDL" loads all of the core modules automatically, making their functions available in the current perl namespace. Some notes: =over 5 =item Modules loaded by default See the SYNOPSIS section at the end of this document for a list of modules loaded by default. =item L and L These are lighter-weight alternatives to the standard PDL module. Consider using these modules if startup time becomes an issue. =item Exports C exports a large number of routines into the calling namespace. If you want to avoid namespace pollution, you must instead C, and include any additional modules explicitly. =item L Note that the L syntax is NOT automatically loaded by C. If you want to use the extended slicing syntax in a standalone script, you must also say C. =item L The L module has been added to the list of modules for versions later than 2.3.1. Note that PDL::Math is still I included in the L and L start-up modules. =back =head1 SYNOPSIS use PDL; # Is equivalent to the following: use PDL::Core; use PDL::Ops; use PDL::Primitive; use PDL::Ufunc; use PDL::Basic; use PDL::Slices; use PDL::Bad; use PDL::MatrixOps; use PDL::Math; use PDL::Version; use PDL::IO::Misc; use PDL::IO::FITS; use PDL::IO::Pic; use PDL::IO::Storable; use PDL::Lvalue; =cut # set the version: $PDL::VERSION = '2.018'; # Main loader of standard PDL package sub PDL::import { my $pkg = (caller())[0]; eval <<"EOD"; package $pkg; # Load the fundamental packages use PDL::Core; use PDL::Ops; use PDL::Primitive; use PDL::Ufunc; use PDL::Basic; use PDL::Slices; use PDL::Bad; use PDL::Math; use PDL::MatrixOps; use PDL::Lvalue; # Load these for TPJ compatibility use PDL::IO::Misc; # Misc IO (Ascii) use PDL::IO::FITS; # FITS IO (rfits/wfits; used by rpic/wpic too) use PDL::IO::Pic; # rpic/wpic # Load this so config/install info is available use PDL::Config; # Load this to avoid mysterious Storable segfaults use PDL::IO::Storable; EOD die $@ if $@; } # Dummy Package PDL Statement. This is only needed so CPAN # properly recognizes the PDL package. package PDL; # support: use Inline with => 'PDL'; # Returns a hash containing parameters accepted by recent versions of # Inline, to tweak compilation. Not normally called by anyone but # the Inline API. # # If you're trying to debug the actual code, you're looking for "IFiles.pm" # which is currently in the Core directory. --CED 23-Feb-2015 sub Inline { require PDL::Install::Files; goto &PDL::Install::Files::Inline; } ################################################## # Rudimentary handling for multiple Perl threads # ################################################## my $clone_skip_should_be_quiet = 0; sub CLONE_SKIP { warn("* If you need to share PDL data across threads, use memory mapped data, or\n" . "* check out PDL::Parallel::threads, available on CPAN.\n" . "* You can silence this warning by saying `PDL::no_clone_skip_warning;'\n" . "* before you create your first thread.\n") unless $clone_skip_should_be_quiet; PDL::no_clone_skip_warning(); # Whether we warned or not, always return 1 to tell Perl not to clone PDL data return 1; } sub no_clone_skip_warning { $clone_skip_should_be_quiet = 1; } # Exit with OK status 1; PDL-2.018/Basic/Pod/0000755060175006010010000000000013110402046012126 5ustar chmNonePDL-2.018/Basic/Pod/API.pod0000644060175006010010000003162313036512174013263 0ustar chmNone=head1 NAME PDL::API - making piddles from Perl and C/XS code =head1 DESCRIPTION A simple cookbook how to create piddles manually. It covers both the Perl and the C/XS level. Additionally, it describes the PDL core routines that can be accessed from other modules. These routines basically define the PDL API. If you need to access piddles from C/XS you probably need to know about these functions. =head1 SYNOPSIS use PDL; sub mkmypiddle { ... } =head1 Creating a piddle manually from Perl Sometimes you want to create a piddle I from binary data. You can do that at the Perl level. Examples in the distribution include some of the IO routines. The code snippet below illustrates the required steps. use Carp; sub mkmypiddle { my $class = shift; my $pdl = $class->new; $pdl->set_datatype($PDL_B); my @dims = (1,3,4); my $size = 1; for (@dims) { $size *= $_ } $pdl->setdims([@dims]); my $dref = $pdl->get_dataref(); # read data directly from file open my $file, 'get_datatype); croak "couldn't read enough data" if read( $file, $$dref, $len) != $len; close $file; $pdl->upd_data(); return $pdl; } =head1 Creating a piddle in C The following example creates a piddle at the C level. We use the C module which is really the way to interface Perl and C these days, using the C capability in L 0.68+. use PDL::LiteF; $a = myfloatseq(); # exercise our C piddle constructor print $a->info,"\n"; use Inline with => 'PDL'; use Inline C; Inline->init; # useful if you want to be able to 'do'-load this script __DATA__ __C__ static pdl* new_pdl(int datatype, PDL_Indx dims[], int ndims) { pdl *p = PDL->pdlnew(); PDL->setdims (p, dims, ndims); /* set dims */ p->datatype = datatype; /* and data type */ PDL->allocdata (p); /* allocate the data chunk */ return p; } pdl* myfloatseq() { PDL_Indx dims[] = {5,5,5}; pdl *p = new_pdl(PDL_F,dims,3); PDL_Float *dataf = (PDL_Float *) p->data; PDL_Indx i; /* dimensions might be 64bits */ for (i=0;i<5*5*5;i++) dataf[i] = i; /* the data must be initialized ! */ return p; } =head2 Wrapping your own data into a piddle Sometimes you obtain a chunk of data from another source, for example an image processing library, etc. All you want to do in that case is wrap your data into a piddle struct at the C level. Examples using this approach can be found in the IO modules (where FastRaw and FlexRaw use it for mmapped access) and the Gimp Perl module (that uses it to wrap Gimp pixel regions into piddles). The following script demonstrates a simple example: use PDL::LiteF; use PDL::Core::Dev; use PDL::Graphics::PGPLOT; $b = mkpiddle(); print $b->info,"\n"; imag1 $b; use Inline with => 'PDL'; use Inline C; Inline->init; __DATA__ __C__ /* wrap a user supplied chunk of data into a piddle * You must specify the dimensions (dims,ndims) and * the datatype (constants for the datatypes are declared * in pdl.h; e.g. PDL_B for byte type, etc) * * when the created piddle 'npdl' is destroyed on the * Perl side the function passed as the 'delete_magic' * parameter will be called with the pointer to the pdl structure * and the 'delparam' argument. * This gives you an opportunity to perform any clean up * that is necessary. For example, you might have to * explicitly call a function to free the resources * associated with your data pointer. * At the very least 'delete_magic' should zero the piddle's data pointer: * * void delete_mydata(pdl* pdl, int param) * { * pdl->data = 0; * } * pdl *p = pdl_wrap(mydata, PDL_B, dims, ndims, delete_mydata,0); * * pdl_wrap returns the pointer to the pdl * that was created. */ typedef void (*DelMagic)(pdl *, int param); static void default_magic(pdl *p, int pa) { p->data = 0; } static pdl* pdl_wrap(void *data, int datatype, PDL_Indx dims[], int ndims, DelMagic delete_magic, int delparam) { pdl* npdl = PDL->pdlnew(); /* get the empty container */ PDL->setdims(npdl,dims,ndims); /* set dims */ npdl->datatype = datatype; /* and data type */ npdl->data = data; /* point it to your data */ /* make sure the core doesn't meddle with your data */ npdl->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; if (delete_magic != NULL) PDL->add_deletedata_magic(npdl, delete_magic, delparam); else PDL->add_deletedata_magic(npdl, default_magic, 0); return npdl; } #define SZ 256 /* a really silly function that makes a ramp image * in reality this could be an opaque function * in some library that you are using */ static PDL_Byte* mkramp(void) { PDL_Byte *data; int i; /* should use PDL_Indx to support 64bit pdl indexing */ if ((data = malloc(SZ*SZ*sizeof(PDL_Byte))) == NULL) croak("mkramp: Couldn't allocate memory"); for (i=0;idata) free(p->data); p->data = 0; } pdl* mkpiddle() { PDL_Indx dims[] = {SZ,SZ}; pdl *p; p = pdl_wrap((void *) mkramp(), PDL_B, dims, 2, delete_myramp,0); /* the delparam is abitrarily set to 0 */ return p; } =head1 The gory details =head2 The Core struct -- getting at PDL core routines at runtime PDL uses a technique similar to that employed by the Tk modules to let other modules use its core routines. A pointer to all shared core PDL routines is stored in the C<$PDL::SHARE> variable. XS code should get hold of this pointer at boot time so that the rest of the C/XS code can then use that pointer for access at run time. This initial loading of the pointer is most easily achieved using the functions C and C that are defined and exported by C. Typical usage with the Inline module has already been demonstrated: use Inline with => 'PDL'; In earlier versions of C, this was achieved like this: use Inline C => Config => INC => &PDL_INCLUDE, TYPEMAPS => &PDL_TYPEMAP, AUTO_INCLUDE => &PDL_AUTO_INCLUDE, # declarations BOOT => &PDL_BOOT; # code for the XS boot section The code returned by C makes sure that F is included and declares the static variables to hold the pointer to the C struct. It looks something like this: print PDL_AUTO_INCLUDE; #include static Core* PDL; /* Structure holds core C functions */ static SV* CoreSV; /* Gets pointer to Perl var holding core structure */ The code returned by C retrieves the C<$PDL::SHARE> variable and initializes the pointer to the C struct. For those who know their way around the Perl API here is the code: perl_require_pv ("PDL/Core.pm"); /* make sure PDL::Core is loaded */ #ifndef aTHX_ #define aTHX_ #endif if (SvTRUE (ERRSV)) Perl_croak(aTHX_ "%s",SvPV_nolen (ERRSV)); CoreSV = perl_get_sv("PDL::SHARE",FALSE); /* SV* value */ if (CoreSV==NULL) Perl_croak(aTHX_ "We require the PDL::Core module, which was not found"); PDL = INT2PTR(Core*,SvIV( CoreSV )); /* Core* value */ if (PDL->Version != PDL_CORE_VERSION) Perl_croak(aTHX_ "[PDL->Version: \%d PDL_CORE_VERSION: \%d XS_VERSION: \%s] The code needs to be recompiled against the newly installed PDL", PDL->Version, PDL_CORE_VERSION, XS_VERSION); The C struct contains version info to ensure that the structure defined in F really corresponds to the one obtained at runtime. The code above tests for this if (PDL->Version != PDL_CORE_VERSION) .... For more information on the Core struct see L. With these preparations your code can now access the core routines as already shown in some of the examples above, e.g. pdl *p = PDL->pdlnew(); By default the C variable named C is used to hold the pointer to the C struct. If that is (for whichever reason) a problem you can explicitly specify a name for the variable with the C and the C routines: use Inline C => Config => INC => &PDL_INCLUDE, TYPEMAPS => &PDL_TYPEMAP, AUTO_INCLUDE => &PDL_AUTO_INCLUDE 'PDL_Corep', BOOT => &PDL_BOOT 'PDL_Corep'; Make sure you use the same identifier with C and C and use that same identifier in your own code. E.g., continuing from the example above: pdl *p = PDL_Corep->pdlnew(); =head2 Some selected core routines explained The full definition of the C struct can be found in the file F. In the following the most frequently used member functions of this struct are briefly explained. =over 5 =item * C =item * C =item * C C returns an empty pdl object that needs further initialization to turn it into a proper piddle. Example: pdl *p = PDL->pdlnew(); PDL->setdims(p,dims,ndims); p->datatype = PDL_B; =item * C =item * C =item * C =item * C =item * C =item * C =item * C =item * C =item * C =item * C and C where X is one of B,S,U,L,F,D and Xtype is one of Byte, Short, Ushort, Long, Float or Double. PDL_Indx is the C integer type corresponding to appropriate indexing size for the perl configuration (ivsize and ivtype). It can be either 'long' or 'long long' depending on whether your perl is 32bit or 64bit enabled. =item * C and C These are constants to produce the required NaN values. =item * C and C These are C-code equivalents of C and C. They include special handling of error or warning messages during pthreading (i.e. processor multi-threading) that defer the messages until after pthreading is completed. When pthreading is complete, perl's C or C is called with the deferred messages. This is needed to keep from calling perl's C or C during pthreading, which can cause segfaults. Note that C and C have been redefined (using c-preprocessor macros) in pdlcore.h to C<< PDL->barf >> and C<< PDL->warn >>. This is to keep any XS or PP code from calling perl's C or C directly, which can cause segfaults during pthreading. See L for more information on pthreading. =back =cut # ones that are not clear: # safe_indterm # converttypei_new # converttype # get_convertedpdl # affine_new # make_trans_mutual # make_now # get # get_offs # put_offs # setdims_careful # tmp # destroy # twod # grow # flushcache # reallocdims # reallocthreadids # resize_defaultincs =head1 SEE ALSO L L =head2 Handy macros from pdl.h Some of the C API functions return C C type which is a structure and therefore requires special handling. You might want to use for example C function: /* THIS DOES NOT WORK! (although it did in older PDL) */ if( PDL->get_pdl_badvalue(a) == 0 ) { ... } /* THIS IS CORRECT */ double bad_a; ANYVAL_TO_CTYPE(bad_a, double, PDL->get_pdl_badvalue(a)); if( bad_a == 0 ) { ... } In pdl.h there are the following macros for handling PDL_Anyval from C code: ANYVAL_TO_SV(out_SV, in_anyval) ANYVAL_FROM_CTYPE(out_anyval, out_anyval_type, in_variable) ANYVAL_TO_CTYPE(out_variable, out_ctype, in_anyval) ANYVAL_EQ_ANYVAL(x, y) As these macros where not available in older PDL versions you might want to add the following defines into your C/XS code to make compatible with older PDL versions. #if PDL_CORE_VERSION < 12 #define ANYVAL_TO_SV(outsv,inany) outsv = newSVnv((NV)(inany) #define ANYVAL_FROM_CTYPE(outany,avtype,inval) outany = (PDL_Double)(inval) #define ANYVAL_TO_CTYPE(outval,ctype,inany) outval = (ctype)(inany) #define ANYVAL_EQ_ANYVAL(x,y) (x == y) #endif =head1 BUGS This manpage is still under development. Feedback and corrections are welcome. =head1 COPYRIGHT Copyright 2013 Chris Marshall (chm@cpan.org). Copyright 2010 Christian Soeller (c.soeller@auckland.ac.nz). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ =cut PDL-2.018/Basic/Pod/BadValues.pod0000644060175006010010000006365212562522363014533 0ustar chmNone=head1 NAME PDL::BadValues - Discussion of bad value support in PDL =head1 DESCRIPTION =head2 What are bad values and why should I bother with them? Sometimes it's useful to be able to specify a certain value is 'bad' or 'missing'; for example CCDs used in astronomy produce 2D images which are not perfect since certain areas contain invalid data due to imperfections in the detector. Whilst PDL's powerful index routines and all the complicated business with dataflow, slices, etc etc mean that these regions can be ignored in processing, it's awkward to do. It would be much easier to be able to say C<$c = $a + $b> and leave all the hassle to the computer. If you're not interested in this, then you may (rightly) be concerned with how this affects the speed of PDL, since the overhead of checking for a bad value at each operation can be large. Because of this, the code has been written to be as fast as possible - particularly when operating on piddles which do not contain bad values. In fact, you should notice essentially no speed difference when working with piddles which do not contain bad values. However, if you do not want bad values, then PDL's C configuration option comes to the rescue; if set to 0 or undef, the bad-value support is ignored. About the only time I think you'll need to use this - I admit, I'm biased ;) - is if you have limited disk or memory space, since the size of the code is increased (see below). You may also ask 'well, my computer supports IEEE NaN, so I already have this'. Well, yes and no - many routines, such as C, will propagate NaN's without the user having to code differently, but routines such as C, or finding the median of an array, need to be re-coded to handle bad values. For floating-point datatypes, C and C are used to flag bad values I the option C is set to 1 in your config file. Otherwise special values are used (L). I do not have any benchmarks to see which option is faster. There is an experimental feature C which, if set, allows you to have different bad values for separate piddles of the same type. This currently does not work with the C option; if both are set then PDL will ignore the C value. =head2 Code increase due to bad values The following comparison is out of date! On an i386 machine running Linux and Perl 5.005_03, I measured the following sizes (the Slatec code was compiled in, but none of the other options: e.g., FFTW, GSL, and TriD were): =over 4 =item WITH_BADVAL = 0 Size of blib directory after a successful make = B<4963 kb>: blib/arch = 2485 kb and blib/lib = 1587 kb. =item WITH_BADVAL = 1 Size of blib directory after a successful make = B<5723 kb>: blib/arch = 3178 kb and blib/lib = 1613 kb. =back So, the overall increase is I 15% - not much to pay for all the wonders that bad values provides ;) The source code used for this test had the vast majority of the core routines (eg those in Basic/) converted to use bad values, whilst very few of the 'external' routines (i.e. everything else in the PDL distribution) had been changed. =head2 A quick overview pdl> p $PDL::Bad::Status 1 pdl> $a = sequence(4,3); pdl> p $a [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] ] pdl> $a = $a->setbadif( $a % 3 == 2 ) pdl> p $a [ [ 0 1 BAD 3] [ 4 BAD 6 7] [BAD 9 10 BAD] ] pdl> $a *= 3 pdl> p $a [ [ 0 3 BAD 9] [ 12 BAD 18 21] [BAD 27 30 BAD] ] pdl> p $a->sum 120 C and C within L or L gives a demonstration of some of the things possible with bad values. These are also available on PDL's web-site, at F. See L for useful routines for working with bad values and F to see them in action. The intention is to: =over 4 =item * not significantly affect PDL for users who don't need bad value support =item * be as fast as possible when bad value support is installed =back If you never want bad value support, then you set C to 0 in F; PDL then has no bad value support compiled in, so will be as fast as it used to be. However, in most cases, the bad value support has a negligible affect on speed, so you should set C to 1! One exception is if you are low on memory, since the amount of code produced is larger (but only by about 15% - see L). To find out if PDL has been compiled with bad value support, look at the values of either C<$PDL::Config{WITH_BADVAL}> or C<$PDL::Bad::Status> - if true then it has been. To find out if a routine supports bad values, use the C command in L or L or the C<-b> option to L. This facility is currently a 'proof of concept' (or, more realistically, a quick hack) so expect it to be rough around the edges. Each piddle contains a flag - accessible via C<$pdl-Ebadflag> - to say whether there's any bad data present: =over 4 =item * If B, which means there's no bad data here, the code supplied by the C option to C is executed. This means that the speed should be very close to that obtained with C, since the only overhead is several accesses to a bit in the piddles state variable. =item * If B, then this says there I be bad data in the piddle, so use the code in the C option (assuming that the C for this routine has been updated to have a BadCode key). You get all the advantages of threading, as with the C option, but it will run slower since you are going to have to handle the presence of bad values. =back If you create a piddle, it will have its bad-value flag set to 0. To change this, use C<$pdl-Ebadflag($new_bad_status)>, where C<$new_bad_status> can be 0 or 1. When a routine creates a piddle, its bad-value flag will depend on the input piddles: unless over-ridden (see the C option to C), the bad-value flag will be set true if any of the input piddles contain bad values. To check that a piddle really contains bad data, use the C method. I: propagation of the badflag If you change the badflag of a piddle, this change is propagated to all the I of a piddle, so pdl> $a = zeroes(20,30); pdl> $b = $a->slice('0:10,0:10'); pdl> $c = $b->slice(',(2)'); pdl> print ">>c: ", $c->badflag, "\n"; >>c: 0 pdl> $a->badflag(1); pdl> print ">>c: ", $c->badflag, "\n"; >>c: 1 I change is made to the parents of a piddle, so pdl> print ">>a: ", $a->badflag, "\n"; >>a: 1 pdl> $c->badflag(0); pdl> print ">>a: ", $a->badflag, "\n"; >>a: 1 Thoughts: =over 4 =item * the badflag can ONLY be cleared IF a piddle has NO parents, and that this change will propagate to all the children of that piddle. I am not so keen on this anymore (too awkward to code, for one). =item * C<$a-Ebadflag(1)> should propagate the badflag to BOTH parents and children. =back This shouldn't be hard to implement (although an initial attempt failed!). Does it make sense though? There's also the issue of what happens if you change the badvalue of a piddle - should these propagate to children/parents (yes) or whether you should only be able to change the badvalue at the 'top' level - i.e. those piddles which do not have parents. The C method returns the compile-time value for a given datatype. It works on piddles, PDL::Type objects, and numbers - eg $pdl->orig_badvalue(), byte->orig_badvalue(), and orig_badvalue(4). It also has a horrible name... To get the current bad value, use the C method - it has the same syntax as C. To change the current bad value, supply the new number to badvalue - eg $pdl->badvalue(2.3), byte->badvalue(2), badvalue(5,-3e34). I: the value is silently converted to the correct C type, and returned - i.e. Cbadvalue(-26)> returns 230 on my Linux machine. It is also a C for floating-point types when C is true. Note that changes to the bad value are I propagated to previously-created piddles - they will still have the bad value set, but suddenly the elements that were bad will become 'good', but containing the old bad value. See discussion below. It's not a problem for floating-point types which use NaN, since you can not change their badvalue. =head2 Bad values and boolean operators For those boolean operators in L, evaluation on a bad value returns the bad value. Whilst this means that $mask = $img > $thresh; correctly propagates bad values, it I cause problems for checks such as do_something() if any( $img > $thresh ); which need to be re-written as something like do_something() if any( setbadtoval( ($img > $thresh), 0 ) ); When using one of the 'projection' functions in L - such as L - bad values are skipped over (see the documentation of these functions for the current (poor) handling of the case when all elements are bad). =head2 A bad value for each piddle, and related issues An B option C has been added to F to allow per-piddle bad values. The documentation has not been updated to account for this change. The following is relevant only for integer types, and for floating-point types if C was not set when PDL was built. Currently, there is one bad value for each datatype. The code is written so that we could have a separate bad value for each piddle (stored in the pdl structure) - this would then remove the current problem of: pdl> $a = byte( 1, 2, byte->badvalue, 4, 5 ); pdl> p $a; [1 2 255 4 5] pdl> $a->badflag(1) pdl> p $a; [1 2 BAD 4 5] pdl> byte->badvalue(0); pdl> p $a; [1 2 255 4 5] ie the bad value in C<$a> has lost its I status using the current implementation. It would almost certainly cause problems elsewhere though! =head1 IMPLEMENTATION DETAILS PDL code just needs to access the C<%PDL::Config> array (e.g. F) to find out whether bad-value support is required. A new flag has been added to the state of a piddle - C. If unset, then the piddle does not contain bad values, and so all the support code can be ignored. If set, it does not guarantee that bad values are present, just that they should be checked for. Thanks to Christian, C - which sets/clears this flag (see F) - will update I the children/grandchildren/etc of a piddle if its state changes (see C in F and C in F). It's not clear what to do with parents: I can see the reason for propagating a 'set badflag' request to parents, but I think a child should NOT be able to clear the badflag of a parent. There's also the issue of what happens when you change the bad value for a piddle. The C structure has been extended to include an integer value, C, which acts as a switch to tell the code whether to handle bad values or not. This value is set if any of the input piddles have their C flag set (although this code can be replaced by setting C in pp_def). The logic of the check is going to get a tad more complicated if I allow routines to fall back to using the C section for floating-point types (i.e. those routines with C 1> when C is true). The bad values for the integer types are now stored in a structure within the Core PDL structure - C (eg F); see also C in F and the BOOT code of F where the values are initialised to (hopefully) sensible values. See F for read/write routines to the values. The addition of the C option has resulted in additional changes to the internals of piddles. These changes are not documented yet. =head2 Why not make a PDL subclass? The support for bad values could have been done as a PDL sub-class. The advantage of this approach would be that you only load in the code to handle bad values if you actually want to use them. The downside is that the code then gets separated: any bug fixes/improvements have to be done to the code in two different files. With the present approach the code is in the same C function (although there is still the problem that both C and C sections need updating). =head2 Default bad values The default/original bad values are set to (taken from the Starlink distribution): #include PDL_Byte == UCHAR_MAX PDL_Short == SHRT_MIN PDL_Ushort == USHRT_MAX PDL_Long == INT_MIN If C, then we also have PDL_Float == -FLT_MAX PDL_Double == -DBL_MAX otherwise all of C, C<+Inf>, and C<-Inf> are taken to be bad for floating-point types. In this case, the bad value can't be changed, unlike the integer types. =head2 How do I change a routine to handle bad values? Examples can be found in most of the F<*.pd> files in F (and hopefully many more places soon!). Some of the logic might appear a bit unclear - that's probably because it is! Comments appreciated. All routines should automatically propagate the bad status flag to output piddles, unless you declare otherwise. If a routine explicitly deals with bad values, you must provide this option to pp_def: HandleBad => 1 This ensures that the correct variables are initialised for the C<$ISBAD> etc macros. It is also used by the automatic document-creation routines to provide default information on the bad value support of a routine without the user having to type it themselves (this is in its early stages). To flag a routine as NOT handling bad values, use HandleBad => 0 This I cause the routine to print a warning if it's sent any piddles with the bad flag set. Primitive's C has had this set - since it would be awkward to convert - but I've not tried it out to see if it works. If you want to handle bad values but not set the state of all the output piddles, or if it's only one input piddle that's important, then look at the PP rules C and C and the corresponding C options: =over 4 =item FindBadStatusCode By default, C creates code which sets C<$PRIV(bvalflag)> depending on the state of the bad flag of the input piddles: see C in F. User-defined code should also store the value of C in the C<$BADFLAGCACHE()> variable. =item CopyBadStatusCode The default code here is a bit simpler than for C: the bad flag of the output piddles are set if C<$BADFLAGCACHE()> is true after the code has been evaluated. Sometimes C is set to an empty string, with the responsibility of setting the badflag of the output piddle left to the C section (e.g. the C routines in F). Prior to PDL 2.4.3 we used C<$PRIV(bvalflag)> instead of C<$BADFLAGCACHE()>. This is dangerous since the C<$PRIV()> structure is not guaranteed to be valid at this point in the code. =back If you have a routine that you want to be able to use as in-place, look at the routines in F (or F) which use the C option to see how the bad flag is propagated to children using the C options. I decided not to automate this as rules would be a little complex, since not every in-place op will need to propagate the badflag (eg unary functions). If the option HandleBad => 1 is given, then many things happen. For integer types, the readdata code automatically creates a variable called Cpdl nameE_badval>, which contains the bad value for that piddle (see C in F). However, do not hard code this name into your code! Instead use macros (thanks to Tuomas for the suggestion): '$ISBAD(a(n=>1))' expands to '$a(n=>1) == a_badval' '$ISGOOD(a())' '$a() != a_badval' '$SETBAD(bob())' '$bob() = bob_badval' well, the C<$a(...)> is expanded as well. Also, you can use a C<$> before the pdl name, if you so wish, but it begins to look like line noise - eg C<$ISGOOD($a())>. If you cache a piddle value in a variable -- eg C in F -- the following routines are useful: '$ISBADVAR(c_var,pdl)' 'c_var == pdl_badval' '$ISGOODVAR(c_var,pdl)' 'c_var != pdl_badval' '$SETBADVAR(c_var,pdl)' 'c_var = pdl_badval' The following have been introduced, They may need playing around with to improve their use. '$PPISBAD(CHILD,[i]) 'CHILD_physdatap[i] == CHILD_badval' '$PPISGOOD(CHILD,[i]) 'CHILD_physdatap[i] != CHILD_badval' '$PPSETBAD(CHILD,[i]) 'CHILD_physdatap[i] = CHILD_badval' If C is set, then it's a bit different for C and C, where we consider C, C<+Inf>, and C<-Inf> all to be bad. In this case: ISBAD becomes finite(piddle) == 0 ISGOOD finite(piddle) != 0 SETBAD piddle = NaN where the value for NaN is discussed below in L. This all means that you can change Code => '$a() = $b() + $c();' to BadCode => 'if ( $ISBAD(b()) || $ISBAD(c()) ) { $SETBAD(a()); } else { $a() = $b() + $c(); }' leaving Code as it is. PP::PDLCode will then create a loop something like if ( __trans->bvalflag ) { threadloop over BadCode } else { threadloop over Code } (it's probably easier to just look at the F<.xs> file to see what goes on). =head2 Going beyond the Code section Similar to C, there's C, and C. Handling C is a bit different: under the assumption that the only access to data is via the C<$EQUIVCPOFFS(i,j)> macro, then we can automatically create the 'bad' version of it; see the C<[EquivCPOffsCode]> and C<[Code]> rules in L. =head2 Macro access to the bad flag of a piddle Macros have been provided to provide access to the bad-flag status of a pdl: '$PDLSTATEISBAD(a)' -> '($PDL(a)->state & PDL_BADVAL) > 0' '$PDLSTATEISGOOD(a)' '($PDL(a)->state & PDL_BADVAL) == 0' '$PDLSTATESETBAD(a)' '$PDL(a)->state |= PDL_BADVAL' '$PDLSTATESETGOOD(a)' '$PDL(a)->state &= ~PDL_BADVAL' For use in C (+ other stuff that goes into the INIT: section) there are: '$SETPDLSTATEBAD(a)' -> 'a->state |= PDL_BADVAL' '$SETPDLSTATEGOOD(a)' -> 'a->state &= ~PDL_BADVAL' '$ISPDLSTATEBAD(a)' -> '((a->state & PDL_BADVAL) > 0)' '$ISPDLSTATEGOOD(a)' -> '((a->state & PDL_BADVAL) == 0)' In PDL 2.4.3 the C<$BADFLAGCACHE()> macro was introduced for use in C and C. =head2 Handling NaN values There are two issues: =over 4 =item NaN as the bad value which is done. To select, set C to 1 in perldl.conf; a value of 0 falls back to treating the floating-point types the same as the integers. I need to do some benchmarks to see which is faster, and whether it's dependent on machines (Linux seems to slow down much more than my Sparc machine in some very simple tests I did). =item Ignoring BadCode sections which is I. =back For I routines processing floating-point numbers, we should let the computer process the bad values (i.e. C and C values) instead of using the code in the C section. Many such routines have been labeled using C 1>; however this is currently I by PDL::PP. For these routines, we want to use the C section if the piddle does not have its bad flag set the datatype is a float or double otherwise we use the C section. This is I, as it will require reasonable hacking of PP::PDLCode! There's also the problem of how we handle 'exceptions' - since C<$a = pdl(2) / pdl(0)> produces a bad value but doesn't update the badflag value of the piddle. Can we catch an exception, or do we have to trap for this (e.g. search for C in F)? Checking for C, and C is done by using the C system call. If you want to set a value to the C value, the following bit of code can be used (this can be found in both F and F): /* for big-endian machines */ static union { unsigned char __c[4]; float __d; } __pdl_nan = { { 0x7f, 0xc0, 0, 0 } }; /* for little-endian machines */ static union { unsigned char __c[4]; float __d; } __pdl_nan = { { 0, 0, 0xc0, 0x7f } }; This approach should probably be replaced by library routines such as C or C. To find out whether a particular machine is big endian, use the routine C. =head1 WHAT ABOUT DOCUMENTATION? One of the strengths of PDL is its on-line documentation. The aim is to use this system to provide information on how/if a routine supports bad values: in many cases C contains all the information anyway, so the function-writer doesn't need to do anything at all! For the cases when this is not sufficient, there's the C option. For code written at the Perl level - i.e. in a .pm file - use the C<=for bad> pod directive. This information will be available via man/pod2man/html documentation. It's also accessible from the C or C shells - using the C command - and the C shell command - using the C<-b> option. This support is at a very early stage - i.e. not much thought has gone into it: comments are welcome; improvements to the code preferred ;) One awkward problem is for F<*.pm> code: you have to write a F<*.pm.PL> file which only inserts the C<=for bad> directive (+ text) if bad value support is compiled in. In fact, this is a pain when handling bad values at the Perl, rather than PDL::PP, level: perhaps I should just scrap the C option... =head1 CURRENT ISSUES There are a number of areas that need work, user input, or both! They are mentioned elsewhere in this document, but this is just to make sure they don't get lost. =head2 Trapping invalid mathematical operations Should we add exceptions to the functions in C to set the output bad for out-of-range input values? pdl> p log10(pdl(10,100,-1)) I would like the above to produce "[1 2 BAD]", but this would slow down operations on I piddles. We could check for C/C values after the operation, but I doubt that would be any faster. =head2 Integration with NaN When C is true, the routines in C should just fall through to the C section - i.e. don't use C - for C and C data types. =head2 Global versus per-piddle bad values I think all that's needed is to change the routines in C, although there's bound to be complications. It would also mean that the pdl structure would need to have a variable to store its bad value, which would mean binary incompatibility with previous versions of PDL with bad value support. As of 17 March 2006, PDL contains the B C configuration option which, if selected, adds per-piddle bad values. =head2 Dataflow of the badflag Currently changes to the bad flag are propagated to the children of a piddle, but perhaps they should also be passed on to the parents as well. With the advent of per-piddle bad values we need to consider how to handle changes to the value used to represent bad items too. =head1 EVERYTHING ELSE The build process has been affected. The following files are now created during the build: Basic/Core/pdlcore.h pdlcore.h.PL pdlcore.c pdlcore.c.PL pdlapi.c pdlapi.c.PL Core.xs Core.xs.PL Core.pm Core.pm.PL Several new files have been added: Basic/Pod/BadValues.pod (i.e. this file) t/bad.t Basic/Bad/ Basic/Bad/Makefile.PL bad.pd etc =head1 TODO/SUGGESTIONS =over 4 =item * Look at using per-piddle bad values. Would mean a change to the pdl structure (i.e. binary incompatibility) and the routines in C would need changing to handle this. Most other routines I need to be changed ... See the B C option. =item * what to do about C<$b = pdl(-2); $a = log10($b)> - C<$a> should be set bad, but it currently isn't. =item * Allow the operations in PDL::Ops to skip the check for bad values when using NaN as a bad value and processing a floating-point piddle. Needs a fair bit of work to PDL::PP::PDLCode. =item * C<$pdl-Ebaddata()> now updates all the children of this piddle as well. However, not sure what to do with parents, since: $b = $a->slice(); $b->baddata(0) doesn't mean that C<$a> shouldn't have its badvalue cleared. however, after $b->baddata(1) it's sensible to assume that the parents now get flagged as containing bad values. PERHAPS you can only clear the bad value flag if you are NOT a child of another piddle, whereas if you set the flag then all children AND parents should be set as well? Similarly, if you change the bad value in a piddle, should this be propagated to parent & children? Or should you only be able to do this on the 'top-level' piddle? Nasty... =item * get some code set up to do benchmarks to see how much things are slowed down (and to check that I haven't messed things up if C is 0/undef). =item * some of the names aren't appealing - I'm thinking of C in F in particular. Any suggestions appreciated. =back =head1 AUTHOR Copyright (C) Doug Burke (djburke@cpan.org), 2000, 2006. The per-piddle bad value support is by Heiko Klein (2006). Commercial reproduction of this documentation in a different format is forbidden. =cut PDL-2.018/Basic/Pod/Course.pod0000644060175006010010000004026712562522363014122 0ustar chmNone=head1 NAME PDL::Course - A journey through PDL's documentation, from beginner to advanced. =head1 AUTHOR, DATE This is written by David Mertens with edits by Daniel Carrera. =head1 Preface PDL's documentation is extensive. Some sections cover deep core magic while others cover more usual topics like IO and numerical computation. How are these related? Where should you begin? This document is an attempt to pull all the key PDL documentation together in a coherent study course, starting from the beginner level, up to the expert. I've broken down everything by level of expertise, and within expertise I've covered documentation, library, and workflow modules. The documentation modules are useful for what they tell you; the library modules are useful for the functions that they define for you; the workflow modules are useful for the way that they allow you to get your work done in new and different ways. =head1 Introductory If you are new to PDL, these documentation modules will get you started down the right path for using PDL. =head2 Documentation Modules that tell you how to start using PDL. Many of these are library modules technically, but they are included when you C, so I've included them for their documentation. After the first three, most of the docs listed below are rather dry. Perhaps they would be better summarized by tables or better synopses. You should at least scan through them to familiarize yourself with the basic capabilities of PDL. =over =item * L, L A couple of brief introductions to PDL. The second one is a bit more hands-on. If you are new to PDL, you should start with these. =item * L Covers basic piddle-creation routines like C, C, and C to name a random few. Also covers C and C. =item * L Explains a large collection of built-in functions which, given an N-dimension piddle, will create a piddle with N-1 dimensions. =item * L PDL came of age right around the turn of the millennium and NiceSlice came on the scene slightly after that. Some of the docs still haven't caught up. NiceSlice is the 'modern' way to slice and dice your piddles. Read the Synopsis, then scroll down to The New Slicing Syntax. After you've read to the bottom, return to and read the stuff at the top. =item * L Defines a whole slew of useful built-in functions. These are the sorts of things that beginners are likely to write to the list and say, "How do I do xxx?" You would be well on your way to learning the ropes after you've gotten through this document. =item * Selections from L Like PDL::Primitive, defines a large set of useful functions. Unfortunately, some of the functions are quite esoteric, but are mixed in with the rest of the simple and easy ones. Skim the whole document, skipping over the complicated functions for now. I would point out in particular the function C. =back =head2 Workflow =over =item * The L or L Shell The Perldl Shell is a REPL (Read-Evaluate-Print-Loop, in other words, a prompt or shell) that allows you to work with PDL (or any Perl, for that matter) in 'real time', loading data from files, plotting, manipulating... Anything you can do in a script, you can do in the PDL Shell, with instant feedback! =back =head2 Libraries =over =item * L The main workhorse module. You'll include this in nearly every PDL program you write. =back =head1 Normal Usage The sorts of modules that you'll likely use on a normal basis in scripts or from within the perldl shell. Some of these modules you may never use, but you should still be aware that they exist, just in case you need their functionality. =head2 Documentation =over =item * L In addition to explaining the original slicing and dicing functions - for which you can usually use L - this also covers many dimension-handling functions such as C, C, and C. This also thoroughly documents the C function, which can be very powerful, and covers a number of internal functions, which can probably be skipped. =item * L This covers a lot of the deeper conceptual ground that you'll need to grasp to really use PDL to its full potential. It gets more complex as you go along, so don't be troubled if you find yourself loosing interest half way through. However, reading this document all the way through will bring you much closer to PDL enlightenment. =item * L PDL has quite a few IO modules, most of which are discussed in this summary module. =item * L A collection of some of Tuomas's ideas for making good use of PDL. =item * L Explains what bad values are and how and why they are implemented. =item * Selections from L Although writing PDL::PP code is considered an Advanced topic, and is covered in the next section, you should be aware that it is possible (and surprisingly simple) to write PDL-aware code. You needn't read the whole thing at this point, but to get some feel for how it works, you should read everything up through the first example. A copy of this documentation is contained in L. =item * L Explains how to subclass a piddle object. =item * L This was discussed in the Preface. It is an automatically generated file that lists all of the PDL modules on your computer. There are many modules that may be on your machine but which are not documented here, such as bindings to the FFTW library, or GSL. Give it a read! =back =head2 Libraries =over =item * L Complex number support. No, PDL does not have complex number support built into the core, but this should help you out. =item * L PDL's own Fast Fourier Transform. If you have FFTW, then you should probably make use of it; this is PDL's internal implementation and should always be available. =item * GSL PDL does not have bindings for every sub-library in the GNU Scientific Library, but it has quite a few. If you have GSL installed on your machine then chances are decent that your PDL has the GSL bindings. For a full list of the GSL bindings, check L. =item * L A somewhat uniform interface to the different interpolation modules in PDL. =item * L Includes some basic bad-value functionality, including functions to query if a piddle has bad values (C) and functions to set certain elements as bad (C and C). Among other places, bad values are used in L's xyplot to make a gap in a line plot. =item * L A cool module that allows you to tie a Perl array to a collection of files on your disk, which will be loaded into and out of memory as piddles. If you find yourself writing scripts to process many data files, especially if that data processing is not necessarily in sequential order, you should consider using PDL::DiskCache. =item * L A PDL subclass that allows you to store and manipulate collections of fixed-length character strings using PDL. =item * L A whole collection of methods for manipulating images whose image data are stored in a piddle. These include methods for convolutions (smoothing), polygon fills, scaling, rotation, and warping, among others. =item * L Contains a few functions that are conceptually related to image processing, but which can be defined for higher-dimensional data. For examples this module defines high-dimensional convolution and interpolation, among others. =item * L Defines some useful functions for working with RBG image data. It's not very feature-full, but it may have something you need, and if not, you can always add more! =item * L Creates the transform class, which allows you to create various coordinate transforms. For example, if you data is a collection of Cartesian coordinates, you could create a transform object to convert them to Spherical-Polar coordinates (although many such standard coordinate transformations are predefined for you, in this case it's called C). =item * L This package states that it "implements the commonly used simplex optimization algorithm." I'm going to assume that if you need this algorithm then you already know what it is. =item * L A collection of fairly standard math functions, like the inverse trigonometric functions, hyperbolic functions and their inverses, and others. This module is included in the standard call to C, but not in the Lite versions. =item * L Provides a few functions that use the standard mathematical Matrix notation of row-column indexing rather than the PDL-standard column-row. It appears that this module has not been heavily tested with other modules, so although it should work with other modules, don't be surprised if something breaks when you use it (and feel free to offer any fixes that you may develop). =item * L Provides many standard matrix operations for piddles, such as computing eigenvalues, inverting square matrices, LU-decomposition, and solving a system of linear equations. Though it is not built on L, it should generally work with that module. Also, the methods provided by this module do not depend on external libraries such as Slatec or GSL. =item * L Implements an interface to all the functions that return piddles with one less dimension (for example, C), such that they can be called by suppling their name, as a string. =back =head2 Workflow =over =item * L Enables Matlab-style autoloading. When you call an unknown function, instead of complaining and croaking, PDL will go hunt around in the directories you specify in search of a like-named file. Particularly useful when used with the Perldl Shell. =item * L Declares the C function, which can be handy for debugging your PDL scripts and/or perldl shell commands. =item * L Suppose you define a powerful, versatile function. Chances are good that you'll accept the arguments in the form of a hash or hashref. Now you face the problem of processing that hashref. L assists you in writing code to process those options. (You'd think Perl would have tons of these sorts of modules lying around, but I couldn't find any.) Note this module does not depend on PDL for its usage or installation. =item * L Ever fired-up the perldl shell just to look up the help for a particular function? You can use C instead. This shell script extracts information from the help index without needing to start the perldl shell. =back =head1 Advanced Usage The sorts of modules and documentation that you'll use if you write modules that use PDL, or if you work on PDL maintenance. These modules can be difficult to use, but enable you to tackle some of your harder problems. =over =item * L, L Lite-weight replacements for C, from the standpoint of namespace pollution and load time. =item * L This was mentioned earlier. Before you begin reading about L (next), you should remind yourself about how to use this. L will help you experiment with L without having to go through the trouble of building a module and constructing makefiles (but see L for help on that). =item * L The PDL Pre-Processor, which vastly simplifies making you C or Fortran code play with Perl and piddles. Most of PDL's basic functionality is written using PDL::PP, so if you're thinking about how you might integrate some numerical library written in C, look no further. =item * L A script that automates the creation of modules that use L, which should make your life as a module author a bit simpler. =item * L Allows you to call functions using external shared libraries. This is an alternative to using L. The major difference between PDL::PP and PDL::CallExt is that the former will handle threading over implicit thread dimensions for you, whereas PDL::CallExt simply calls an external function. PDL::PP is generally the recommended way to interface your code with PDL, but it wouldn't be Perl if there wasn't another way to do it. =item * PDL::Config Defines the C<%PDL::Config> hash, which has lots of useful information pertinent to your PDL build. =item * L Explanation of the PDL documentation conventions, and an interface to the PDL Documentation parser. Following these guidelines when writing documentation for PDL functions will ensure that your wonderful documentation is accessible from the perldl shell and from calls to C. (Did you notice that C used your documentation? Time to reread L...) =item * L A simple replacement for the standard L module. The only major difference is that the default imported modules are those marked ':Func'. =item * L Defines some useful functions for getting a piddle's type, as well as getting information about that type. =item * PDL::Version Simply defines the scalar C<$PDL::Version::Version> with the current version of PDL, as defined in PDL.pm. This is most useful if you distribute your own module on CPAN, use L or L and want to make sure that your users have a recent-enough version of PDL. Since the variable is defined in PDL.pm, you don't need this module if you C. =back =head1 Expert Usage =over =item * L Provides some decently useful functions that are pretty much only needed by the PDL Porters. =item * L Explains how to make a piddle I, from Perl or your C source code, using the PDL API. =item * L Explains the nitty-gritty of the PDL data structures. After reading this (a few times :), you should be able to create a piddle completely from scratch (i.e. without using the PDL API). Put a little differently, if you want to understand how PDL::PP works, you'll need to read this. =back =begin questionable =head1 Other Documents These documents are part of the PDL distribution but don't seem to fit anywhere above. =over =item * L Explains how things changed from PDL 1.x to PDL 2.x =item * L Supposed to be a uniform interface to plotting 2D graphics. =item * L Covers data flow, a cool feature to be sure, but from what I can tell it is not currently supported. =item * L PDL started before Perl 5.6, which introduce subs that could return lvalues. I'm pretty sure that this module has been rolled into the core and is no longer necessary. =item * L Defines a few PDL::PP tests. This code should be moved into the testing suite, but hasn't been... =item * L Defines the standard Perl-overloadable operators, like + and .=, for example. Since pretty much all of these operators and functions are discussed elsewhere, there's usually no need to read this documentation or use this module. =item * L An apparently broken module to help generate and work with Gaussian distributions. =back =end questionable =head1 COPYRIGHT Copyright 2010 David Mertens (dcmertens.perl@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.018/Basic/Pod/Dataflow.pod0000644060175006010010000001635212562522363014421 0ustar chmNone=head1 NAME PDL::Dataflow -- description of the dataflow philosophy =head1 SYNOPSIS pdl> $a = zeroes(10); pdl> $b = $a->slice("2:4:2"); pdl> $b ++; pdl> print $a; [0 0 1 0 1 0 0 0 0 0] =head1 WARNING Dataflow is very experimental. Many features of it are disabled for 2.0, particularly families for one-directional dataflow. If you wish to use one-directional dataflow for something, please contact the author first and we'll work out how to make it functional again. Two-directional dataflow (which implements ->slice() etc.) is fully functional, however. Just about any function which returns some subset of the values in some piddle will make a binding so that $a = some piddle $b = $a->slice("some parts"); $b->set(3,3,10); also changes the corresponding element in $a. $b has become effectively a window to some sub-elements of $a. You can also define your own routines that do different types of subsets. If you don't want $b to be a window to $a, you must do $b = $a->slice("some parts")->copy; The copying turns off all dataflow between the two piddles. The difficulties with one-directional dataflow are related to sequences like $b = $a + 1; $b ++; where there are several possible outcomes and the semantics get a little murky. =head1 DESCRIPTION Dataflow is new to PDL2.0. The basic philosophy behind dataflow is that > $a = pdl 2,3,4; > $b = $a * 2; > print $b [2 3 4] > $a->set(0,5); > print $b; [10 3 4] should work. It doesn't. It was considered that doing this might be too confusing for novices and occasional users of the language. Therefore, you need to explicitly turn on dataflow, so > $a = pdl 2,3,4; > $a->doflow(); > $b = $a * 2; ... produces the unexpected result. The rest of this documents explains various features and details of the dataflow implementation. =head1 Lazy evaluation When you calculate something like the above > $a = pdl 2,3,4; > $a->doflow(); > $b = $a * 2; nothing will have been calculated at this point. Even the memory for the contents of $b has not been allocated. Only the command > print $b will actually cause $b to be calculated. This is important to bear in mind when doing performance measurements and benchmarks as well as when tracking errors. There is an explanation for this behaviour: it may save cycles but more importantly, imagine the following: > $a = pdl 2,3,4; > $b = pdl 5,6,7; > $c = $a + $b; ... > $a->resize(4); > $b->resize(4); > print $c; Now, if $c were evaluated between the two resizes, an error condition of incompatible sizes would occur. What happens in the current version is that resizing $a raises a flag in $c: "PDL_PARENTDIMSCHANGED" and $b just raises the same flag again. When $c is next evaluated, the flags are checked and it is found that a recalculation is needed. Of course, lazy evaluation can sometimes make debugging more painful because errors may occur somewhere where you'd not expect them. A better stack trace for errors is in the works for PDL, probably so that you can toggle a switch $PDL::traceevals and get a good trace of where the error actually was. =head1 Families This is one of the more intricate concepts of one-directional dataflow. Consider the following code ($a and $b are pdls that have dataflow enabled): $c = $a + $b; $e = $c + 1; $d = $c->diagonal(); $d ++; $f = $c + 1; What should $e and $f contain now? What about when $a is changed and a recalculation is triggered. In order to make dataflow work like you'd expect, a rather strange concept must be introduced: families. Let us make a diagram: a b \ / c /| / | e d This is what PDL actually has in memory after the first three lines. When $d is changed, we want $c to change but we don't want $e to change because it already is on the graph. It may not be clear now why you don't want it to change but if there were 40 lines of code between the 2nd and 4th lines, you would. So we need to make a copy of $c and $d: a b \ / c' . . . c /| |\ / | | \ e d' . . . d f Notice that we primed the original c and d, because they do not correspond to the objects in $c and $d any more. Also, notice the dotted lines between the two objects: when $a is changed and this diagram is re-evaluated, $c really does get the value of c' with the diagonal incremented. To generalize on the above, whenever a piddle is mutated i.e. when its actual *value* is forcibly changed (not just the reference: $d = $d + 1 would produce a completely different result ($c and $d would not be bound any more whereas $d .= $d + 1 would yield the same as $d++), a "family" consisting of all other piddles joined to the mutated piddle by a two-way transformation is created and all those are copied. All slices or transformations that simply select a subset of the original pdl are two-way. Matrix inverse should be. No arithmetic operators are. =head1 Sources What you were told in the previous section is not quite true: the behaviour described is not *always* what you want. Sometimes you would probably like to have a data "source": $a = pdl 2,3,4; $b = pdl 5,6,7; $c = $a + $b; line($c); Now, if you know that $a is going to change and that you want its children to change with it, you can declare it into a data source (XXX unimplemented in current version): $a->datasource(1); After this, $a++ or $a .= something will not create a new family but will alter $a and cut its relation with its previous parents. All its children will follow its current value. So if $c in the previous section had been declared as a source, $e and $f would remain equal. =head1 Binding A dataflow mechanism would not be very useful without the ability to bind events onto changed data. Therefore, we provide such a mechanism: > $a = pdl 2,3,4 > $b = $a + 1; > $c = $b * 2; > $c->bind( sub { print "A now: $a, C now: $c\n" } ) > PDL::dowhenidle(); A now: [2,3,4], C now: [6 8 10] > $a->set(0,1); > $a->set(1,1); > PDL::dowhenidle(); A now: [1,1,4], C now: [4 4 10] Notice how the callbacks only get called during PDL::dowhenidle. An easy way to interface this to Perl event loop mechanisms (such as Tk) is being planned. There are many kinds of uses for this feature: self-updating graphs, for instance. Blah blah blah XXX more explanation =head1 Limitations Dataflow as such is a fairly limited addition on top of Perl. To get a more refined addition, the internals of Perl need to be hacked a little. A true implementation would enable flow of everything, including =over 12 =item data =item data size =item datatype =item operations =back At the moment we only have the first two (hey, 50% in a couple of months is not bad ;) but even this is useful by itself. However, especially the last one is desirable since it would add the possibility of flowing closures from place to place and would make many things more flexible. To get the rest working, the internals of dataflow probably need to be changed to be a more general framework. Additionally, it would be nice to be able to flow data in time, lucid-like (so you could easily define all kinds of signal processing things). =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu). Redistribution in the same form is allowed provided that the copyright notice stays intact but reprinting requires a permission from the author. PDL-2.018/Basic/Pod/Delta.pod0000644060175006010010000000233512562522363013705 0ustar chmNone=head1 NAME PDL::Delta - PDL changes between V1.0 and V2.0 =head1 DESCRIPTION This file is an attempt to list the major user-visible changes between PDL versions 1.0 and 2.0. =head1 Core Changes =head2 Piddles are not hashes any more: $a = zeroes 10,10; $$a{FOO} = "bar" doesn't work. They are currently scalar references (to opaque C structures in finer terms) because of speed as well as syntactic issues. If you want to have a hash, use $a->hdr() which returns a reference to an anonymous hash. Also, subclassing works if you store a piddle in the hash member ``PDL''. There are also many core enhancements to support Dataflow and Slicing tricks, but these do not introduce any incompatibilities. =head2 Incompatible Changes vs 1.11 =over 4 =item rgrep Order of the arguments has changed. =item copy method No longer copies the header. This may not be a misfeature. =back =head1 Documentation Changes Many of the base and library pods were updated. =head1 SEE ALSO The F file for exhaustive details on what changed. The F file for how to build PDL. The F file for general stuff. =head1 HISTORY pdldelta was inspired by I man page in the Perl 5.004 distribution. PDL-2.018/Basic/Pod/FAQ.pod0000644060175006010010000015042313110401743013251 0ustar chmNone =head1 NAME PDL::FAQ - Frequently asked questions about PDL =head1 VERSION Current FAQ version: 1.008 =head1 DESCRIPTION This is version 1.008 of the PDL FAQ, a collection of frequently asked questions about PDL - the Perl Data Language. =head1 ABOUT THIS DOCUMENT =head2 Q: 1.1 Where to find this document You can find the latest version of this document at L . =head2 Q: 1.2 How to contribute to this document This is a considerably reworked version of the PDL FAQ. As such many errors might have crept in and many updates might not have made it in. You are explicitly encouraged to let us know about questions which you think should be answered in this document but currently aren't. Similarly, if you think parts of this document are unclear, please tell the FAQ maintainer about it. Where a specific answer is taken in full from someones posting the authorship should be indicated, let the FAQ maintainer know if it isn't. For more general information explicit acknowledgment is not made in the text, but rather there is an incomplete list of contributors at the end of this document. Please contact the FAQ maintainer if you feel hard done by. Send your comments, additions, suggestions or corrections to the PDL mailing list at pdl-general@lists.sourceforge.net. See Q: 3.2 below for instructions on how to join the mailing lists. =head1 GENERAL QUESTIONS =head2 Q: 2.1 What is PDL ? PDL stands for I . To say it with the words of Karl Glazebrook, initiator of the PDL project: The PDL concept is to give standard perl5 the ability to COMPACTLY store and SPEEDILY manipulate the large N-dimensional data sets which are the bread and butter of scientific computing. e.g. $a=$b+$c can add two 2048x2048 images in only a fraction of a second. It provides tons of useful functionality for scientific and numeric analysis. For readers familiar with other scientific data evaluation packages it may be helpful to add that PDL is in many respects similar to IDL, MATLAB and similar packages. However, it tries to improve on a number of issues which were perceived (by the authors of PDL) as shortcomings of those existing packages. =head2 Q: 2.2 Who supports PDL? Who develops it? PDL is supported by its users. General informal support for PDL is provided through the PDL mailing list (pdl-general@lists.sourceforge.net , see below). As a Perl extension (see Q: 2.5 below) it is devoted to the idea of free and open development put forth by the Perl community. PDL was and is being actively developed by a loosely knit group of people around the world who coordinate their activities through the PDL development mailing list (pdl-devel@lists.sourceforge.net , see Q: 3.2 below). If you would like to join in the ongoing efforts to improve PDL please join this list. =head2 Q: 2.3 Why yet another Data Language ? There are actually several reasons and everyone should decide for himself which are the most important ones: =over 4 =item * PDL is "free software". The authors of PDL think that this concept has several advantages: everyone has access to the sources -> better debugging, easily adaptable to your own needs, extensible for your purposes, etc... In comparison with commercial packages such as MATLAB and IDL this is of considerable importance for workers who want to do some work at home and cannot afford the considerable cost to buy commercial packages for personal use. =item * PDL is based on a powerful and well designed scripting language: Perl. In contrast to other scientific/numeric data analysis languages it has been designed using the features of a proven language instead of having grown into existence from scratch. Defining the control structures while features were added during development leads to languages that often appear clumsy and badly planned for most existing packages with similar scope as PDL. =item * Using Perl as the basis a PDL programmer has all the powerful features of Perl at his hand, right from the start. This includes regular expressions, associative arrays (hashes), well designed interfaces to the operating system, network, etc. Experience has shown that even in mainly numerically oriented programming it is often extremely handy if you have easy access to powerful semi-numerical or completely non-numerical functionality as well. For example, you might want to offer the results of a complicated computation as a server process to other processes on the network, perhaps directly accepting input from other processes on the network. Using Perl and existing Perl extension packages things like this are no problem at all (and it all will fit into your "PDL script"). =item * Extremely easy extensibility and interoperability as PDL is a Perl extension; development support for Perl extensions is an integral part of Perl and there are already numerous extensions to standard Perl freely available on the network. =item * Integral language features of Perl (regular expressions, hashes, object modules) immensely facilitated development and implementation of key concepts of PDL. One of the most striking examples for this point is probably L (see Q: 6.16 below), a code generator/parser/pre-processor that generates PDL functions from concise descriptions. =item * None of the existing data languages follow the Perl language rules, which the authors firmly believe in: =over 4 =item * TIMTOWTDI: There is more than one way to do it. Minimalist languages are interesting for computer scientists, but for users, a little bit of redundancy makes things wildly easier to cope with and allows individual programming styles - just as people speak in different ways. For many people this will undoubtedly be a reason to avoid PDL ;) =item * Simple things are simple, complicated things possible: Things that are often done should be easy to do in the language, whereas seldom done things shouldn't be too cumbersome. =back All existing languages violate at least one of these rules. =item * As a project for the future PDL should be able to use super computer features, e.g. vector capabilities/parallel processing, GPGPU acceleration. This will probably be achieved by having L (see Q: 6.16 below) generate appropriate code on such architectures to exploit these features. =item * [ fill in your personal 111 favourite reasons here...] =back =head2 Q: 2.4 What is PDL good for ? Just in case you do not yet know what the main features of PDL are and what one could do with them, here is a (necessarily selective) list of key features: PDL is well suited for matrix computations, general handling of multidimensional data, image processing, general scientific computation, numerical applications. It supports I/O for many popular image and data formats, 1D (line plots), 2D (images) and 3D (volume visualization, surface plots via OpenGL - for instance implemented using Mesa or video card OpenGL drivers), graphics display capabilities and implements many numerical and semi-numerical algorithms. Through the powerful pre-processor it is also easy to interface Perl to your favorite C routines, more of that further below. =head2 Q: 2.5 What is the connection between PDL and Perl ? PDL is a Perl5 extension package. As such it needs an existing Perl5 installation (see below) to run. Furthermore, much of PDL is written in Perl (+ some core functionality that is written in C). PDL programs are (syntactically) just Perl scripts that happen to use some of the functionality implemented by the package "PDL". =head2 Q: 2.6 What do I need to run PDL on my machine ? Since PDL is just a Perl5 package you need first of all an installation of Perl5 on your machine. As of this writing PDL requires version 5.10.x of perl, or higher. More information on where and how to get a Perl installation can be found at the Perl home page L and at many CPAN sites (if you do not know what I is, check the answer to the next question). To build PDL you also need a working C compiler, support for Xsubs, and the package Extutils::MakeMaker. If you don't have a compiler there might be a binary distribution available, see "Binary distributions" below. If you can (or cannot) get PDL working on a new (previously unsupported) platform we would like to hear about it. Please, report your success/failure to the PDL mailing list at pdl-general@lists.sourceforge.net . We will do our best to assist you in porting PDL to a new system. =head2 Q: 2.7 Where do I get it? PDL is available as source distribution in the I (or CPAN) and from the sourceforge.net project page at L. The CPAN archives contains not only the PDL distribution but also just about everything else that is Perl-related. CPAN is mirrored by dozens of sites all over the world. The main site is L, and local CPAN sites (mirrors) can be found there. Within CPAN you find the latest released version of PDL in the directory /modules/by-module/PDL/. PDL's homepage is at L and the latest version can also be downloaded from there. =head2 Q: 2.8 What do I have to pay to get PDL? We are delighted to be able to give you the nicest possible answer on a question like this: PDL is *free software* and all sources are publicly available. But still, there are some copyrights to comply with. So please, try to be as nice as we (the PDL authors) are and try to comply with them. Oh, before you think it is *completely* free: you have to invest some time to pull the distribution from the net, compile and install it and (maybe) read the manuals. =head1 GETTING HELP/MORE INFORMATION =head2 Q: 3.1 Where can I get information on PDL? The complete PDL documentation is available with the PDL distribution. Use the command C to start learning about PDL. The easiest way by far, however, to get familiar with PDL is to use the PDL on-line help facility from within the PDL shell, C Just type C at your system prompt. Once you are inside the C shell type C . Using the C and C commands inside the shell you should be able to find the way round the documentation. Even better, you can immediately try your newly acquired knowledge about PDL by issuing PDL/Perl commands directly at the command line. To illustrate this process, here is the record of a typical C session of a PDL beginner (lengthy output is only symbolically reproduced in braces ( <... ...> ) ): unix> pdl2 pdl> help < ... help output ... > pdl> help PDL::QuickStart < ... perldoc page ... > pdl> $a = pdl (1,5,7.3,1.0) pdl> $b = sequence float, 4, 4 pdl> help inner < ... help on the 'inner' function ... > pdl> $c = inner $a, $b pdl> p $c [22.6 79.8 137 194.2] For further sources of information that are accessible through the Internet see next question. =head2 Q: 3.2 Are there other PDL information sources on the Internet? First of all, for all purely Perl-related questions there are tons of sources on the net. Good points to start are L and L . The PDL home site can be accessed by pointing your web browser to L . It has tons of goodies for anyone interested in PDL: =over 4 =item * PDL distributions =item * On-line documentation =item * Pointers to an HTML archive of the PDL mailing lists =item * A list of platforms on which PDL has been successfully tested. =item * News about recently added features, ported libraries, etc. =item * Name of the current pumpkin holders for the different PDL modules (if you want to know what that means you better had a look at the web pages). =back If you are interested in PDL in general you can join the PDL mailing list pdl-general@lists.sourceforge.net. This is a forum to discuss programming issues in PDL, report bugs, seek assistance with PDL related problems, etc. To subscribe, fill out the form at L . A searchable archive and a hypertext version of the traffic on this list (1997-2004) can be found at L . More recent messages (since June 2005) can be found at TBD. If you are interested in all the technical details of the ongoing PDL development you can join the PDL developers mailing list pdl-devel@lists.sourceforge.net . To subscribe, fill out the form at L . A searchable archive and a hypertext version of the traffic on this list (1997-2004) can be found at L . More recent messages (since June 2005) can be found at TBD Cross-posting between these lists should be avoided unless there is a I good reason for doing that. =head2 Q: 3.3 What is the current version of PDL ? As of this writing (FAQ version 1.008 of 21 May 2017) the latest stable version is 2.018. The latest stable version should always be available from a CPAN mirror site near you (see L for info on where to get PDL). The most current (possibly unstable) version of PDL can be obtained from the Git repository, see L and periodic CPAN developers releases of the Git code will be made for testing purposes and more general availability. =head2 Q: 3.4 How can PDL-2.2 be older than PDL-2.007? Over its development, PDL has used both a single floating point version number (from the versions 1.x through 2.005) at which point it switched to a dotted triple version for 2.1.1 onward---EXCEPT for version 2.2 which came out which should have been 2.2.0. To simplify and unify things, PDL has reverted to a single float version representation with PDL-2.006. This can cause dependency problems for modules that set a minimum PDL version of 2.2. The work around it, note that all extant PDL releases have version numbers greater than 2.2.1 so that using 0 as the minimum version will work. =head2 Q: 3.5 I want to contribute to the further development of PDL. How can I help? Two ways that you could help almost immediately are (1) participate in CPAN Testers for PDL and related modules, and (2) proofreading and clarifying the PDL documentation so that it is most useable for PDL users, especially new users. To participate in CPAN Testers and contribute test reports, the page L has instructions for starting for either C or C users. If you have a certain project in mind you should check if somebody else is already working on it or if you could benefit from existing modules. Do so by posting your planned project to the PDL developers mailing list at pdl-devel@lists.sourceforge.net . See the subscription instructions in L. We are always looking for people to write code and/or documentation ;). =head2 Q: 3.6 I think I have found a bug in the current version of PDL. What shall I do? First, make sure that the bug/problem you came across has not already been dealt with somewhere else in this FAQ. Secondly, you can check the searchable archive of the PDL mailing lists to find whether this bug has already been discussed. If you still haven't found any explanations you can post a bug report to pdl-general@lists.sourceforge.net , or through the Bugs link on L . See the F file in the PDL distribution for what information to include. If you are unsure, discussions via the perldl mailing list can be most helpful. =head1 INSTALLATION =head2 Q: 4.1 I have problems installing PDL. What shall I do? First make sure you have read the file F in the distribution. This contains a list of common problems which are unnecessary to repeat here. Next, check the file F to see if by editing the configuration options in that file you will be able to successfully build PDL. Some of the modules need additional software installed, please refer to the file F for further details. Make sure to edit the location of these packages in perldl.conf if you have them in non-standard locations. N.B. Unix shell specific: If you would like to save an edited perldl.conf for future builds just copy it as F<~/.perldl.conf> into your home directory where it will be picked up automatically during the PDL build process. Also, check for another, pre-existing version of PDL on the build system. Multiple PDL installs in the same PATH or @INC can cause puzzling test or build failures. If you still can't make it work properly please submit a bug report including detailed information on the problems you encountered to the perldl mailing list ( pdl-general@lists.sourceforge.net , see also above). Response is often rapid. =head2 Q: 4.2 Are there configuration files for PDL I have to edit? Most users should not have to edit any configuration files manually. However, in some cases you might have to supply some information about awkwardly placed include files/libraries or you might want to explicitly disable building some of the optional PDL modules. Check the files F and F for details. If you had to manually edit F and are happy with the results you can keep the file handy for future reference. Place it in F<~/.perldl.conf> where it will be picked up automatically or use C next time you build PDL. =head2 Q: 4.3 Do I need other software for successful operation? For the basic PDL functionality you don't need any additional software. However, some of the optional PDL modules included in the distribution (notably most graphics and some I/O modules) require certain other libraries/programs to be installed. Check the file F in the distribution for details and directions on how to get these. =head2 Q: 4.4 How can I install PDL in a non-standard location? To install PDL in a non-standard location, use the INSTALL_BASE option in the C configure step. For example, C will configure PDL to install into the tree rooted at C. For more details see L and subsequent sections. Another alternative is to use L to do the heavy listing for the needed configuration. =head2 Q: 4.5 How can I force a completely clean installation? To guarantee a completely clean installation of PDL, you will need to first delete the current installation files and folders. These will be all directories named C in the Perl C<@INC> path, files named C<*Pdlpp*> in any C directories, and the programs C. Then just build and install as usual. This is much easier to keep track of if you always install C into a non-standard location. See Q: 4.4 above. =head1 BINARY DISTRIBUTIONS =head2 Q: 4.5 What binary distributions are available? Information about binary distributions of PDL can be found on L . At present there are binary distributions of PDL for Linux (RedHat and Debian), FreeBSD, Mac OS X and Windows, though they might not be the most recent version. If someone is interested in providing binary distributions for other architectures, that would be very welcome. Let us know on the pdl-devel@lists.sourceforge.net mailing list. Also check your Linux distribution's package manager as many now include PDL. PPMs for win32 versions (both 32bit and 64bit) are also available. =head2 Q: 4.6 Does PDL run on Linux? (And what about packages?) Yes, PDL does run on Linux and indeed much of the development has been done under Linux. On L you can find links to packages for some of the major distributions. Also check your distribution's package manager (yum, apt, urpmi, ...) as PDL is now found by many of these. =head2 Q: 4.7 Does PDL run under Windows? PDL builds fine on Win32 using MinGW or Microsoft compilers. See the F file in the PDL source distribution for details. Other compilers have not been tested--input is welcome. There is also a distribution of PDL through ActiveState's ppm, though it might not always be the latest version. PDL-2.018 builds out of the box on Strawberry Perl and ActiveState Perl and there are distributions of Strawberry Perl with bundled PDL (see L). =head1 CVS, GIT, AND ON-GOING DEVELOPMENT =head2 Q: 4.8 Can I get PDL via CVS? No. PDL development was conducted with a CVS repository from December 1999 to April 2009. In April 2009 the project switched to the Git version control system (see L). =head2 Q: 4.9 How do I get PDL via Git? Assume you have Git installed on your system and want to download the project source code into the directory C. To get read-only access to the repository, you type at the command line git clone git://git.code.sf.net/p/pdl/code pdl-code For official PDL developers, to get read/write access to the repository type at the command line git clone ssh://USERNAME@git.code.sf.net/p/pdl/code pdl-code =head2 Q: 4.10 I had a problem with the Git version, how do I check if someone has submitted a patch? The Sourceforge system contains a patch-manager which contains patches that have not yet been applied to the distribution. This can be accessed via the Tickets menu at PDL's Sourceforge project page L . In addition, if you are not subscribing to the mailing list, check the archive of the C and C mailing lists. See L for details. =head2 Q: 4.11 I have gotten developer access to Git, how do I upload my changes? The first thing you should do is to read the Git documentation and learn the basics about Git. There are many sources available online. But here are the basics: Before you upload your changes, commit them to YOUR repository git add ... git commit or combine these two with git commit -a Then pull in any changes others have made git pull origin Test the PDL before you push it to the main repository. If the code is broken for you, then it is most likely broken for others and they won't be happy to have their recent PDL fail to build! NOTE: git makes it very easy to maintain a separate branch of development. [ TBD, provide information on how ]. Then update the shared repository (at SF.net) with your changes git push origin master =head1 PDL JARGON =head2 Q: 5.1 What is threading (is PDL a newsreader) ? Unfortunately, in the context of PDL the term threading can have two different (but related) meanings: =over 4 =item * When mentioned in the F directions and possibly during the build process we have the usual computer science meaning of multi-threading in mind (useful mainly on multiprocessor machines or clusters) =item * PDL threading of operations on piddles (as mentioned in the indexing docs) is the iteration of a basic operation over appropriate sub-slices of piddles, e.g. the inner product C of a (3) pdl C<$a> and a (3,5,4) pdl C<$b> results in a (5,4) piddle where each value is the result of an inner product of the (3) pdl with a (3) sub-slice of the (3,5,4) piddle. For details check L =back PDL threading leads naturally to potentially parallel code which can make use of multi threading on multiprocessor machines/networks; there you have the connection between the two types of use of the term. =head2 Q: 5.2 What is a piddle? Well, PDL scalar variables (which are instances of a particular class of Perl objects, i.e. blessed thingies (see C )) are in common PDL parlance often called I (for example, check the mailing list archives). Err, clear? If not, simply use the term I when you refer to a PDL variable (an instance of a PDL object as you might remember) regardless of what actual data the PDL variable contains. =head1 TECHNICAL QUESTIONS =head2 Q: 6.1 What is perldl? What is pdl2? Sometimes C (C) is used as a synonym for PDL. Strictly speaking, however, the name C (C) is reserved for the little shell that comes with the PDL distribution and is supposed to be used for the interactive prototyping of PDL scripts. For details check L or L. =head2 Q: 6.2 How do I get on-line help for PDL? Just type C (shortcut = "?") at the C shell prompt and proceed from there. Another useful command is the C (shortcut = "??") command. Also try the C command in the C or C shell if you are new to PDL. =head1 MANIPULATION OF PIDDLES =head2 Q: 6.3 I want to access the third element of a pdl but $a[2] doesn't work ?! See answer to the next question why the normal Perl array syntax doesn't work for piddles. =head2 Q: 6.4 The docs say piddles are some kind of array. But why doesn't the Perl array syntax work with piddles then ? OK, you are right in a way. The docs say that piddles can be thought of arrays. More specifically, it says ( L ): I find when using the Perl Data Language it is most useful to think of standard Perl @x variables as "lists" of generic "things" and PDL variables like $x as "arrays" which can be contained in lists or hashes. So, while piddles can be thought of as some kind of multi-dimensional array they are B< not> arrays in the Perl sense. Rather, from the point of view of Perl they are some special class (which is currently implemented as an opaque pointer to some stuff in memory) and therefore need special functions (or 'methods' if you are using the OO version) to access individual elements or a range of elements. The functions/methods to check are C / C (see L ) or the powerful C function and friends (see L and L and especially L ). Finally, to confuse you completely, you can have Perl arrays of piddles, e.g. C<$spec[3]> can refer to a pdl representing ,e.g, a spectrum, where C<$spec[3]> is the fourth element of the Perl list (or array ;) C<@spec> . This may be confusing but is very useful ! =head2 Q: 6.5 How do I concatenate piddles? Most people will try to form new piddles from old piddles using some variation over the theme: C<$a = pdl([$b, 0, 2])> , but this does not work. The way to concatenate piddles is to use the function C (see also C and C). Similarly you can split piddles using the command C . =head2 Q: 6.6 Sometimes I am getting these strange results when using inplace operations? This question is related to the C function. From the documentation (see L): Most functions, e.g. log(), return a result which is a transformation of their argument. This makes for good programming practice. However many operations can be done "in-place" and this may be required when large arrays are in use and memory is at a premium. For these circumstances the operator inplace() is provided which prevents the extra copy and allows the argument to be modified. e.g.: $x = log($array); # $array unaffected log( inplace($bigarray) ); # $bigarray changed in situ And also from the doc !!: Obviously when used with some functions which can not be applied in situ (e.g. convolve()) unexpected effects may occur! =for comment Check the list of PDL functions at the end of PDL.pod which points out C-safe functions. No longer in PDL.pod, need to fix!! =head2 Q: 6.7 What is this strange usage of the string concatenation operator C<.=> in PDL scripts? See next question on assignment in PDL. =head2 Q: 6.8 Why are there two different kinds of assignment in PDL ? This is caused by the fact that currently the assignment operator C<=> allows only restricted overloading. For some purposes of PDL it turned out to be necessary to have more control over the overloading of an assignment operator. Therefore, PDL peruses the operator C<.=> for certain types of assignments. =head2 Q: 6.9 How do I set a set of values in a piddle? In Perl 5.6.7 and higher this assignment can be made using lvalue subroutines: pdl> $a = sequence(5); p $a [0 1 2 3 4] pdl> $a->slice('1:2') .= pdl([5,6]) pdl> p $a [0 5 6 3 4] see L for more info. PDL also supports a more matrix-like slice syntax via the L module: pdl> $a(1:2) .= pdl([5,6]) pdl> p $a [0 5 6 3 4] With versions of Perl prior to 5.6.7 B this has to be done using a temporary variable: pdl> $a = sequence(5); p $a [0 1 2 3 4] pdl> $tmp = $a->slice('1:2'); p $tmp; [1 2] pdl> $tmp .= pdl([5, 6]); # Note .= !! pdl> p $a [0 5 6 3 4] This can also be made into one expression, which is often seen in PDL code: pdl> ($tmp = $a->slice('1:2')) .= pdl([5,6]) pdl> p $a [0 5 6 3 4] =head2 Q: 6.10 Can I use a piddle in a conditional expression? Yes you can, but not in the way you probably tried first. It is not possible to use a piddle directly in a conditional expression since this is usually poorly defined. Instead PDL has two very useful functions: C and C . Use these to test if any or all elements in a piddle fulfills some criterion: pdl> $a=pdl ( 1, -2, 3); pdl> print '$a has at least one element < 0' if (any $a < 0); $a has at least one element < 0 pdl> print '$a is not positive definite' unless (all $a > 0); $a is not positive definite =head2 Q: 6.11 Logical operators and piddles - '||' and '&&' don't work! It is a common problem that you try to make a mask array or something similar using a construct such as $mask = which($piddle > 1 && $piddle < 2); # incorrect This B< does not> work! What you are looking for is the B< bitwise> logical operators '|' and '&' which work on an element-by-element basis. So it is really very simple: Do not use logical operators on multi-element piddles since that really doesn't make sense, instead write the example as: $mask = which($piddle > 1 & $piddle < 2); which works correctly. =head1 ADVANCED TOPICS =head2 Q: 6.12 What is a null pdl ? =for comment Is Q: 6.12 up-to-date with null and empty pdls? C is a special token for 'empty piddle'. A null pdl can be used to flag to a PDL function that it should create an appropriately sized and typed piddle. I piddles can be used in places where a PDL function expects an I or I argument. I and I arguments are flagged in the I of a PDL function with the C<[o]> and C<[t]> qualifiers (see next question if you don't know what the I of a PDL function is). For example, you can invoke the C function as follows: sumover $a, $b=null; which is equivalent to $b = sumover $a; If this seems still a bit murky check L and L for details about calling conventions, the I and I (see also below). =head2 Q: 6.13 What is the signature of a PDL function ? The I of a function is an important concept in PDL. Many (but not all) PDL function have a I which specifies the arguments and their (minimal) dimensionality. As an example, look at the signature of the C function: 'a(n); [o] b;' this says that C takes two arguments, the first of which is (at least) one-dimensional while the second one is zero-dimensional and an I argument (flagged by the C<[o]> qualifier). If the function is called with piddles of higher dimension the function will be repeatedly called with slices of these piddles of appropriate dimension(this is called I in PDL). For details and further explanations consult L and L . =head2 Q: 6.14 How can I subclass (inherit from) piddles? The short answer is: read L (e.g. type C in the I or I shell). The longer answer (extracted from L ): Since a PDL object is an opaque reference to a C struct, it is not possible to extend the PDL class by e.g. extra data via sub-classing (as you could do with a hash based Perl object). To circumvent this problem PDL has built-in support to extend the PDL class via the I relation for blessed hashes. You can get the I to behave like I simply in that you assign the PDL object to the attribute named C and redefine the method initialize(). For example: package FOO; @FOO::ISA = qw(PDL); sub initialize { my $class = shift; my $self = { creation_time => time(), # necessary extension :-) PDL => PDL->null, # used to store PDL object }; bless $self, $class; } For another example check the script F in the PDL distribution. =head2 Q: 6.15 What on earth is this dataflow stuff ? Dataflow is an experimental project that you don't need to concern yourself with (it should not interfere with your usual programming). However, if you want to know, have a look at L . There are applications which will benefit from this feature (and it is already at work behind the scenes). =head2 Q: 6.16 What is PDL::PP? Simple answer: PDL::PP is both a glue between external libraries and PDL and a concise language for writing PDL functions. Slightly longer answer: PDL::PP is used to compile very concise definitions into XSUB routines implemented in C that can easily be called from PDL and which automatically support threading, dataflow and other things without you having to worry about it. For further details check L and the section below on L. =head2 Q: 6.17 What happens when I have several references to the same PDL object in different variables (cloning, etc?) ? Piddles behave like Perl references in many respects. So when you say $a = pdl [0,1,2,3]; $b = $a; then both $b and $a point to the same object, e.g. then saying $b++; will *not* create a copy of the original piddle but just increment in place, of which you can convince yourself by saying print $a; [1 2 3 4] This should not be mistaken for dataflow which connects several *different* objects so that data changes are propagated between the so linked piddles (though, under certain circumstances, dataflown piddles can share physically the same data). It is important to keep the "reference nature" of piddles in mind when passing piddles into subroutines. If you modify the input piddles you modify the original argument, I a copy of it. This is different from some other array processing languages but makes for very efficient passing of piddles between subroutines. If you do not want to modify the original argument but rather a copy of it just create a copy explicitly (this example also demonstrates how to properly check for an I request to process inplace, assuming your routine can work inplace): sub myfunc { my $pdl = shift; if ($pdl->is_inplace) { $pdl->set_inplace(0) } else { # modify a copy by default $pdl = $pdl->copy } $pdl->set(0,0); return $pdl; } =head1 MISCELLANEOUS =head2 Q: 6.18 What I/O formats are supported by PDL ? The current versions of PDL already support quite a number of different I/O formats. However, it is not always obvious which module implements which formats. To help you find the right module for the format you require, here is a short list of the current list of I/O formats and a hint in which module to find the implementation: =over 4 =item * A home brew fast raw (binary) I/O format for PDL is implemented by the L module =item * The L module implements generic methods for the input and output of `raw' data arrays. In particular, it is designed to read output from FORTRAN 77 UNFORMATTED files and the low-level C C function, even if the files are compressed or gzipped. It is possible that the FastRaw functionality will be included in the FlexRaw module at some time in the future. =item * FITS I/O is implemented by the C/C functions in L . =item * ASCII file I/O in various formats can be achieved by using the C and C functions, also in L . =item * L implements an interface to the NetPBM/PBM+ filters to read/write several popular image formats; also supported is output of image sequences as MPEG movies, animated GIFs and a wide variety of other video formats. =item * On CPAN you can find the L module that works with PDL 2.007. =back For further details consult the more detailed list in the L documentation or the documentation for the individual modules. =head2 Q: 6.19 How can I stack a set of 2D arrays (images) into a 3D piddle? Assuming all arrays are of the same size and in some format recognized by C (see L ) you could say: use PDL::IO::Pic; @names = qw/name1.tif .... nameN.tif/; # some file names $dummy = PDL->rpic($names[0]); $cube = PDL->zeroes($dummy->type,$dummy->dims,$#names+1); # make 3D piddle for (0..$#names) { # this is the slice assignment ($tmp = $cube->slice(":,:,($_)")) .= PDL->rpic($names[$_]); } or $cube(:,:,($_)) .= PDL->rpic($names[$_]); for the slice assignment using the new L syntax and Lvalue assignments. The for loop reads the actual images into a temporary 2D piddle whose values are then assigned (using the overloaded C<.=> operator) to the appropriate slices of the 3D piddle C<$cube> . =head2 Q: 6.20 Where are test files for the graphics modules? This answer applies mainly to PDL::Graphics::TriD (PDL's device independent 3D graphics model) which is the trickiest one in this respect. You find some test scripts in Demos/TriD in the distribution. There are also F<3dtest.pl> and F in the PDL/Example/TriD directory. After you have built PDL you can do: perl -Mblib Example/TriD/3dtest.pl perl -Mblib Example/TriD/line3d.pl to try the two TriD test programs. They only exercise one TriD function each but their simplicity makes it easy to debug if needed with the Perl debugger, see L. The programs in the Demo directory can be run most easily from the C or C interactive shell: perl -Mblib perldl or perl -Mblib Perldl2/pdl2 followed by C or C at the prompt. C by itself will give you a list of the available PDL demos. You can run the test scripts in the Demos/TriD directory manually by changing to that directory and running perl -Mblib where C<< testfile >> ; should match the pattern C and watch the results. Some of the tests should bring up a window where you can control (twiddle) the 3D objects with the mouse. Try using mouse button 1 for turning the objects in 3D space, mouse button 3 to zoom in and out, and 'q' to advance to the next stage of the test. =head2 Q: 6.21 What is TriD or PDL::TriD or PDL::Graphics::TriD? Questions like this should be a thing of the past with the PDL on-line help system in place. Just try (after installation): un*x> pdl2 pdl> apropos trid Check the output for promising hits and then try to look up some of them, e.g. pdl> help PDL::Graphics::TriD Note that case matters with C but not with C . =head2 Q: 6.22 PGPLOT does not write out PNG files. There are a few sources of trouble with PGPLOT and PNG files. First, when compiling the pgplot libraries, make sure you uncomment the PNG entries in the F file. Then when running 'make' you probably got an error like C To fix this, find the line in the 'makefile' that starts with 'pndriv.o:' (it's near the bottom). Change, for example, ./png.h to /usr/include/png.h, if that is where your header files are (you do have the libpng and libz devel packages, don't you?). Do this for all four entries on that line, then go back and run C. Second, if you already have the PGPLOT Perl module and PDL installed, you probably tried to write out a PNG file and got fatal error message like: C This is because the PGPLOT Perl module does not automatically link against the png and z libraries. So when you are installing the PGPLOT Perl module (version 2.19) from CPAN, don't do C, but just do C. Then exit from CPAN and manually install PGPLOT, calling the makefile thusly: C assuming that there exist files such as /usr/lib/libpng.so.*, /usr/lib/libz.so.*. Then do the standard C sequence. Now you can write png files from PDL! =head1 EXTENSIONS OF PDL =head2 Q: 7.1 I am looking for a package to do XXX in PDL. Where shall I look for it? The first stop is again C or C and the on-line help or the PDL documentation. There is already a lot of functionality in PDL which you might not be aware of. The easiest way to look for functionality is to use the C command: pdl> apropos 'integral' ceil Round to integral values in floating-point format floor Round to integral values in floating-point format intover Project via integral to N-1 dimensions rint Round to integral values in floating-point format Since the apropos command is no sophisticated search engine make sure that you search on a couple of related topics and use short phrases. However there is a good chance that what you need is not part of the PDL distribution. You are then well advised to check out L where there is a list of packages using PDL. If that does not solve your problem, ask on the mailing-list, if nothing else you might get assistance which will let you interface your package with PDL yourself, see also the next question. =head2 Q: 7.2 Can I access my C/FORTRAN library routines in PDL? Yes, you can, in fact it is very simple for many simple applications. What you want is the PDL pre-processor PP (L ). This will allow you to make a simple interface to your C routine. The two functions you need to learn (at least first) are C which defines the calling interface to the function, specifying input and output parameters, and contains the code that links to the external library. The other command is C which finishes the PP definitions. For details see the L man-page, but we also have a worked example here. double eight_sum(int n) { int i; double sum, x; sum = 0.0; x=0.0; for (i=1; i<=n; i++) { x++; sum += x/((4.0*x*x-1.0)*(4.0*x*x-1.0)); } return 1.0/sum; } We will here show you an example of how you interface C code with PDL. This is the first example and will show you how to approximate the number 8... The C code is shown above and is a simple function returning a double, and expecting an integer - the number of terms in the sum - as input. This function could be defined in a library or, as we do here, as an inline function. We will postpone the writing of the Makefile till later. First we will construct the C<.pd> file. This is the file containing PDL::PP code. We call this C . # # pp_def defines a PDL function. # pp_addhdr ( ' double eight_sum(int n) { int i; double sum, x; sum = 0.0; x=0.0; for (i=1; i<=n; i++) { x++; sum += x/((4.0*x*x-1.0)*(4.0*x*x-1.0)); } return 1.0/sum; } '); pp_def ( 'eight', Pars => 'int a(); double [o]b();', Code => '$b()=eight_sum($a());' ); # Always make sure that you finish your PP declarations with # pp_done pp_done(); A peculiarity with our example is that we have included the entire code with C instead of linking it in. This is only for the purposes of example, in a typical application you will use C to include header files. Note that the argument to C is enclosed in quotes. What is most important in this example is however the C command. The first argument to this is the name of the new function I , then comes a hash which the real meat: =over 4 =item * This gives the input parameters (here C) and the output parameters (here C). The latter are indicated by the C<[o]> specifier. Both arguments can have a type specification as shown here. Many variations and further flexibility in the interface can be specified. See C for details. =item * This switch contains the code that should be executed. As you can see this is a rather peculiar mix of C and Perl, but essentially it is just as you would write it in C, but the variables that are passed from PDL are treated differently and have to be referred to with a preceding '$'. There are also simple macros to pass pointers to data and to obtain the values of other Perl quantities, see the manual page for further details. =back Finally note the call to C at the end of the file. This is necessary in all PP files. OK. So now we have a file with code that we dearly would like to use in Perl via PDL. To do this we need to compile the function, and to do that we need a Makefile. use PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); $package = ["eight.pd",Eight,PDL::Eight]; %hash = pdlpp_stdargs($package); WriteMakefile( %hash ); sub MY::postamble {pdlpp_postamble($package)}; The code above should go in a file called Makefile.PL, which should subsequently be called in the standard Perl way: C . This should give you a Makefile and running C should compile the module for you and C will install it for you. =head2 Q: 7.3 How can I interface package XXX in PDL? This question is closely related to the previous one, and as we said there, the L pre-processor is the standard way of interfacing external packages with PDL. The most usual way to use PDL::PP is to write a short interface routine, see the L perldoc page and the answer to the previous question for examples. However it is also possible to interface a package to PDL by re-writing your function in PDL::PP directly. This can be convenient in certain situations, in particular if you have a routine that expects a function as input and you would like to pass the function a Perl function for convenience. The L perldoc page is the main source of information for writing PDL::PP extensions, but it is very useful to look for files in the distribution of PDL as many of the core functions are written in PDL::PP. Look for files that end in C<.pd> which is the generally accepted suffix for PDL::PP files. But we also have a simple example here. The following example will show you how to write a simple function that automatically allows threading. To make this concise the example is of an almost trivial function, but the intention is to show the basics of writing a PDL::PP interface. We will write a simple function that calculates the minimum, maximum and average of a piddle. On my machine the resulting function is 8 times faster than the built-in function C (of course the latter also calculates the median). Let's jump straight in. Here is the code (from a file called C ) # pp_def('quickstats', Pars => 'a(n); [o]avg(); [o]max(); [o]min()', Code => '$GENERIC(a) curmax, curmin; $GENERIC(a) tmp=0; loop(n) %{ tmp += $a(); if (!n || $a() > curmax) { curmax = $a();} if (!n || $a() < curmin) { curmin = $a();} %} $avg() = tmp/$SIZE(n); $max() = curmax; $min() = curmin; ' ); pp_done(); The above might look like a confusing mixture of C and Perl, but behind the peculiar syntax lies a very powerful language. Let us take it line by line. The first line declares that we are starting the definition of a PDL:PP function called C . The second line is very important as it specifies the input and output parameters of the function. C tells us that there is one input parameter that we will refer to as C which is expected to be a vector of length n (likewise matrices, both square and rectangular would be written as C and C respectively). To indicate that something is an output parameter we put C<[o]> in front of their names, so referring back to the code we see that avg, max and min are three output parameters, all of which are scalar (since they have no dimensional size indicated. The third line starts the code definition which is essentially pure C but with a couple of convenient functions. C<$GENERIC> is a function that returns the C type of its argument - here the input parameter a. Thus the first two lines of the code section are variable declarations. The C construct is a convenience function that loops over the dimension called n in the parameter section. Inside this loop we calculate the cumulative sum of the input vector and keep track of the maximum and minimum values. Finally we assign the resulting values to the output parameters. Finally we finish our function declaration with C . To compile our new function we need to create a Makefile, which we will just list since its creation is discussed in an earlier question. use PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); $package = ["quickstats.pd",Quickstats,PDL::Quickstats]; %hash = pdlpp_stdargs($package); WriteMakefile( %hash ); sub MY::postamble {pdlpp_postamble($package)}; An example Makefile.PL Our new statistic function should now compile using the tried and tested Perl way: C . You should experiment with this function, changing the calculations and input and output parameters. In conjunction with the L perldoc page this should allow you to quickly write more advanced routines directly in PDL::PP. =head1 BUGS If you find any inaccuracies in this document (or dis-functional URLs) please report to the perldl mailing list pdl-general@lists.sourceforge.net. =head1 ACKNOWLEDGMENTS Achim Bohnet (ach@mpe.mpg.de ) for suggesting CoolHTML as a prettypodder (although we have switched to XML now) and various other improvements. Suggestions for some questions were taken from Perl FAQ and adapted for PDL. =head1 CONTRIBUTORS Many people have contributed or given feedback on the current version of the FAQ, here is an incomplete list of individuals whose contributions or posts to the mailing-list have improved this FAQ at some point in time alphabetically listed by first name: Christian Soeller, Chris Marshall, Doug Burke, Doug Hunt, Frank Schmauder, Jarle Brinchmann, John Cerney, Karl Glazebrook, Kurt Starsinic, Thomas Yengst, Tuomas J. Lukka. =head1 AUTHOR AND COPYRIGHT This document emerged from a joint effort of several PDL developers (Karl Glazebrook, Tuomas J. Lukka, Christian Soeller) to compile a list of the most frequently asked questions about PDL with answers. Permission is granted for verbatim copying (and formatting) of this material as part of PDL. Permission is explicitly not granted for distribution in book or any corresponding form. Ask on the PDL mailing list pdl-general@lists.sourceforge.net if some of the issues covered in here are unclear. PDL-2.018/Basic/Pod/Index.pod0000644060175006010010000003144612562522363013730 0ustar chmNone =head1 NAME PDL::Index - an index of PDL documentation =head1 DESCRIPTION A meta document listing the documented PDL modules and the PDL manual documents =head1 PDL manuals =over 4 =item * L - making piddles from Perl and C/XS code =item * L - Discussion of bad value support in PDL =item * L - A journey through PDL's documentation, from beginner to advanced. =item * L - description of the dataflow philosophy =item * L - PDL changes between V1.0 and V2.0 =item * L - Frequently asked questions about PDL =item * L - An overview of the modules in the PDL::IO namespace. =item * L - Introduction to indexing and slicing piddles. =item * L - description of some aspects of the current internals =item * L - A guide for MATLAB users. =item * L - A guide to PDL's module reference. =item * L - Object-Orientation, what is it and how to exploit it =item * L - Generate PDL routines from concise descriptions =item * L - Parallel Processor MultiThreading Support in PDL (Experimental) =item * L - Why did we write PDL? =item * L - Quick introduction to PDL features. =item * L - A guide for Scilab users. =item * L - Tutorial for PDL's Threading feature =item * L - Small tidbits of useful arcana. Programming tidbits and such. =item * L - A guide to PDL's tutorial documentation. =back =head1 PDL scripts =over 4 =item * L - Simple shell (version 2) for PDL =item * L - shell interface to PDL documentation =item * L - Simple shell for PDL (see also L) =item * L - script to generate Makefile.PL and PP file skeleton =back =head1 PDL modules =over 4 =item * L - the Perl Data Language =item * L - MatLab style AutoLoader for PDL =item * L - PDL does process bad values =item * L - Basic utility functions for PDL =item * L - call functions in external shared libraries =item * L - PDL subclass which allows reading and writing of fixed-length character strings as byte PDLs =item * L - handle complex numbers =item * L - compression utilities =item * L - basic compile time constants for PDL =item * L - fundamental PDL functionality and vectorization/threading =item * L - PDL development module =item * L - functions to support debugging of PDL scripts =item * L - Non-memory-resident array object =item * L - support for PDL online documentation =item * L - commands for accessing PDL doc database from 'perldl' shell =item * L - PDL export control =item * L - FFTs for PDL =item * L - PDL interface to the Fastest Fourier Transform in the West v2.x =item * L - Linear predictive filtering =item * L - linear filtering for PDL =item * L - routines for fitting gaussians =item * L - Levenberg-Marquardt fitting routine for PDL =item * L - routines for fitting data with linear combinations of functions. =item * L - routines for fitting with polynomials =item * L - interpolation, integration, & gradient estimation (differentiation) of functions =item * L - PDL interface to the Proj4 projection library. =item * L - PDL interface to numerical differentiation routines in GSL =item * L - PDL interface to numerical integration routines in GSL =item * L - PDL interface to Interpolation routines in GSL =item * L - PDL interface to multidimensional root-finding routines in GSL =item * L - PDL interface to RNG and randist routines in GSL =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - Gaussian distributions. =item * L - An object oriented interface to PDL graphics =item * L - Display PDL images on IIS devices (saoimage/ximtool) =item * L - provides access to a number of look-up tables =item * L - derive limits for display purposes =item * L - PDL TriD OpenGL interface using POGL =item * L - quick routines to plot lots of stuff from piddles. =item * L - PGPLOT enhanced interface for PDL =item * L - A OO interface to PGPLOT windows =item * L - Setting PGPLOT options =item * L - Object-oriented interface from perl/PDL to the PLPLOT plotting library =item * L - PDL 3D interface =item * L - default event handler subroutines =item * L - 3D Surface contours for TriD =item * L - Text tools =item * L - Mathematical Graph objects for PDL =item * L - Simple Graph Objects for TriD =item * L - Helper routines for Three-dimensional graphics =item * L - A Tk widget interface to the PDL::Graphics::TriD. =item * L - TriD VRML backend =item * L - a module for reading DICOM images. =item * L - data dumping for structs with PDLs =item * L - Simple FITS support for PDL =item * L - A simple, fast and convenient io format for PerlDL. =item * L - A flexible binary I/O format for PerlDL =item * L - Interface to the GD image library. =item * L - An interface library for HDF4 files. =item * L - PDL interface to the HDF4 SD library. =item * L - I/O of IDL Save Files =item * L - misc IO routines for PDL =item * L - image I/O for PDL =item * L - pnm format I/O for PDL =item * L - helper functions to make PDL usable with Storable =item * L - Miscellaneous 2D image processing functions =item * L - useful image processing in N dimensions =item * L - some utility functions for RGB image data handling =item * L - minimum PDL module OO loader =item * L - minimum PDL module function loader =item * L - declare PDL lvalue subs =item * L - extended mathematical operations and special functions =item * L - a convenience matrix class for column-major access =item * L - Some Useful Matrix Operations =item * L - a PDL interface to the Minuit library =item * L - toward a nicer slicing syntax for PDL =item * L - Fundamental mathematical operators =item * L - Simplex optimization routines =item * L - simplifies option passing by hash in PerlDL =item * L - filter out Moose cruft =item * L - enable PDL NiceSlice syntax =item * L - implement perldl aliases/escapes =item * L - disable default print output =item * L - profile for Perldl2 shell =item * L - primitive operations for pdl =item * L - a C function for PDL =item * L - PDL interface to the slatec numerical programming library =item * L - Indexing, slicing, and dicing =item * L - tests for some PP features =item * L - Coordinate transforms, image warping, and N-D functions =item * L - Useful cartographic projections =item * L - PDL::Transform interface to the Proj4 projection library =item * L - define fundamental PDL Datatypes =item * L - primitive ufunc operations for pdl =back =head1 HISTORY Automatically generated by scantree.pl for PDL version 2.004_995. PDL-2.018/Basic/Pod/Indexing.pod0000644060175006010010000017525213036512174014426 0ustar chmNone=head1 NAME PDL::Indexing - Introduction to indexing and slicing piddles. =head1 OVERVIEW This man page should serve as a first tutorial on the indexing and threading features of I. Like all vectorized languages, PDL automates looping over multi-dimensional data structures ("piddles") using a variant of mathematical vector notation. The automatic looping is called "threading", in part because ultimately PDL will implement parallel processing to speed up the loops. A lot of the flexibility and power of PDL relies on the indexing and threading features of the Perl extension. Indexing allows access to the data of a piddle in a very flexible way. Threading provides efficient vectorization of simple operations. The values of a piddle are stored compactly as typed values in a single block of memory, not (as in a normal Perl list-of-lists) as individual Perl scalars. In the sections that follow many "methods" are called out -- these are Perl operators that apply to piddles. From the L (or L) shell, you can find out more about each method by typing "?" followed by the method name. =head2 Dimension lists A piddle (PDL variable), in general, is an N-dimensional array where N can be 0 (for a scalar), 1 (e.g. for a sound sample), or higher values for images and more complex structures. Each dimension of the piddle has a positive integer size. The C interpreter treats each piddle as a special type of Perl scalar (a blessed Perl object, actually -- but you don't have to know that to use them) that can be used anywhere you can put a normal scalar. You can access the dimensions of a piddle as a Perl list and otherwise determine the size of a piddle with several methods. The important ones are: =over 3 =item nelem - the total number of elements in a piddle =item ndims - returns the number of dimensions in a piddle =item dims - returns the dimension list of a piddle as a Perl list =item dim - returns the size of a particular dimension of a piddle =back =head2 Indexing and Dataflow PDL maintains a notion of "dataflow" between a piddle and indexed subfields of that piddle. When you produce an indexed subfield or single element of a parent piddle, the child and parent remain attached until you manually disconnect them. This lets you represent the same data different ways within your code -- for example, you can consider an RGB image simultaneously as a collection of (R,G,B) values in a 3 x 1000 x 1000 image, and as three separate 1000 x 1000 color planes stored in different variables. Modifying any of the variables changes the underlying memory, and the changes are reflected in all representations of the data. There are two important methods that let you control dataflow connections between a child and parent piddle: =over 3 =item copy - forces an explicit copy of a piddle =item sever - breaks the dataflow connection between a piddle and its parents (if any) =back =head2 Threading and Dimension Order Most PDL operations act on the first few dimensions of their piddle arguments. For example, C sums all elements along the first dimension in the list (dimension 0). If you feed in a three-dimensional piddle, then the first dimension is considered the "active" dimension and the later dimensions are "thread" dimensions because they are simply looped over. There are several ways to transpose or re-order the dimension list of a piddle. Those techniques are very fast since they don't touch the underlying data, only change the way that PDL accesses the data. The main dimension ordering functions are: =over 3 =item mv - moves a particular dimension somewhere else in the dimension list =item xchg - exchanges two dimensions in the dimension list, leaving the rest alone =item reorder - allows wholesale mixing of the dimensions =item clump - clumps together two or more small dimensions into one larger one =item squeeze - eliminates any dimensions of size 1 =back =head2 Physical and Dummy Dimensions =over 5 =item * document Perl level threading =item * threadids =item * update and correct description of slice =item * new functions in slice.pd (affine, lag, splitdim) =item * reworking of paragraph on explicit threading =back =head1 Indexing and threading with PDL A lot of the flexibility and power of PDL relies on the indexing and looping features of the Perl extension. Indexing allows access to the data of a piddle in a very flexible way. Threading provides efficient implicit looping functionality (since the loops are implemented as optimized C code). Piddles are Perl objects that represent multidimensional arrays and operations on those. In contrast to simple Perl C<@x> style lists the array data is compactly stored in a single block of memory thus taking up a lot less memory and enabling use of fast C code to implement operations (e.g. addition, etc) on piddles. =head2 piddles can have children Central to many of the indexing capabilities of PDL are the relation of "parent" and "child" between piddles. Many of the indexing commands create a new piddle from an existing piddle. The new piddle is the "child" and the old one is the "parent". The data of the new piddle is defined by a transformation that specifies how to generate (compute) its data from the parent's data. The relation between the child piddle and its parent are often bidirectional, meaning that changes in the child's data are propagated back to the parent. (Note: You see, we are aiming in our terminology already towards the new dataflow features. The kind of dataflow that is used by the indexing commands (about which you will learn in a minute) is always in operation, not only when you have explicitly switched on dataflow in your piddle by saying C<$a-Edoflow>. For further information about data flow check the dataflow man page.) Another way to interpret the piddles created by our indexing commands is to view them as a kind of intelligent pointer that points back to some portion or all of its parent's data. Therefore, it is not surprising that the parent's data (or a portion of it) changes when manipulated through this "pointer". After these introductory remarks that hopefully prepared you for what is coming (rather than confuse you too much) we are going to dive right in and start with a description of the indexing commands and some typical examples how they might be used in PDL programs. We will further illustrate the pointer/dataflow analogies in the context of some of the examples later on. There are two different implementations of this ``smart pointer'' relationship: the first one, which is a little slower but works for any transformation is simply to do the transformation forwards and backwards as necessary. The other is to consider the child piddle a ``virtual'' piddle, which only stores a pointer to the parent and access information so that routines which use the child piddle actually directly access the data in the parent. If the virtual piddle is given to a routine which cannot use it, PDL transparently physicalizes the virtual piddle before letting the routine use it. Currently (1.94_01) all transformations which are ``affine'', i.e. the indices of the data item in the parent piddle are determined by a linear transformation (+ constant) from the indices of the child piddle result in virtual piddles. All other indexing routines (e.g. C<-Eindex(...)>) result in physical piddles. All routines compiled by PP can accept affine piddles (except those routines that pass pointers to external library functions). Note that whether something is affine or not does not affect the semantics of what you do in any way: both $a->index(...) .= 5; $a->slice(...) .= 5; change the data in C<$a>. The affinity does, however, have a significant impact on memory usage and performance. =head2 Slicing piddles Probably the most important application of the concept of parent/child piddles is the representation of rectangular slices of a physical piddle by a virtual piddle. Having talked long enough about concepts let's get more specific. Suppose we are working with a 2D piddle representing a 5x5 image (its unusually small so that we can print it without filling several screens full of digits ;). pdl> $im = sequence(5,5) pdl> p $im [ [ 0 1 2 3 4] [ 5 6 7 8 9] [10 11 12 13 14] [15 16 17 18 19] [20 21 22 23 24] ] pdl> help vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $im Double D [5,5] P 0.20Kb [ here it might be appropriate to quickly talk about the C command that provides information about piddles in the interactive C or C shell that comes with PDL. ] Now suppose we want to create a 1-D piddle that just references one line of the image, say line 2; or a piddle that represents all even lines of the image (imagine we have to deal with even and odd frames of an interlaced image due to some peculiar behaviour of our frame grabber). As another frequent application of slices we might want to create a piddle that represents a rectangular region of the image with top and bottom reversed. All these effects (and many more) can be easily achieved with the powerful slice function: pdl> $line = $im->slice(':,(2)') pdl> $even = $im->slice(':,1:-1:2') pdl> $area = $im->slice('3:4,3:1') pdl> help vars # or just PDL->vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $even Double D [5,2] -C 0.00Kb $im Double D [5,5] P 0.20Kb $line Double D [5] -C 0.00Kb $area Double D [2,3] -C 0.00Kb All three "child" piddles are children of C<$im> or in the other (largely equivalent) interpretation pointers to data of C<$im>. Operations on those virtual piddles access only those portions of the data as specified by the argument to slice. So we can just print line 2: pdl> p $line [10 11 12 13 14] Also note the difference in the "Flow State" of C<$area> above and below: pdl> p $area pdl> help $area This variable is Double D [2,3] VC 0.00Kb The following demonstrates that C<$im> and C<$line> really behave as you would expect from a pointer-like object (or in the dataflow picture: the changes in C<$line>'s data are propagated back to C<$im>): pdl> $im++ pdl> p $line [11 12 13 14 15] pdl> $line += 2 pdl> p $im [ [ 1 2 3 4 5] [ 6 7 8 9 10] [13 14 15 16 17] [16 17 18 19 20] [21 22 23 24 25] ] Note how assignment operations on the child virtual piddles change the parent physical piddle and vice versa (however, the basic "=" assignment doesn't, use ".=" to obtain that effect. See below for the reasons). The virtual child piddles are something like "live links" to the "original" parent piddle. As previously said, they can be thought of to work similar to a C-pointer. But in contrast to a C-pointer they carry a lot more information. Firstly, they specify the structure of the data they represent (the dimensionality of the new piddle) and secondly, specify how to create this structure from its parents data (the way this works is buried in the internals of PDL and not important for you to know anyway (unless you want to hack the core in the future or would like to become a PDL guru in general (for a definition of this strange creature see L)). The previous examples have demonstrated typical usage of the slice function. Since the slicing functionality is so important here is an explanation of the syntax for the string argument to slice: $vpdl = $a->slice('ind0,ind1...') where C specifies what to do with index No 0 of the piddle C<$a>, etc. Each element of the comma separated list can have one of the following forms: =over 6 =item ':' Use the whole dimension =item 'n' Use only index C. The dimension of this index in the resulting virtual piddle is 1. An example involving those first two index formats: pdl> $column = $im->slice('2,:') pdl> $row = $im->slice(':,0') pdl> p $column [ [ 3] [ 8] [15] [18] [23] ] pdl> p $row [ [1 2 3 4 5] ] pdl> help $column This variable is Double D [1,5] VC 0.00Kb pdl> help $row This variable is Double D [5,1] VC 0.00Kb =item '(n)' Use only index C. This dimension is removed from the resulting piddle (relying on the fact that a dimension of size 1 can always be removed). The distinction between this case and the previous one becomes important in assignments where left and right hand side have to have appropriate dimensions. pdl> $line = $im->slice(':,(0)') pdl> help $line This variable is Double D [5] -C 0.00Kb pdl> p $line [1 2 3 4 5] Spot the difference to the previous example? =item 'n1:n2' or 'n1:n2:n3' Take the range of indices from C to C or (second form) take the range of indices from C to C with step C. An example for the use of this format is the previous definition of the sub-image composed of even lines. pdl> $even = $im->slice(':,1:-1:2') This example also demonstrates that negative indices work like they do for normal Perl style arrays by counting backwards from the end of the dimension. If C is smaller than C (in the example -1 is equivalent to index 4) the elements in the virtual piddle are effectively reverted with respect to its parent. =item '*[n]' Add a dummy dimension. The size of this dimension will be 1 by default or equal to C if the optional numerical argument is given. Now, this is really something a bit strange on first sight. What is a dummy dimension? A dummy dimension inserts a dimension where there wasn't one before. How is that done ? Well, in the case of the new dimension having size 1 it can be easily explained by the way in which you can identify a vector (with C elements) with an C<(1,m)> or C<(m,1)> matrix. The same holds obviously for higher dimensional objects. More interesting is the case of a dummy dimensions of size greater than one (e.g. C). This works in the same way as a call to the L function creates a new dummy dimension. So read on and check its explanation below. =item '([n1:n2[:n3]]=i)' [Not yet implemented ??????] With an argument like this you make I. The I will be dimension no. C of the new output piddle and (if optional part in brackets specified) will extend along the range of indices specified of the respective parent piddle's dimension. In general an argument like this only makes sense if there are other arguments like this in the same call to slice. The part in brackets is optional for this type of argument. All arguments of this type that specify the same target dimension C have to relate to the same number of indices in their parent dimension. The best way to explain it is probably to give an example, here we make a piddle that refers to the elements along the space diagonal of its parent piddle (a cube): $cube = zeroes(5,5,5); $sdiag = $cube->slice('(=0),(=0),(=0)'); The above command creates a virtual piddle that represents the diagonal along the parents' dimension no. 0, 1 and 2 and makes its dimension 0 (the only dimension) of it. You use the extended syntax if the dimension sizes of the parent dimensions you want to build the diagonal from have different sizes or you want to reverse the sequence of elements in the diagonal, e.g. $rect = zeroes(12,3,5,6,2); $vpdl = $rect->slice('2:7,(0:1=1),(4),(5:4=1),(=1)'); So the elements of $vpdl will then be related to those of its parent in way we can express as: vpdl(i,j) = rect(i+2,j,4,5-j,j) 0<=i<5, 0<=j<2 =back [ work in the new index function: C<$b = $a-Eindex($c);> ???? ] =head2 There are different kinds of assignments in PDL The previous examples have already shown that virtual piddles can be used to operate on or access portions of data of a parent piddle. They can also be used as lvalues in assignments (as the use of C<++> in some of the examples above has already demonstrated). For explicit assignments to the data represented by a virtual piddle you have to use the overloaded C<.=> operator (which in this context we call I). Why can't you use the normal assignment operator C<=>? Well, you definitely still can use the '=' operator but it wouldn't do what you want. This is due to the fact that the '=' operator cannot be overloaded in the same way as other assignment operators. If we tried to use '=' to try to assign data to a portion of a physical piddle through a virtual piddle we wouldn't achieve the desired effect (instead the variable representing the virtual piddle (a reference to a blessed thingy) would after the assignment just contain the reference to another blessed thingy which would behave to future assignments as a "physical" copy of the original rvalue [this is actually not yet clear and subject of discussions in the PDL developers mailing list]. In that sense it would break the connection of the piddle to the parent [ isn't this behaviour in a sense the opposite of what happens in dataflow, where C<.=> breaks the connection to the parent? ]. E.g. pdl> $line = $im->slice(':,(2)') pdl> $line = zeroes(5); pdl> $line++; pdl> p $im [ [ 1 2 3 4 5] [ 6 7 8 9 10] [13 14 15 16 17] [16 17 18 19 20] [21 22 23 24 25] ] pdl> p $line [1 1 1 1 1] But using C<.=> pdl> $line = $im->slice(':,(2)') pdl> $line .= zeroes(5) pdl> $line++ pdl> p $im [ [ 1 2 3 4 5] [ 6 7 8 9 10] [ 1 1 1 1 1] [16 17 18 19 20] [21 22 23 24 25] ] pdl> print $line [1 1 1 1 1] Also, you can substitute pdl> $line .= 0; for the assignment above (the zero is converted to a scalar piddle, with no dimensions so it can be assigned to any piddle). A nice feature in recent perl versions is lvalue subroutines (i.e., versions 5.6.x and higher including all perls currently supported by PDL). That allows one to use the slicing syntax on both sides of the assignment: pdl> $im->slice(':,(2)') .= zeroes(5)->xvals->float Related to the lvalue sub assignment feature is a little trap for the unwary: recent perls introduced a "feature" which breaks PDL's use of lvalue subs for slice assignments when running under the perl debugger, C. Under the debugger, the above usage gives an error like: C< Can't return a temporary from lvalue subroutine... > So you must use syntax like this: pdl> ($pdl = $im->slice(':,(2)')) .= zeroes(5)->xvals->float which works both with and without the debugger but is arguably clumsy and awkward to read. Note that there can be a problem with assignments like this when lvalue and rvalue piddles refer to overlapping portions of data in the parent piddle: # revert the elements of the first line of $a ($tmp = $a->slice(':,(1)')) .= $a->slice('-1:0,(1)'); Currently, the parent data on the right side of the assignments is not copied before the (internal) assignment loop proceeds. Therefore, the outcome of this assignment will depend on the sequence in which elements are assigned and almost certainly I do what you wanted. So the semantics are currently B for now and liable to change anytime. To obtain the desired behaviour, use ($tmp = $a->slice(':,(1)')) .= $a->slice('-1:0,(1)')->copy; which makes a physical copy of the slice or ($tmp = $a->slice(':,(1)')) .= $a->slice('-1:0,(1)')->sever; which returns the same slice but severs the connection of the slice to its parent. =head2 Other functions that manipulate dimensions Having talked extensively about the L function it should be noted that this is not the only PDL indexing function. There are additional indexing functions which are also useful (especially in the context of threading which we will talk about later). Here are a list and some examples how to use them. =over 4 =item C inserts a dummy dimension of the size you specify (default 1) at the chosen location. You can't wait to hear how that is achieved? Well, all elements with index C<(X,x,Y)> (C<0E=xEsize_of_dummy_dim>) just map to the element with index C<(X,Y)> of the parent piddle (where C and C refer to the group of indices before and after the location where the dummy dimension was inserted.) This example calculates the x coordinate of the centroid of an image (later we will learn that we didn't actually need the dummy dimension thanks to the magic of implicit threading; but using dummy dimensions the code would also work in a thread-less world; though once you have worked with PDL threads you wouldn't want to live without them again). # centroid ($xd,$yd) = $im->dims; $xc = sum($im*xvals(zeroes($xd))->dummy(1,$yd))/sum($im); Let's explain how that works in a little more detail. First, the product: $xvs = xvals(zeroes($xd)); print $xvs->dummy(1,$yd); # repeat the line $yd times $prod = $im*xvs->dummy(1,$yd); # form the pixel-wise product with # the repeated line of x-values The rest is then summing the results of the pixel-wise product together and normalizing with the sum of all pixel values in the original image thereby calculating the x-coordinate of the "center of mass" of the image (interpreting pixel values as local mass) which is known as the centroid of an image. Next is a (from the point of view of memory consumption) very cheap conversion from grey-scale to RGB, i.e. every pixel holds now a triple of values instead of a scalar. The three values in the triple are, fortunately, all the same for a grey image, so that our trick works well in that it maps all the three members of the triple to the same source element: # a cheap grey-scale to RGB conversion $rgb = $grey->dummy(0,3) Unfortunately this trick cannot be used to convert your old B/W photos to color ones in the way you'd like. :( Note that the memory usage of piddles with dummy dimensions is especially sensitive to the internal representation. If the piddle can be represented as a virtual affine (``vaffine'') piddle, only the control structures are stored. But if C<$b> in $a = zeroes(10000); $b = $a->dummy(1,10000); is made physical by some routine, you will find that the memory usage of your program has suddenly grown by 100Mb. =item C replaces two dimensions (which have to be of equal size) by one dimension that references all the elements along the "diagonal" along those two dimensions. Here, we have two examples which should appear familiar to anyone who has ever done some linear algebra. Firstly, make a unity matrix: # unity matrix $e = zeroes(float, 3, 3); # make everything zero ($tmp = $e->diagonal(0,1)) .= 1; # set the elements along the diagonal to 1 print $e; Or the other diagonal: ($tmp = $e->slice(':-1:0')->diagonal(0,1)) .= 2; print $e; (Did you notice how we used the slice function to revert the sequence of lines before setting the diagonal of the new child, thereby setting the cross diagonal of the parent ?) Or a mapping from the space of diagonal matrices to the field over which the matrices are defined, the trace of a matrix: # trace of a matrix $trace = sum($mat->diagonal(0,1)); # sum all the diagonal elements =item C and C L exchanges or "transposes" the two specified dimensions. A straightforward example: # transpose a matrix (without explicitly reshuffling data and # making a copy) $prod = $a x $a->xchg(0,1); C<$prod> should now be pretty close to the unity matrix if C<$a> is an orthogonal matrix. Often C will be used in the context of threading but more about that later. L works in a similar fashion. It moves a dimension (specified by its number in the parent) to a new position in the new child piddle: $b = $a->mv(4,0); # make the 5th dimension of $a the first in the # new child $b The difference between C and C is that C only changes the position of two dimensions with each other, whereas C inserts the first dimension to the place of second, moving the other dimensions around accordingly. =item C collapses several dimensions into one. Its only argument specifies how many dimensions of the source piddle should be collapsed (starting from the first). An (admittedly unrealistic) example is a 3D piddle which holds data from a stack of image files that you have just read in. However, the data from each image really represents a 1D time series and has only been arranged that way because it was digitized with a frame grabber. So to have it again as an array of time sequences you say pdl> $seqs = $stack->clump(2) pdl> help vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $seqs Double D [8000,50] -C 0.00Kb $stack Double D [100,80,50] P 3.05Mb Unrealistic as it may seem, our confocal microscope software writes data (sometimes) this way. But more often you use clump to achieve a certain effect when using implicit or explicit threading. =back =head2 Calls to indexing functions can be chained As you might have noticed in some of the examples above calls to the indexing functions can be nicely chained since all of these functions return a newly created child object. However, when doing extensive index manipulations in a chain be sure to keep track of what you are doing, e.g. $a->xchg(0,1)->mv(0,4) moves the dimension 1 of C<$a> to position 4 since when the second command is executed the original dimension 1 has been moved to position 0 of the new child that calls the C function. I think you get the idea (in spite of my convoluted explanations). =head2 Propagated assignments ('.=') and dummy dimensions A subtlety related to indexing is the assignment to piddles containing dummy dimensions of size greater than 1. These assignments (using C<.=>) are forbidden since several elements of the lvalue piddle point to the same element of the parent. As a consequence the value of those parent elements are potentially ambiguous and would depend on the sequence in which the implementation makes the assignments to elements. Therefore, an assignment like this: $a = pdl [1,2,3]; $b = $a->dummy(1,4); $b .= yvals(zeroes(3,4)); can produce unexpected results and the results are explicitly B by PDL because when PDL gets parallel computing features, the current result may well change. From the point of view of dataflow the introduction of greater-size-than-one dummy dimensions is regarded as an irreversible transformation (similar to the terminology in thermodynamics) which precludes backward propagation of assignment to a parent (which you had explicitly requested using the C<.=> assignment). A similar problem to watch out for occurs in the context of threading where sometimes dummy dimensions are created implicitly during the thread loop (see below). =head2 Reasons for the parent/child (or "pointer") concept [ this will have to wait a bit ] XXXXX being memory efficient XXXXX in the context of threading XXXXX very flexible and powerful way of accessing portions of piddle data (in much more general way than sec, etc allow) XXXXX efficient implementation XXXXX difference to section/at, etc. =head2 How to make things physical again [ XXXXX fill in later when everything has settled a bit more ] ** When needed (xsub routine interfacing C lib function) ** How achieved (->physical) ** How to test (isphysical (explain how it works currently)) ** ->copy and ->sever =head1 Threading In the previous paragraph on indexing we have already mentioned the term occasionally but now its really time to talk explicitly about "threading" with piddles. The term threading has many different meanings in different fields of computing. Within the framework of PDL it could probably be loosely defined as an implicit looping facility. It is implicit because you don't specify anything like enclosing for-loops but rather the loops are automatically (or 'magically') generated by PDL based on the dimensions of the piddles involved. This should give you a first idea why the index/dimension manipulating functions you have met in the previous paragraphs are especially important and useful in the context of threading. The other ingredient for threading (apart from the piddles involved) is a function that is threading aware (generally, these are L compiled functions) and that the piddles are "threaded" over. So much about the terminology and now let's try to shed some light on what it all means. =head2 Implicit threading - a first example There are two slightly different variants of threading. We start with what we call "implicit threading". Let's pick a practical example that involves looping of a function over many elements of a piddle. Suppose we have an RGB image that we want to convert to grey-scale. The RGB image is represented by a 3-dim piddle C where the first dimension contains the three color components of each pixel and C and C are width and height of the image, respectively. Next we need to specify how to convert a color-triple at a given pixel into a grey-value (to be a realistic example it should represent the relative intensity with which our color insensitive eye cells would detect that color to achieve what we would call a natural conversion from color to grey-scale). An approximation that works quite well is to compute the grey intensity from each RGB triplet (r,g,b) as a weighted sum grey-value = 77/256*r + 150/256*g + 29/256*b = inner([77,150,29]/256, [r,g,b]) where the last form indicates that we can write this as an inner product of the 3-vector comprising the weights for red, green and blue components with the 3-vector containing the color components. Traditionally, we might have written a function like the following to process the whole image: my @dims=$im->dims; # here normally check that first dim has correct size (3), etc $grey=zeroes(@dims[1,2]); # make the piddle for the resulting grey image $w = pdl [77,150,29] / 256; # the vector of weights for ($j=0;$jslice(':,(i),(j)')); set($grey,$i,$j,$tmp); # and set it in the grey-scale image } } Now we write the same using threading (noting that C is a threading aware function defined in the L package) $grey = inner($im,pdl([77,150,29]/256)); We have ended up with a one-liner that automatically creates the piddle C<$grey> with the right number and size of dimensions and performs the loops automatically (these loops are implemented as fast C code in the internals of PDL). Well, we still owe you an explanation how this 'magic' is achieved. =head2 How does the example work ? The first thing to note is that every function that is threading aware (these are without exception functions compiled from concise descriptions by L, later just called PP-functions) expects a defined (minimum) number of dimensions (we call them core dimensions) from each of its piddle arguments. The L function expects two one-dimensional (input) parameters from which it calculates a zero-dimensional (output) parameter. We write that symbolically as C and call it C's I, where n represents the size of that dimension. n being equal in the first and second parameter means that those dimensions have to be of equal size in any call. As a different example take the outer product which takes two 1D vectors to generate a 2D matrix, symbolically written as C. The C<[o]> in both examples indicates that this (here third) argument is an output argument. In the latter example the dimensions of first and second argument don't have to agree but you see how they determine the size of the two dimensions of the output piddle. Here is the point when threading finally enters the game. If you call PP-functions with piddles that have I than the required core dimensions the first dimensions of the piddle arguments are used as the core dimensions and the additional extra dimensions are threaded over. Let us demonstrate this first with our example above $grey = inner($im,$w); # w is the weight vector from above In this case $w is 1D and so supplied just the core dimension, C<$im> is 3D, more specifically C<(3,x,y)>. The first dimension (of size 3) is the required core dimension that matches (as required by inner) the first (and only) dimension of C<$w>. The second dimension is the first thread dimension (of size C) and the third is here the second thread dimension (of size C). The output piddle is automatically created (as requested by setting C<$grey> to "null" prior to invocation). The output dimensions are obtained by appending the I (here C<(x,y)>) to the core output dimensions (here 0D) to yield the final dimensions of the auto-created piddle (here C<0D+2D=2D> to yield a 2D output of size C<(x,y)>). So the above command calls the core functionality that computes the inner product of two 1D vectors C times with C<$w> and all 1D slices of the form C<(':,(i),(j)')> of C<$im> and sets the respective elements of the output piddle C<$grey(i,j)> to the result of each computation. We could write that symbolically as $grey(0,0) = f($w,$im(:,(0),(0))) $grey(1,0) = f($w,$im(:,(1),(0))) . . . $grey(x-2,y-1) = f($w,$im(:,(x-2),(y-1))) $grey(x-1,y-1) = f($w,$im(:,(x-1),(y-1))) But this is done automatically by PDL without writing any explicit Perl loops. We see that the command really creates an output piddle with the right dimensions and sets the elements indeed to the result of the computation for each pixel of the input image. When even more piddles and extra dimensions are involved things get a bit more complicated. We will first give the general rules how the thread dimensions depend on the dimensions of input piddles enabling you to figure out the dimensionality of an auto-created output piddle (for any given set of input piddles and core dimensions of the PP-function in question). The general rules will most likely appear a bit confusing on first sight so that we'll set out to illustrate the usage with a set of further examples (which will hopefully also demonstrate that there are indeed many practical situations where threading comes in extremely handy). =head2 A call for coding discipline Before we point out the other technical details of threading, please note this call for programming discipline when using threading: In order to preserve human readability, I comment any nontrivial expression in your code involving threading. Most importantly, for any subroutine, include information at the beginning about what you expect the dimensions to represent (or ranges of dimensions). As a warning, look at this undocumented function and try to guess what might be going on: sub lookup { my ($im,$palette) = @_; my $res; index($palette->xchg(0,1), $im->long->dummy(0,($palette->dim)[0]), ($res=null)); return $res; } Would you agree that it might be difficult to figure out expected dimensions, purpose of the routine, etc ? (If you want to find out what this piece of code does, see below) =head2 How to figure out the loop dimensions There are a couple of rules that allow you to figure out number and size of loop dimensions (and if the size of your input piddles comply with the threading rules). Dimensions of any piddle argument are broken down into two groups in the following: Core dimensions (as defined by the PP-function, see B for a list of PDL primitives) and extra dimensions which comprises all remaining dimensions of that piddle. For example calling a function C with the signature C with a piddle C as C results in the semantic splitting of a's dimensions into: core dimensions C<(2,4)> and extra dimensions C<(7,1,3)>. =over 6 =item R0 Core dimensions are identified with the first N dimensions of the respective piddle argument (and are required). Any further dimensions are extra dimensions and used to determine the loop dimensions. =item R1 The number of (implicit) loop dimensions is equal to the maximal number of extra dimensions taken over the set of piddle arguments. =item R2 The size of each of the loop dimensions is derived from the size of the respective dimensions of the piddle arguments. The size of a loop dimension is given by the maximal size found in any of the piddles having this extra dimension. =item R3 For all piddles that have a given extra dimension the size must be equal to the size of the loop dimension (as determined by the previous rule) or 1; otherwise you raise a runtime exception. If the size of the extra dimension in a piddle is one it is implicitly treated as a dummy dimension of size equal to that loop dim size when performing the thread loop. =item R4 If a piddle doesn't have a loop dimension, in the thread loop this piddle is treated as if having a dummy dimension of size equal to the size of that loop dimension. =item R5 If output auto-creation is used (by setting the relevant piddle to Cnull> before invocation) the number of dimensions of the created piddle is equal to the sum of the number of core output dimensions + number of loop dimensions. The size of the core output dimensions is derived from the relevant dimension of input piddles (as specified in the function definition) and the sizes of the other dimensions are equal to the size of the loop dimension it is derived from. The automatically created piddle will be physical (unless dataflow is in operation). =back In this context, note that you can run into the problem with assignment to piddles containing greater-than-one dummy dimensions (see above). Although your output piddle(s) didn't contain any dummy dimensions in the first place they may end up with implicitly created dummy dimensions according to I. As an example, suppose we have a (here unspecified) PP-function with the signature: func((m,n),(m,n,o),(m),[o](m,o)) and you call it with 3 piddles C, C, and C as func($a,$b,$c,($d=null)) then the number of loop dimensions is 3 (by C from C<$b> and C<$c>) with sizes C<(10,11,12)> (by R2); the two output core dimensions are C<(5,2)> (from the signature of func) resulting in a 5-dimensional output piddle C<$c> of size C<(5,2,10,11,12)> (see R5) and (the automatically created) C<$d> is derived from C<($a,$b,$c)> in a way that can be expressed in pdl pseudo-code as $d(:,:,i,j,k) .= func($a(:,:,i,j),$b(:,:,:,i,0,k),$c(:,0,j,k)) with 0<=i<10, 0<=j<=11, 0<=k<12 If we analyze the color to grey-scale conversion again with these rules in mind we note another great advantage of implicit threading. We can call the conversion with a piddle representing a pixel (C), a line of rgb pixels (C), a proper color image (C) or a whole stack of RGB images (C). As long as C<$im> is of the form C<(3,...)> the automatically created output piddle will contain the right number of dimensions and contain the intensity data as we expect it since the loops have been implicitly performed thanks to I. You can easily convince yourself that calling with a color pixel C<$grey> is 0D, with a line it turns out 1D C, with an image we get C and finally we get a converted image stack C. Let's fill these general rules with some more life by going through a couple of further examples. The reader may try to figure out equivalent formulations with explicit for-looping and compare the flexibility of those routines using implicit threading to the explicit formulation. Furthermore, especially when using several thread dimensions it is a useful exercise to check the relative speed by doing some benchmark tests (which we still have to do). First in the row is a slightly reworked centroid example, now coded with threading in mind. # threaded mult to calculate centroid coords, works for stacks as well $xc = sumover(($im*xvals(($im->dims)[0]))->clump(2)) / sumover($im->clump(2)); Let's analyze what's going on step by step. First the product: $prod = $im*xvals(zeroes(($im->dims)[0])) This will actually work for C<$im> being one, two, three, and higher dimensional. If C<$im> is one-dimensional it's just an ordinary product (in the sense that every element of C<$im> is multiplied with the respective element of C), if C<$im> has more dimensions further threading is done by adding appropriate dummy dimensions to C according to R4. More importantly, the two L operations show a first example of how to make use of the dimension manipulating commands. A quick look at sumover's signature will remind you that it will only "gobble up" the first dimension of a given input piddle. But what if we want to really compute the sum over all elements of the first two dimensions? Well, nothing keeps us from passing a virtual piddle into sumover which in this case is formed by clumping the first two dimensions of the "parent piddle" into one. From the point of view of the parent piddle the sum is now computed over the first two dimensions, just as we wanted, though sumover has just done the job as specified by its signature. Got it ? Another little finesse of writing the code like that: we intentionally used Cclump(2))> instead of C so that we can either pass just an image C<(x,y)> or a stack of images C<(x,y,t)> into this routine and get either just one x-coordiante or a vector of x-coordinates (of size t) in return. Another set of common operations are what one could call "projection operations". These operations take a N-D piddle as input and return a (N-1)-D "projected" piddle. These operations are often performed with functions like L, L, L and L. Using again images as examples we might want to calculate the maximum pixel value for each line of an image or image stack. We know how to do that # maxima of lines (as function of line number and time) maximum($stack,($ret=null)); But what if you want to calculate maxima per column when implicit threading always applies the core functionality to the first dimension and threads over all others? How can we achieve that instead the core functionality is applied to the second dimension and threading is done over the others. Can you guess it? Yes, we make a virtual piddle that has the second dimension of the "parent piddle" as its first dimension using the C command. # maxima of columns (as function of column number and time) maximum($stack->mv(1,0),($ret=null)); and calculating all the sums of sub-slices over the third dimension is now almost too easy # sums of pixels in time (assuming time is the third dim) sumover($stack->mv(2,0),($ret=null)); Finally, if you want to apply the operation to all elements (like max over all elements or sum over all elements) regardless of the dimensions of the piddle in question C comes in handy. As an example look at the definition of C (as defined in C): sub sum { PDL::Ufunc::sumover($name->clump(-1),($tmp=null)); return $tmp->at(); # return a Perl number, not a 0D piddle } We have already mentioned that all basic operations support threading and assignment is no exception. So here are a couple of threaded assignments pdl> $im = zeroes(byte, 10,20) pdl> $line = exp(-rvals(10)**2/9) # threaded assignment pdl> $im .= $line # set every line of $im to $line pdl> $im2 .= 5 # set every element of $im2 to 5 By now you probably see how it works and what it does, don't you? To finish the examples in this paragraph here is a function to create an RGB image from what is called a palette image. The palette image consists of two parts: an image of indices into a color lookup table and the color lookup table itself. [ describe how it works ] We are going to use a PP-function we haven't encoutered yet in the previous examples. It is the aptly named L function, signature C<((n),(),[o]())> (see B) with the core functionality that C will return the element with index 2 of the first input piddle. In this case, C<$ret> will contain the value 4. So here is the example: # a threaded index lookup to generate an RGB, or RGBA or YMCK image # from a palette image (represented by a lookup table $palette and # an color-index image $im) # you can say just dummy(0) since the rules of threading make it fit pdl> index($palette->xchg(0,1), $im->long->dummy(0,($palette->dim)[0]), ($res=null)); Let's go through it and explain the steps involved. Assuming we are dealing with an RGB lookup-table $palette is of size C<(3,x)>. First we exchange the dimensions of the palette so that looping is done over the first dimension of C<$palette> (of size 3 that represent r, g, and b components). Now looking at C<$im>, we add a dummy dimension of size equal to the length of the number of components (in the case we are discussing here we could have just used the number 3 since we have 3 color components). We can use a dummy dimension since for red, green and blue color components we use the same index from the original image, e.g. assuming a certain pixel of C<$im> had the value 4 then the lookup should produce the triple [palette(0,4),palette(1,4),palette(2,4)] for the new red, green and blue components of the output image. Hopefully by now you have some sort of idea what the above piece of code is supposed to do (it is often actually quite complicated to describe in detail how a piece of threading code works; just go ahead and experiment a bit to get a better feeling for it). If you have read the threading rules carefully, then you might have noticed that we didn't have to explicitly state the size of the dummy dimension that we created for C<$im>; when we create it with size 1 (the default) the rules of threading make it automatically fit to the desired size (by rule R3, in our example the size would be 3 assuming a palette of size C<(3,x)>). Since situations like this do occur often in practice this is actually why rule R3 has been introduced (the part that makes dimensions of size 1 fit to the thread loop dim size). So we can just say pdl> index($palette->xchg(0,1),$im->long->dummy(0),($res=null)); Again, you can convince yourself that this routine will create the right output if called with a pixel (C<$im> is 0D), a line (C<$im> is 1D), an image (C<$im> is 2D), ..., an RGB lookup table (palette is C<(3,x)>) and RGBA lookup table (palette is C<(4,x)>, see e.g. OpenGL). This flexibility is achieved by the rules of threading which are made to do the right thing in most situations. To wrap it all up once again, the general idea is as follows. If you want to achieve looping over certain dimensions and have the I applied to another specified set of dimensions you use the dimension manipulating commands to create a (or several) I piddle(s) so that from the point of view of the I piddle(s) you get what you want (always having the signature of the function in question and R1-R5 in mind!). Easy, isn't it ? =head2 Output auto-creation and PP-function calling conventions At this point we have to divert to some technical detail that has to do with the general calling conventions of PP-functions and the automatic creation of output arguments. Basically, there are two ways of invoking PDL routines, namely $result = func($a,$b); and func($a,$b,$result); If you are only using implicit threading then the output variable can be automatically created by PDL. You flag that to the PP-function by setting the output argument to a special kind of piddle that is returned from a call to the function Cnull> that returns an essentially "empty" piddle (for those interested in details there is a flag in the C pdl structure for this). The dimensions of the created piddle are determined by the rules of implicit threading: the first dimensions are the core output dimensions to which the threading dimensions are appended (which are in turn determined by the dimensions of the input piddles as described above). So you can say func($a,$b,($result=PDL->null)); or $result = func($a,$b) which are B equivalent. Be warned that you can I use output auto-creation when using explicit threading (for reasons explained in the following section on B, the second variant of threading). In "tight" loops you probably want to avoid the implicit creation of a temporary piddle in each step of the loop that comes along with the "functional" style but rather say # create output piddle of appropriate size only at first invocation $result = null; for (0...$n) { func($a,$b,$result); # in all but the first invocation $result func2($b); # is defined and has the right size to # take the output provided $b's dims don't change twiddle($result,$a); # do something from $result to $a for iteration } The take-home message of this section once more: be aware of the limitation on output creation when using B. =head2 Explicit threading Having so far only talked about the first flavour of threading it is now about time to introduce the second variant. Instead of shuffling around dimensions all the time and relying on the rules of implicit threading to get it all right you sometimes might want to specify in a more explicit way how to perform the thread loop. It is probably not too surprising that this variant of the game is called I. Now, before we create the wrong impression: it is not either I or I; the two flavours do mix. But more about that later. The two most used functions with explicit threading are L and L. We start with an example that illustrates typical usage of the former: [ # ** this is the worst possible example to start with ] # but can be used to show that $mat += $line is different from # $mat->thread(0) += $line # explicit threading to add a vector to each column of a matrix pdl> $mat = zeroes(4,3) pdl> $line = pdl (3.1416,2,-2) pdl> ($tmp = $mat->thread(0)) += $line In this example, C<$mat-Ethread(0)> tells PDL that you want the second dimension of this piddle to be threaded over first leading to a thread loop that can be expressed as for (j=0; j<3; j++) { for (i=0; i<4; i++) { mat(i,j) += src(j); } } C takes a list of numbers as arguments which explicitly specify which dimensions to thread over first. With the introduction of explicit threading the dimensions of a piddle are conceptually split into three different groups the latter two of which we have already encountered: thread dimensions, core dimensions and extra dimensions. Conceptually, it is best to think of those dimensions of a piddle that have been specified in a call to C as being taken away from the set of normal dimensions and put on a separate stack. So assuming we have a piddle C saying $b = $a->thread(2,1) creates a new virtual piddle of dimension C (which we call the remaining dims) that also has 2 thread dimensions of size C<(2,7)>. For the purposes of this document we write that symbolically as C. An important difference to the previous examples where only implicit threading was used is the fact that the core dimensions are matched against the I which are not necessarily the first dimensions of the piddle. We will now specify how the presence of thread dimensions changes the rules R1-R5 for thread loops (which apply to the special case where none of the piddle arguments has any thread dimensions). =over 4 =item T0 Core dimensions are matched against the first n I of the piddle argument (note the difference to R1). Any further I are I and are used to determine the I. =item T1a The number of I is equal to the maximal number of extra dimensions taken over the set of piddle arguments. =item T1b The number of I is equal to the maximal number of thread dimensions taken over the set of piddle arguments. =item T1c The total number of I is equal to the sum of I and I. In the thread loop, I are threaded over first followed by I. =item T2 The size of each of the I is derived from the size of the respective dimensions of the piddle arguments. It is given by the maximal size found in any piddles having this thread dimension (for I) or extra dimension (for I). =item T3 This rule applies to any I as well as any I. For all piddles that have a given I the size must be equal to the size of the respective I or 1; otherwise you raise a runtime exception. If the size of a I of a piddle is one it is implicitly treated as a dummy dimension of size equal to the I. =item T4 If a piddle doesn't have a I that corresponds to an I, in the thread loop this piddle is treated as if having a dummy dimension of size equal to the size of that loop dimension. =item T4a All piddles that do have I must have the same number of thread dimensions. =item T5 Output auto-creation cannot be used if any of the piddle arguments has any I. Otherwise R5 applies. =back The same restrictions apply with regard to implicit dummy dimensions (created by application of T4) as already mentioned in the section on implicit threading: if any of the output piddles has an (explicit or implicitly created) greater-than-one dummy dimension a runtime exception will be raised. Let us demonstrate these rules at work in a generic case. Suppose we have a (here unspecified) PP-function with the signature: func((m,n),(m),(),[o](m)) and you call it with 3 piddles C, C, C and an output piddle C (which can here I be automatically created) as func($a->thread(1,3),$b->thread(0,3),$c,$d->thread(0,1)) From the signature of func and the above call the piddles split into the following groups of core, extra and thread dimensions (written in the form C): a(5,10){3,11}[] b(5){3,1}[10,12] c(){}[10] d(5){3,11}[10,12] With this to help us along (it is in general helpful to write the arguments down like this when you start playing with threading and want to keep track of what is going on) we further deduce that the number of explicit loop dimensions is 2 (by T1b from C<$a> and C<$b>) with sizes C<(3,11)> (by T2); 2 implicit loop dimensions (by T1a from C<$b> and C<$d>) of size C<(10,12)> (by T2) and the elements of are computed from the input piddles in a way that can be expressed in pdl pseudo-code as for (l=0;l<12;l++) for (k=0;k<10;k++) for (j=0;j<11;j++) effect of treating it as dummy dim (index j) for (i=0;i<3;i++) | d(i,j,:,k,l) = func(a(:,i,:,j),b(i,:,k,0,l),c(k)) Ugh, this example was really not easy in terms of bookkeeping. It serves mostly as an example how to figure out what's going on when you encounter a complicated looking expression. But now it is really time to show that threading is useful by giving some more of our so called "practical" examples. [ The following examples will need some additional explanations in the future. For the moment please try to live with the comments in the code fragments. ] Example 1: *** inverse of matrix represented by eigvecs and eigvals ** given a symmetrical matrix M = A^T x diag(lambda_i) x A ** => inverse M^-1 = A^T x diag(1/lambda_i) x A ** first $tmp = diag(1/lambda_i)*A ** then A^T * $tmp by threaded inner product # index handling so that matrices print correct under pdl $inv .= $evecs*0; # just copy to get appropriately sized output $tmp .= $evecs; # initialise, no back-propagation ($tmp2 = $tmp->thread(0)) /= $evals; # threaded division # and now a matrix multiplication in disguise PDL::Primitive::inner($evecs->xchg(0,1)->thread(-1,1), $tmp->thread(0,-1), $inv->thread(0,1)); # alternative for matrix mult using implicit threading, # first xchg only for transpose PDL::Primitive::inner($evecs->xchg(0,1)->dummy(1), $tmp->xchg(0,1)->dummy(2), ($inv=null)); Example 2: # outer product by threaded multiplication # stress that we need to do it with explicit call to my_biop1 # when using explicit threading $res=zeroes(($a->dims)[0],($b->dims)[0]); my_biop1($a->thread(0,-1),$b->thread(-1,0),$res->(0,1),"*"); # similar thing by implicit threading with auto-created piddle $res = $a->dummy(1) * $b->dummy(0); Example 3: # different use of thread and unthread to shuffle a number of # dimensions in one go without lots of calls to ->xchg and ->mv # use thread/unthread to shuffle dimensions around # just try it out and compare the child piddle with its parent $trans = $a->thread(4,1,0,3,2)->unthread; Example 4: # calculate a couple of bounding boxes # $bb will hold BB as [xmin,xmax],[ymin,ymax],[zmin,zmax] # we use again thread and unthread to shuffle dimensions around pdl> $bb = zeroes(double, 2,3 ); pdl> minimum($vertices->thread(0)->clump->unthread(1), $bb->slice('(0),:')); pdl> maximum($vertices->thread(0)->clump->unthread(1), $bb->slice('(1),:')); Example 5: # calculate a self-rationed (i.e. self normalized) sequence of images # uses explicit threading and an implicitly threaded division $stack = read_image_stack(); # calculate the average (per pixel average) of the first $n+1 images $aver = zeroes([stack->dims]->[0,1]); # make the output piddle sumover($stack->slice(":,:,0:$n")->thread(0,1),$aver); $aver /= ($n+1); $stack /= $aver; # normalize the stack by doing a threaded division # implicit versus explicit # alternatively calculate $aver with implicit threading and auto-creation sumover($stack->slice(":,:,0:$n")->mv(2,0),($aver=null)); $aver /= ($n+1); # =head2 Implicit versus explicit threading In this paragraph we are going to illustrate when explicit threading is preferable over implicit threading and vice versa. But then again, this is probably not the best way of putting the case since you already know: the two flavours do mix. So, it's more about how to get the best of both worlds and, anyway, in the best of Perl traditions: TIMTOWTDI ! [ Sorry, this still has to be filled in in a later release; either refer to above examples or choose some new ones ] Finally, this may be a good place to justify all the technical detail we have been going on about for a couple of pages: why threading ? Well, code that uses threading should be (considerably) faster than code that uses explicit for-loops (or similar Perl constructs) to achieve the same functionality. Especially on supercomputers (with vector computing facilities/parallel processing) PDL threading will be implemented in a way that takes advantage of the additional facilities of these machines. Furthermore, it is a conceptually simply construct (though technical details might get involved at times) and can I reduce the syntactical complexity of PDL code (but keep the admonition for documentation in mind). Once you are comfortable with the I way of thinking (and coding) it shouldn't be too difficult to understand code that somebody else has written than (provided he gave you an idea what expected input dimensions are, etc.). As a general tip to increase the performance of your code: if you have to introduce a loop into your code try to reformulate the problem so that you can use threading to perform the loop (as with anything there are exceptions to this rule of thumb; but the authors of this document tend to think that these are rare cases ;). =head1 PDL::PP =head2 An easy way to define functions that are aware of indexing and threading (and the universe and everything) PDL:PP is part of the PDL distribution. It is used to generate functions that are aware of indexing and threading rules from very concise descriptions. It can be useful for you if you want to write your own functions or if you want to interface functions from an external library so that they support indexing and threading (and maybe dataflow as well, see L). For further details check L. =head1 Appendix A =head2 Affine transformations - a special class of simple and powerful transformations [ This is also something to be added in future releases. Do we already have the general make_affine routine in PDL ? It is possible that we will reference another appropriate man page from here ] =head1 Appendix B =head2 signatures of standard PDL::PP compiled functions A selection of signatures of PDL primitives to show how many dimensions PP compiled functions gobble up (and therefore you can figure out what will be threaded over). Most of those functions are the basic ones defined in C # functions in primitive.pd # sumover ((n),[o]()) prodover ((n),[o]()) axisvalues ((n)) inplace inner ((n),(n),[o]()) outer ((n),(m),[o](n,m)) innerwt ((n),(n),(n),[o]()) inner2 ((m),(m,n),(n),[o]()) inner2t ((j,n),(n,m),(m,k),[o]()) index (1D,0D,[o]) minimum (1D,[o]) maximum (1D,[o]) wstat ((n),(n),(),[o],()) assgn ((),()) # basic operations binary operations ((),(),[o]()) unary operations ((),[o]()) =head1 AUTHOR & COPYRIGHT Copyright (C) 1997 Christian Soeller (c.soeller@auckland.ac.nz) & Tuomas J. Lukka (lukka@fas.harvard.edu). All rights reserved. Although destined for release as a man page with the standard PDL distribution, it is not public domain. Permission is granted to freely distribute verbatim copies of this document provided that no modifications outside of formatting be made, and that this notice remain intact. You are permitted and encouraged to use its code and derivatives thereof in your own source code for fun or for profit as you see fit. PDL-2.018/Basic/Pod/Internals.pod0000644060175006010010000005157513036512174014621 0ustar chmNone=head1 NAME PDL::Internals - description of some aspects of the current internals =head1 DESCRIPTION =head2 Intro This document explains various aspects of the current implementation of PDL. If you just want to use PDL for something, you definitely do not need to read this. Even if you want to interface your C routines to PDL or create new L functions, you do not need to read this man page (though it may be informative). This document is primarily intended for people interested in debugging or changing the internals of PDL. To read this, a good understanding of the C language and programming and data structures in general is required, as well as some Perl understanding. If you read through this document and understand all of it and are able to point what any part of this document refers to in the PDL core sources and additionally struggle to understand L, you will be awarded the title "PDL Guru" (of course, the current version of this document is so incomplete that this is next to impossible from just these notes). B If it seems that this document has gotten out of date, please inform the PDL porters email list (pdl-devel@lists.sourceforge.net). This may well happen. =head2 Piddles The pdl data object is generally an opaque scalar reference into a pdl structure in memory. Alternatively, it may be a hash reference with the C field containing the scalar reference (this makes overloading piddles easy, see L). You can easily find out at the Perl level which type of piddle you are dealing with. The example code below demonstrates how to do it: # check if this a piddle die "not a piddle" unless UNIVERSAL::isa($pdl, 'PDL'); # is it a scalar ref or a hash ref? if (UNIVERSAL::isa($pdl, "HASH")) { die "not a valid PDL" unless exists $pdl->{PDL} && UNIVERSAL::isa($pdl->{PDL},'PDL'); print "This is a hash reference,", " the PDL field contains the scalar ref\n"; } else { print "This is a scalar ref that points to address $$pdl in memory\n"; } The scalar reference points to the numeric address of a C structure of type C which is defined in F. The mapping between the object at the Perl level and the C structure containing the actual data and structural that makes up a piddle is done by the PDL typemap. The functions used in the PDL typemap are defined pretty much at the top of the file F. So what does the structure look like: struct pdl { unsigned long magicno; /* Always stores PDL_MAGICNO as a sanity check */ /* This is first so most pointer accesses to wrong type are caught */ int state; /* What's in this pdl */ pdl_trans *trans; /* Opaque pointer to internals of transformation from parent */ pdl_vaffine *vafftrans; void* sv; /* (optional) pointer back to original sv. ALWAYS check for non-null before use. We cannot inc refcnt on this one or we'd never get destroyed */ void *datasv; /* Pointer to SV containing data. Refcnt inced */ void *data; /* Null: no data alloced for this one */ PDL_Indx nvals; /* How many values allocated */ int datatype; PDL_Indx *dims; /* Array of data dimensions */ PDL_Indx *dimincs; /* Array of data default increments */ short ndims; /* Number of data dimensions */ unsigned char *threadids; /* Starting index of the thread index set n */ unsigned char nthreadids; pdl_children children; PDL_Indx def_dims[PDL_NDIMS]; /* Preallocated space for efficiency */ PDL_Indx def_dimincs[PDL_NDIMS]; /* Preallocated space for efficiency */ unsigned char def_threadids[PDL_NTHREADIDS]; struct pdl_magic *magic; void *hdrsv; /* "header", settable from outside */ }; This is quite a structure for just storing some data in - what is going on? =over 5 =item Data storage We are going to start with some of the simpler members: first of all, there is the member void *datasv; which is really a pointer to a Perl SV structure (C). The SV is expected to be representing a string, in which the data of the piddle is stored in a tightly packed form. This pointer counts as a reference to the SV so the reference count has been incremented when the C was placed here (this reference count business has to do with Perl's garbage collection mechanism -- don't worry if this doesn't mean much to you). This pointer is allowed to have the value C which means that there is no actual Perl SV for this data - for instance, the data might be allocated by a C operation. Note the use of an SV* was purely for convenience, it allows easy transformation of packed data from files into piddles. Other implementations are not excluded. The actual pointer to data is stored in the member void *data; which contains a pointer to a memory area with space for PDL_Indx nvals; data items of the data type of this piddle. PDL_Indx is either 'long' or 'long long' depending on whether your perl is 64bit or not. The data type of the data is stored in the variable int datatype; the values for this member are given in the enum C (see F). Currently we have byte, short, unsigned short, long, float and double types, see also L. =item Dimensions The number of dimensions in the piddle is given by the member int ndims; which shows how many entries there are in the arrays PDL_Indx *dims; PDL_Indx *dimincs; These arrays are intimately related: C gives the sizes of the dimensions and C is always calculated by the code PDL_Indx inc = 1; for(i=0; indims; i++) { it->dimincs[i] = inc; inc *= it->dims[i]; } in the routine C in C. What this means is that the dimincs can be used to calculate the offset by code like PDL_Indx offs = 0; for(i=0; indims; i++) { offs += it->dimincs[i] * index[i]; } but this is not always the right thing to do, at least without checking for certain things first. =item Default storage Since the vast majority of piddles don't have more than 6 dimensions, it is more efficient to have default storage for the dimensions and dimincs inside the PDL struct. PDL_Indx def_dims[PDL_NDIMS]; PDL_Indx def_dimincs[PDL_NDIMS]; The C and C may be set to point to the beginning of these arrays if C is smaller than or equal to the compile-time constant C. This is important to note when freeing a piddle struct. The same applies for the threadids: unsigned char def_threadids[PDL_NTHREADIDS]; =item Magic It is possible to attach magic to piddles, much like Perl's own magic mechanism. If the member pointer struct pdl_magic *magic; is nonzero, the PDL has some magic attached to it. The implementation of magic can be gleaned from the file F in the distribution. =item State One of the first members of the structure is int state; The possible flags and their meanings are given in C. These are mainly used to implement the lazy evaluation mechanism and keep track of piddles in these operations. =item Transformations and virtual affine transformations As you should already know, piddles often carry information about where they come from. For example, the code $b = $a->slice("2:5"); $b .= 1; will alter $a. So C<$b> and C<$a> I that they are connected via a C-transformation. This information is stored in the members pdl_trans *trans; pdl_vaffine *vafftrans; Both C<$a> (the I) and C<$b> (the child) store this information about the transformation in appropriate slots of the C structure. C and C are structures that we will look at in more detail below. =item The Perl SVs When piddles are referred to through Perl SVs, we store an additional reference to it in the member void* sv; in order to be able to return a reference to the user when he wants to inspect the transformation structure on the Perl side. Also, we store an opaque void *hdrsv; which is just for use by the user to hook up arbitrary data with this sv. This one is generally manipulated through L and L calls. =back =head2 Smart references and transformations: slicing and dicing Smart references and most other fundamental functions operating on piddles are implemented via I (as mentioned above) which are represented by the type C in PDL. A transformation links input and output piddles and contains all the infrastructure that defines how: =over 4 =item * output piddles are obtained from input piddles; =item * changes in smartly linked output piddles (e.g. the I of a sliced I piddle) are flown back to the input piddle in transformations where this is supported (the most often used example being C here); =item * datatype and size of output piddles that need to be created are obtained. =back In general, executing a PDL function on a group of piddles results in creation of a transformation of the requested type that links all input and output arguments (at least those that are piddles). In PDL functions that support data flow between input and output args (e.g. C, C) this transformation links I (input) and I (output) piddles permanently until either the link is explicitly broken by user request (C at the Perl level) or all parents and children have been destroyed. In those cases the transformation is lazy-evaluated, e.g. only executed when piddle values are actually accessed. In I functions, for example addition (C<+>) and inner products (C), the transformation is installed just as in flowing functions but then the transformation is immediately executed and destroyed (breaking the link between input and output args) before the function returns. It should be noted that the close link between input and output args of a flowing function (like L) requires that piddle objects that are linked in such a way be kept alive beyond the point where they have gone out of scope from the point of view of Perl: $a = zeroes(20); $b = $a->slice('2:4'); undef $a; # last reference to $a is now destroyed Although $a should now be destroyed according to Perl's rules the underlying C structure must actually only be freed when C<$b> also goes out of scope (since it still references internally some of C<$a>'s data). This example demonstrates that such a dataflow paradigm between PDL objects necessitates a special destruction algorithm that takes the links between piddles into account and couples the lifespan of those objects. The non-trivial algorithm is implemented in the function C in F. In fact, most of the code in F and F is concerned with making sure that piddles (Cs) are created, updated and freed at the right times depending on interactions with other piddles via PDL transformations (remember, C). =head2 Accessing children and parents of a piddle When piddles are dynamically linked via transformations as suggested above input and output piddles are referred to as parents and children, respectively. An example of processing the children of a piddle is provided by the C method of PDL::Bad (only available if you have compiled PDL with the C option set to 1, but still useful as an example!). Consider the following situation: pdl> $a = rvals(7,7,{Centre=>[3,4]}); pdl> $b = $a->slice('2:4,3:5'); pdl> ? vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $a Double D [7,7] P 0.38Kb $b Double D [3,3] -C 0.00Kb Now, if I suddenly decide that C<$a> should be flagged as possibly containing bad values, using pdl> $a->badflag(1) then I want the state of C<$b> - it's I - to be changed as well (since it will either share or inherit some of C<$a>'s data and so be also I), so that I get a 'B' in the I field: pdl> ? vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $a Double D [7,7] PB 0.38Kb $b Double D [3,3] -CB 0.00Kb This bit of magic is performed by the C function, which is listed below: /* newval = 1 means set flag, 0 means clear it */ /* thanks to Christian Soeller for this */ void propagate_badflag( pdl *it, int newval ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) { pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); int i; for( i = trans->vtable->nparents; i < trans->vtable->npdls; i++ ) { pdl *child = trans->pdls[i]; if ( newval ) child->state |= PDL_BADVAL; else child->state &= ~PDL_BADVAL; /* make sure we propagate to grandchildren, etc */ propagate_badflag( child, newval ); } /* for: i */ } PDL_END_CHILDLOOP(it) } /* propagate_badflag */ Given a piddle (C), the routine loops through each C structure, where access to this structure is provided by the C macro. The I of the piddle are stored in the C array, after the I, hence the loop from C to C. Once we have the pointer to the child piddle, we can do what we want to it; here we change the value of the C variable, but the details are unimportant). What B important is that we call C on this piddle, to ensure we loop through its children. This recursion ensures we get to all the I of a particular piddle. Access to I is similar, with the C loop replaced by: for( i = 0; i < trans->vtable->nparents; i++ ) { /* do stuff with parent #i: trans->pdls[i] */ } =head2 What's in a transformation (C) All transformations are implemented as structures struct XXX_trans { int magicno; /* to detect memory overwrites */ short flags; /* state of the trans */ pdl_transvtable *vtable; /* the all important vtable */ void (*freeproc)(struct pdl_trans *); /* Call to free this trans (in case we had to malloc some stuff for this trans) */ pdl *pdls[NP]; /* The pdls involved in the transformation */ int __datatype; /* the type of the transformation */ /* in general more members /* depending on the actual transformation (slice, add, etc) */ }; The transformation identifies all Cs involved in the trans pdl *pdls[NP]; with C depending on the number of piddle args of the particular trans. It records a state short flags; and the datatype int __datatype; of the trans (to which all piddles must be converted unless they are explicitly typed, PDL functions created with L make sure that these conversions are done as necessary). Most important is the pointer to the vtable (virtual table) that contains the actual functionality pdl_transvtable *vtable; The vtable structure in turn looks something like (slightly simplified from F for clarity) typedef struct pdl_transvtable { pdl_transtype transtype; int flags; int nparents; /* number of parent pdls (input) */ int npdls; /* number of child pdls (output) */ char *per_pdl_flags; /* optimization flags */ void (*redodims)(pdl_trans *tr); /* figure out dims of children */ void (*readdata)(pdl_trans *tr); /* flow parents to children */ void (*writebackdata)(pdl_trans *tr); /* flow backwards */ void (*freetrans)(pdl_trans *tr); /* Free both the contents and it of the trans member */ pdl_trans *(*copy)(pdl_trans *tr); /* Full copy */ int structsize; char *name; /* For debuggers, mostly */ } pdl_transvtable; We focus on the callback functions: void (*redodims)(pdl_trans *tr); C will work out the dimensions of piddles that need to be created and is called from within the API function that should be called to ensure that the dimensions of a piddle are accessible (F): void pdl_make_physdims(pdl *it) C and C are responsible for the actual computations of the child data from the parents or parent data from those of the children, respectively (the dataflow aspect). The PDL core makes sure that these are called as needed when piddle data is accessed (lazy-evaluation). The general API function to ensure that a piddle is up-to-date is void pdl_make_physvaffine(pdl *it) which should be called before accessing piddle data from XS/C (see F for some examples). C frees dynamically allocated memory associated with the trans as needed and C can copy the transformation. Again, functions built with L make sure that copying and freeing via these callbacks happens at the right times. (If they fail to do that we have got a memory leak -- this has happened in the past ;). The transformation and vtable code is hardly ever written by hand but rather generated by L from concise descriptions. Certain types of transformations can be optimized very efficiently obviating the need for explicit C and C methods. Those transformations are called I. Most dimension manipulating functions (e.g., C, C) belong to this class. The basic trick is that parent and child of such a transformation work on the same (shared) block of data which they just choose to interpret differently (by using different C, C and C on the same data, compare the C structure above). Each operation on a piddle sharing data with another one in this way is therefore automatically flown from child to parent and back -- after all they are reading and writing the same block of memory. This is currently not Perl thread safe -- no big loss since the whole PDL core is not reentrant (Perl threading C PDL threading!). =head2 Signatures: threading over elementary operations Most of that functionality of PDL threading (automatic iteration of elementary operations over multi-dim piddles) is implemented in the file F. The L generated functions (in particular the C and C callbacks) use this infrastructure to make sure that the fundamental operation implemented by the trans is performed in agreement with PDL's threading semantics. =head2 Defining new PDL functions -- Glue code generation Please, see L and examples in the PDL distribution. Implementation and syntax are currently far from perfect but it does a good job! =head2 The Core struct As discussed in L, PDL uses a pointer to a structure to allow PDL modules access to its core routines. The definition of this structure (the C struct) is in F (created by F in F) and looks something like /* Structure to hold pointers core PDL routines so as to be used by * many modules */ struct Core { I32 Version; pdl* (*SvPDLV) ( SV* ); void (*SetSV_PDL) ( SV *sv, pdl *it ); #if defined(PDL_clean_namespace) || defined(PDL_OLD_API) pdl* (*new) ( ); /* make it work with gimp-perl */ #else pdl* (*pdlnew) ( ); /* renamed because of C++ clash */ #endif pdl* (*tmp) ( ); pdl* (*create) (int type); void (*destroy) (pdl *it); ... } typedef struct Core Core; The first field of the structure (C) is used to ensure consistency between modules at run time; the following code is placed in the BOOT section of the generated xs code: if (PDL->Version != PDL_CORE_VERSION) Perl_croak(aTHX_ "Foo needs to be recompiled against the newly installed PDL"); If you add a new field to the F struct you should: =over 5 =item * discuss it on the pdl porters email list (pdl-devel@lists.sourceforge.net) [with the possibility of making your changes to a separate branch of the CVS tree if it's a change that will take time to complete] =item * increase by 1 the value of the C<$pdl_core_version> variable in F. This sets the value of the C C macro used to populate the Version field =item * add documentation (e.g. to L) if it's a "useful" function for external module writers (as well as ensuring the code is as well documented as the rest of PDL ;) =back =head1 BUGS This description is far from perfect. If you need more details or something is still unclear please ask on the pdl-devel mailing list (pdl-devel@lists.sourceforge.net). =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu), 2000 Doug Burke (djburke@cpan.org), 2002 Christian Soeller & Doug Burke, 2013 Chris Marshall. Redistribution in the same form is allowed but reprinting requires a permission from the author. PDL-2.018/Basic/Pod/Makefile.PL0000644060175006010010000000167012562522363014123 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pods = map { $_=~s/.pod//; $_ } grep { ! m/Index.pod/ } glob("*.pod"); # do we want to create PP-Inline? eval 'require Pod::Select'; if (!$@) { push @pods, 'PP-Inline' unless grep {/PP-Inline/} @pods; } my @man1 = map { $_.".pod", '$(INST_MAN1DIR)/PDL::' . $_ . '.$(MAN1EXT)' } @pods; my @pms = map { $_.".pod", '$(INST_LIBDIR)/' . $_ .".pod"} @pods; undef &MY::postamble; # suppress warning *MY::postamble = sub { my $text = ''; eval 'require Pod::Select'; if (!$@) { $text .= << "EOPS" ; PP-Inline.pod: ../Gen/Inline/Pdlpp.pm \t\$(PERLRUN) -MPod::Select -e "podselect('../Gen/Inline/Pdlpp.pm');" > PP-Inline.pod EOPS } $text; }; WriteMakefile( 'NAME' => 'PDL::pod', 'MAN1PODS' => { @man1 }, 'MAN3PODS' => { }, 'PM' => { @pms }, 'clean' => {FILES => "PP-Inline.pod"}, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Basic/Pod/MATLAB.pod0000644060175006010010000005672612562522363013631 0ustar chmNone=head1 NAME PDL::MATLAB - A guide for MATLAB users. =head1 INTRODUCTION If you are a MATLAB user, this page is for you. It explains the key differences between MATLAB and PDL to help you get going as quickly as possible. B. For that, go to L. This document B the Quick Start guide, as it highlights the key differences between MATLAB and PDL. =head1 Perl The key difference between MATLAB and PDL is B. Perl is a general purpose programming language with thousands of modules freely available on the web. PDL is an extension of Perl. This gives PDL programs access to more features than most numerical tools can dream of. At the same time, most syntax differences between MATLAB and PDL are a result of its Perl foundation. B. But if you wish to learn Perl, there is excellent documentation available on-line (L) or through the command C. There is also a beginner's portal (L). Perl's module repository is called CPAN (L) and it has a vast array of modules. Run C for more information. =head1 TERMINOLOGY: PIDDLE MATLAB typically refers to vectors, matrices, and arrays. Perl already has arrays, and the terms "vector" and "matrix" typically refer to one- and two-dimensional collections of data. Having no good term to describe their object, PDL developers coined the term "I" to give a name to their data type. A I consists of a series of numbers organized as an N-dimensional data set. Piddles provide efficient storage and fast computation of large N-dimensional matrices. They are highly optimized for numerical work. For more information, see "B" later in this document. =head1 COMMAND WINDOW AND IDE Unlike MATLAB, PDL does not come with a dedicated IDE. It does however come with an interactive shell and you can use a Perl IDE to develop PDL programs. =head2 PDL interactive shell To start the interactive shell, open a terminal and run C or C. As in MATLAB, the interactive shell is the best way to learn the language. To exit the shell, type C, just like MATLAB. =head2 Writing PDL programs One popular IDE for Perl is called Padre (L). It is cross platform and easy to use. Whenever you write a stand-alone PDL program (i.e. outside the C or C shell) you must start the program with C. This command imports the PDL module into Perl. Here is a sample PDL program: use PDL; # Import main PDL module. use PDL::NiceSlice; # Import additional PDL module. use PDL::AutoLoader; # Import additional PDL module. $b = pdl [2,3,4]; # Statements end in semicolon. $A = pdl [ [1,2,3],[4,5,6] ]; # 2-dimensional matrix. print $A x $b->transpose; Save this file as C and run it with: perl myprogram.pl =head2 New: Flexible syntax In current versions of PDL (version 2.4.7 or later) there is a flexible matrix syntax that can look extremely similar to MATLAB: 1) Use a ';' to delimit rows: $b = pdl q[ 2,3,4 ]; $A = pdl q[ 1,2,3 ; 4,5,6 ]; 2) Use spaces to separate elements: $b = pdl q[ 2 3 4 ]; $A = pdl q[ 1 2 3 ; 4 5 6 ]; Basically, as long as you put a C in front of the opening bracket, PDL should "do what you mean". So you can write in a syntax that is more comfortable for you. =head1 MODULES FOR MATLAB USERS There are two modules that MATLAB users will want to use: =over 5 =item L Gives PDL a syntax for slices (sub-matrices) that is shorter and more familiar to MATLAB users. % MATLAB b(1:5) --> Selects the first 5 elements from b. # PDL without NiceSlice $b->slice("0:4") --> Selects the first 5 elements from $b. # PDL with NiceSlice $b(0:4) --> Selects the first 5 elements from $b. =item L Provides a MATLAB-style autoloader for PDL. If an unknown function C is called, PDL looks for a file called C. If it finds one, it reads it. =back =head1 BASIC FEATURES This section explains how PDL's syntax differs from MATLAB. Most MATLAB users will want to start here. =head2 General "gotchas" =over 5 =item Indices In PDL, indices start at '0' (like C and Java), not 1 (like MATLAB or FORTRAN). For example, if C<$b> is an array with 5 elements, the elements would be numbered from 0 to 4. =item Displaying an object MATLAB normally displays object contents automatically. In the PDL shells you display objects explicitly with the C command or the shortcut C

and C because the user may have sent piddles with extra threading dimensions. Of course, the temporary piddle C (note the [t] flag) should not be given any thread dimensions anyway. You can also use C to set the dimension of a piddle flagged with [o]. In this case you set the dimensions for the named dimension in the signature using $SIZE() as in the preceding example. However, because the piddle is flagged with [o] instead of [t], threading dimensions will be added if required just as if the size of the dimension were computed from the signature according to the usual rules. Here is an example from PDL::Math pp_def("polyroots", Pars => 'cr(n); ci(n); [o]rr(m); [o]ri(m);', RedoDimsCode => 'PDL_Indx sn = $PDL(cr)->dims[0]; $SIZE(m) = sn-1;', The input piddles are the real and imaginary parts of complex coefficients of a polynomial. The output piddles are real and imaginary parts of the roots. There are C roots to an Cth order polynomial and such a polynomial has C coefficients (the zeoreth through the Cth). In this example, threading will work correctly. That is, the first dimension of the output piddle with have its dimension adjusted, but other threading dimensions will be assigned just as if there were no C. =head2 Typemap handling in the C section The C section discussed above is very often absolutely crucial when you interface external libraries with PDL. However in many cases the external libraries either use derived types or pointers of various types. The standard way to handle this in Perl is to use a C file. This is discussed in some detail in L in the standard Perl documentation. In PP the functionality is very similar, so you can create a C file in the directory where your PP file resides and when it is built it is automatically read in to figure out the appropriate translation between the C type and Perl's built-in type. That said, there are a couple of important differences from the general handling of types in XS. The first, and probably most important, is that at the moment pointers to types are not allowed in the C section. To get around this limitation you must use the C type (thanks to Judd Taylor for pointing out that this is necessary for portability). It is probably best to illustrate this with a couple of code-snippets: For instance the C function has the following C declaration: int gsl_spline_init(gsl_spline * spline, const double xa[], const double ya[], size_t size); Clearly the C and C arrays are candidates for being passed in as piddles and the C argument is just the length of these piddles so that can be handled by the C<$SIZE()> macro in PP. The problem is the pointer to the C type. The natural solution would be to write an C declaration of the form OtherPars => 'gsl_spline *spl' and write a short C file which handled this type. This does not work at present however! So what you have to do is to go around the problem slightly (and in some ways this is easier too!): The solution is to declare C in the C section using an "Integer Value", C. This hides the nature of the variable from PP and you then need to (well to avoid compiler warnings at least!) perform a type cast when you use the variable in your code. Thus C should take the form: OtherPars => 'IV spl' and when you use it in the code you will write INT2PTR(gsl_spline *, $COMP(spl)) where the Perl API macro C has been used to handle the pointer cast to avoid compiler warnings and problems for machines with mixed 32bit and 64bit Perl configurations. Putting this together as Andres Jordan has done (with the modification using C by Judd Taylor) in the C in the distribution source you get: pp_def('init_meat', Pars => 'double x(n); double y(n);', OtherPars => 'IV spl', Code =>' gsl_spline_init,( INT2PTR(gsl_spline *, $COMP(spl)), $P(x),$P(y),$SIZE(n)));' ); where I have removed a macro wrapper call, but that would obscure the discussion. The other minor difference as compared to the standard typemap handling in Perl, is that the user cannot specify non-standard typemap locations or typemap filenames using the C option in MakeMaker... Thus you can only use a file called C and/or the C trick above. =head2 Other useful PP keys in data operation definitions You have already heard about the C key. Currently, there are not many other keys for a data operation that will be useful in normal (whatever that is) PP programming. In fact, it would be interesting to hear about a case where you think you need more than what is provided at the moment. Please speak up on one of the PDL mailing lists. Most other keys recognised by C are only really useful for what we call I (see also above). One thing that is strongly being planned is variable number of arguments, which will be a little tricky. An incomplete list of the available keys: =over 4 =item Inplace Setting this key marks the routine as working inplace - ie the input and output piddles are the same. An example is C<$a-Einplace-Esqrt()> (or C). =over 4 =item Inplace => 1 Use when the routine is a unary function, such as C. =item Inplace => ['a'] If there are more than one input piddles, specify the name of the one that can be changed inplace using an array reference. =item Inplace => ['a','b'] If there are more than one output piddle, specify the name of the input piddle and output piddle in a 2-element array reference. This probably isn't needed, but left in for completeness. =back If bad values are being used, care must be taken to ensure the propagation of the badflag when inplace is being used; consider this excerpt from F: pp_def('replacebad',HandleBad => 1, Pars => 'a(); [o]b();', OtherPars => 'double newval', Inplace => 1, CopyBadStatusCode => '/* propagate badflag if inplace AND it has changed */ if ( a == b && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( b, 0 ); /* always make sure the output is "good" */ $SETPDLSTATEGOOD(b); ', ... Since this routine removes all bad values, then the output piddle had its bad flag cleared. If run inplace (so C), then we have to tell all the children of C that the bad flag has been cleared (to save time we make sure that we call Cpropagate_badgflag> only if the input piddle had its bad flag set). NOTE: one idea is that the documentation for the routine could be automatically flagged to indicate that it can be executed inplace, ie something similar to how C sets C if it's not supplied (it's not an ideal solution). =back =head2 Other PDL::PP functions to support concise package definition So far, we have described the C and C functions. PDL::PP exports a few other functions to aid you in writing concise PDL extension package definitions. =head3 pp_addhdr Often when you interface library functions as in the above example you have to include additional C include files. Since the XS file is generated by PP we need some means to make PP insert the appropriate include directives in the right place into the generated XS file. To this end there is the C function. This is also the function to use when you want to define some C functions for internal use by some of the XS functions (which are mostly functions defined by C). By including these functions here you make sure that PDL::PP inserts your code before the point where the actual XS module section begins and will therefore be left untouched by xsubpp (cf. I and I man pages). A typical call would be pp_addhdr(' #include /* we need defs of XXXX */ #include "libprotos.h" /* prototypes of library functions */ #include "mylocaldecs.h" /* Local decs */ static void do_the real_work(PDL_Byte * in, PDL_Byte * out, int n) { /* do some calculations with the data */ } '); This ensures that all the constants and prototypes you need will be properly included and that you can use the internal functions defined here in the Cs, e.g.: pp_def('barfoo', Pars => ' a(n); [o] b(n)', GenericTypes => ['B'], Code => ' PDL_Indx ns = $SIZE(n); do_the_real_work($P(a),$P(b),ns); ', ); =head3 pp_addpm In many cases the actual PP code (meaning the arguments to C calls) is only part of the package you are currently implementing. Often there is additional Perl code and XS code you would normally have written into the pm and XS files which are now automatically generated by PP. So how to get this stuff into those dynamically generated files? Fortunately, there are a couple of functions, generally called C that assist you in doing this. Let's assume you have additional Perl code that should go into the generated B-file. This is easily achieved with the C command: pp_addpm(<<'EOD'); =head1 NAME PDL::Lib::Mylib -- a PDL interface to the Mylib library =head1 DESCRIPTION This package implements an interface to the Mylib package with full threading and indexing support (see L). =cut use PGPLOT; =head2 use_myfunc this function applies the myfunc operation to all the elements of the input pdl regardless of dimensions and returns the sum of the result =cut sub use_myfunc { my $pdl = shift; myfunc($pdl->clump(-1),($res=null)); return $res->sum; } EOD =head3 pp_add_exported You have probably got the idea. In some cases you also want to export your additional functions. To avoid getting into trouble with PP which also messes around with the C<@EXPORT> array you just tell PP to add your functions to the list of exported functions: pp_add_exported('use_myfunc gethynx'); =head3 pp_add_isa The C command works like the the C function. The arguments to C are added the @ISA list, e.g. pp_add_isa(' Some::Other::Class '); =head3 pp_bless If your pp_def routines are to be used as object methods use C to specify the package (i.e. class) to which your Ied methods will be added. For example, C. The default is C if this is omitted. =head3 pp_addxs Sometimes you want to add extra XS code of your own (that is generally not involved with any threading/indexing issues but supplies some other functionality you want to access from the Perl side) to the generated XS file, for example pp_addxs('',' # Determine endianness of machine int isbigendian() CODE: unsigned short i; PDL_Byte *b; i = 42; b = (PDL_Byte*) (void*) &i; if (*b == 42) RETVAL = 0; else if (*(b+1) == 42) RETVAL = 1; else croak("Impossible - machine is neither big nor little endian!!\n"); OUTPUT: RETVAL '); Especially C and C should be used with care. PP uses PDL::Exporter, hence letting PP export your function means that they get added to the standard list of function exported by default (the list defined by the export tag ``:Func''). If you use C you shouldn't try to do anything that involves threading or indexing directly. PP is much better at generating the appropriate code from your definitions. =head3 pp_add_boot Finally, you may want to add some code to the BOOT section of the XS file (if you don't know what that is check I). This is easily done with the C command: pp_add_boot(<descrip = descrip; GlobalStruc->maxfiles = 200; EOB =head3 pp_export_nothing By default, PP.pm puts all subs defined using the pp_def function into the output .pm file's EXPORT list. This can create problems if you are creating a subclassed object where you don't want any methods exported. (i.e. the methods will only be called using the $object->method syntax). For these cases you can call pp_export_nothing() to clear out the export list. Example (At the end of the .pd file): pp_export_nothing(); pp_done(); =head3 pp_core_importList By default, PP.pm puts the 'use Core;' line into the output .pm file. This imports Core's exported names into the current namespace, which can create problems if you are over-riding one of Core's methods in the current file. You end up getting messages like "Warning: sub sumover redefined in file subclass.pm" when running the program. For these cases the pp_core_importList can be used to change what is imported from Core.pm. For example: pp_core_importList('()') This would result in use Core(); being generated in the output .pm file. This would result in no names being imported from Core.pm. Similarly, calling pp_core_importList(' qw/ barf /') would result in use Core qw/ barf/; being generated in the output .pm file. This would result in just 'barf' being imported from Core.pm. =head3 pp_setversion I am pretty sure that this allows you to simultaneously set the .pm and .xs files' versions, thus avoiding unnecessary version-skew between the two. To use this, simply have the following line at some point in your .pd file: pp_setversion('0.0.3'); However, don't use this if you use L. See that module's documentation for details. =head3 pp_deprecate_module If a particular module is deemed obsolete, this function can be used to mark it as deprecated. This has the effect of emitting a warning when a user tries to C the module. The generated POD for this module also carries a deprecation notice. The replacement module can be passed as an argument like this: pp_deprecate_module( infavor => "PDL::NewNonDeprecatedModule" ); Note that function affects I the runtime warning and the POD. =head1 Making your PP function "private" Let's say that you have a function in your module called PDL::foo that uses the PP function C to do the heavy lifting. But you don't want to advertise that C exists. To do this, you must move your PP function to the top of your module file, then call pp_export_nothing() to clear the C list. To ensure that no documentation (even the default PP docs) is generated, set Doc => undef and to prevent the function from being added to the symbol table, set PMFunc => '' in your pp_def declaration (see Image2D.pd for an example). This will effectively make your PP function "private." However, it is I accessible via PDL::bar_pp due to Perl's module design. But making it private will cause the user to go very far out of his or her way to use it, so he or she shoulders the consequences! =head1 Slice operation The slice operation section of this manual is provided using dataflow and lazy evaluation: when you need it, ask Tjl to write it. a delivery in a week from when I receive the email is 95% probable and two week delivery is 99% probable. And anyway, the slice operations require a much more intimate knowledge of PDL internals than the data operations. Furthermore, the complexity of the issues involved is considerably higher than that in the average data operation. If you would like to convince yourself of this fact take a look at the F file in the PDL distribution :-). Nevertheless, functions generated using the slice operations are at the heart of the index manipulation and dataflow capabilities of PDL. Also, there are a lot of dirty issues with virtual piddles and vaffines which we shall entirely skip here. =head2 Slices and bad values Slice operations need to be able to handle bad values (if support is compiled into PDL). The easiest thing to do is look at F to see how this works. Along with C, there are also the C and C keys for C. However, any C should I need changing, since any changes are absorbed into the definition of the C<$EQUIVCPOFFS()> macro (i.e. it is handled automatically by PDL::PP). =head2 A few notes on writing a slicing routine... The following few paragraphs describe writing of a new slicing routine ('range'); any errors are CED's. (--CED 26-Aug-2002) =head1 Handling of C and C in PP Code For printing warning messages or aborting/dieing, you can call C or C from PP code. However, you should be aware that these calls have been redefined using C preprocessor macros to C<< PDL->barf >> and C<< PDL->warn >>. These redefinitions are in place to keep you from inadvertently calling perl's C or C directly, which can cause segfaults during pthreading (i.e. processor multi-threading). PDL's own versions of C and C will queue-up warning or barf messages until after pthreading is completed, and then call the perl versions of these routines. See L for more information on pthreading. =head1 USEFUL ROUTINES The PDL C structure, defined in F, contains pointers to a number of routines that may be useful to you. The majority of these routines deal with manipulating piddles, but some are more general: =over 4 =item PDL->qsort_B( PDL_Byte *xx, PDL_Indx a, PDL_Indx b ) Sort the array C between the indices C and C. There are also versions for the other PDL datatypes, with postfix C<_S>, C<_U>, C<_L>, C<_N>, C<_Q>, C<_F>, and C<_D>. Any module using this must ensure that C is loaded. =item PDL->qsort_ind_B( PDL_Byte *xx, PDL_Indx *ix, PDL_Indx a, PDL_Indx b ) As for Cqsort_B>, but this time sorting the indices rather than the data. =back The routine C in F shows how such routines are used. =head1 MAKEFILES FOR PP FILES If you are going to generate a package from your PP file (typical file extensions are C<.pd> or C<.pp> for the files containing PP code) it is easiest and safest to leave generation of the appropriate commands to the Makefile. In the following we will outline the typical format of a Perl Makefile to automatically build and install your package from a description in a PP file. Most of the rules to build the xs, pm and other required files from the PP file are already predefined in the PDL::Core::Dev package. We just have to tell MakeMaker to use it. In most cases you can define your Makefile like # Makefile.PL for a package defined by PP code. use PDL::Core::Dev; # Pick up development utilities use ExtUtils::MakeMaker; $package = ["mylib.pd",Mylib,PDL::Lib::Mylib]; %hash = pdlpp_stdargs($package); $hash{OBJECT} .= ' additional_Ccode$(OBJ_EXT) '; $hash{clean}->{FILES} .= ' todelete_Ccode$(OBJ_EXT) '; $hash{'VERSION_FROM'} = 'mylib.pd'; WriteMakefile(%hash); sub MY::postamble { pdlpp_postamble($package); } Here, the list in $package is: first: PP source file name, then the prefix for the produced files and finally the whole package name. You can modify the hash in whatever way you like but it would be reasonable to stay within some limits so that your package will continue to work with later versions of PDL. If you don't want to use prepackaged arguments, here is a generic F that you can adapt for your own needs: # Makefile.PL for a package defined by PP code. use PDL::Core::Dev; # Pick up development utilities use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Lib::Mylib', 'VERSION_FROM' => 'mylib.pd', 'TYPEMAPS' => [&PDL_TYPEMAP()], 'OBJECT' => 'mylib$(OBJ_EXT) additional_Ccode$(OBJ_EXT)', 'PM' => { 'Mylib.pm' => '$(INST_LIBDIR)/Mylib.pm'}, 'INC' => &PDL_INCLUDE(), # add include dirs as required by your lib 'LIBS' => [''], # add link directives as necessary 'clean' => {'FILES' => 'Mylib.pm Mylib.xs Mylib$(OBJ_EXT) additional_Ccode$(OBJ_EXT)'}, ); # Add genpp rule; this will invoke PDL::PP on our PP file # the argument is an array reference where the array has three string elements: # arg1: name of the source file that contains the PP code # arg2: basename of the xs and pm files to be generated # arg3: name of the package that is to be generated sub MY::postamble { pdlpp_postamble(["mylib.pd",Mylib,PDL::Lib::Mylib]); } To make life even easier PDL::Core::Dev defines the function C that returns a hash with default values that can be passed (either directly or after appropriate modification) to a call to WriteMakefile. Currently, C returns a hash where the keys are filled in as follows: ( 'NAME' => $mod, 'TYPEMAPS' => [&PDL_TYPEMAP()], 'OBJECT' => "$pref\$(OBJ_EXT)", PM => {"$pref.pm" => "\$(INST_LIBDIR)/$pref.pm"}, MAN3PODS => {"$src" => "\$(INST_MAN3DIR)/$mod.\$(MAN3EXT)"}, 'INC' => &PDL_INCLUDE(), 'LIBS' => [''], 'clean' => {'FILES' => "$pref.xs $pref.pm $pref\$(OBJ_EXT)"}, ) Here, C<$src> is the name of the source file with PP code, C<$pref> the prefix for the generated .pm and .xs files and C<$mod> the name of the extension module to generate. =head1 INTERNALS The internals of the current version consist of a large table which gives the rules according to which things are translated and the subs which implement these rules. Later on, it would be good to make the table modifiable by the user so that different things may be tried. [Meta comment: here will hopefully be more in the future; currently, your best bet will be to read the source code :-( or ask on the list (try the latter first) ] =head1 Appendix A: Some keys recognised by PDL::PP Unless otherwise specified, the arguments are strings. Keys marked with (bad) are only used if bad-value support is compiled into PDL. =over 4 =item Pars define the signature of your function =item OtherPars arguments which are not pdls. Default: nothing. This is a semi-colon separated list of arguments, e.g., C<< OtherPars=>'int k; double value; char* fd' >>. See C<$COMP(x)> and also the same entry in L. =item Code the actual code that implements the functionality; several PP macros and PP functions are recognised in the string value =item HandleBad (bad) If set to 1, the routine is assumed to support bad values and the code in the BadCode key is used if bad values are present; it also sets things up so that the C<$ISBAD()> etc macros can be used. If set to 0, cause the routine to print a warning if any of the input piddles have their bad flag set. =item BadCode (bad) Give the code to be used if bad values may be present in the input piddles. Only used if C 1>. =item GenericTypes An array reference. The array may contain any subset of the one-character strings `B', `S', `U', `L', `Q', `F' and `D', which specify which types your operation will accept. The meaning of each type is: B - signed byte (i.e. signed char) S - signed short (two-byte integer) U - unsigned short L - signed long (four-byte integer, int on 32 bit systems) N - signed integer for indexing piddle elements (platform & Perl-dependent size) Q - signed long long (eight byte integer) F - float D - double This is very useful (and important!) when interfacing an external library. Default: [qw/B S U L N Q F D/] =item Inplace Mark a function as being able to work inplace. Inplace => 1 if Pars => 'a(); [o]b();' Inplace => ['a'] if Pars => 'a(); b(); [o]c();' Inplace => ['a','b'] if Pars => 'a(); b(); [o]c(); [o]d();' If bad values are being used, care must be taken to ensure the propagation of the badflag when inplace is being used; for instance see the code for C in F. =item Doc Used to specify a documentation string in Pod format. See PDL::Doc for information on PDL documentation conventions. Note: in the special case where the PP 'Doc' string is one line this is implicitly used for the quick reference AND the documentation! If the Doc field is omitted PP will generate default documentation (after all it knows about the Signature). If you really want the function NOT to be documented in any way at this point (e.g. for an internal routine, or because you are doing it elsewhere in the code) explicitly specify Cundef>. =item BadDoc (bad) Contains the text returned by the C command (in C) or the C<-b> switch to the C shell script. In many cases, you will not need to specify this, since the information can be automatically created by PDL::PP. However, as befits computer-generated text, it's rather stilted; it may be much better to do it yourself! =item NoPthread Optional flag to indicate the PDL function should B use processor threads (i.e. pthreads or POSIX threads) to split up work across multiple CPU cores. This option is typically set to 1 if the underlying PDL function is not threadsafe. If this option isn't present, then the function is assumed to be threadsafe. This option only applies if PDL has been compiled with POSIX threads enabled. =cut # FTypes is specified only in the two internal slice functions # converttypei and flowconvert. converttypei is never used anywhere in the # core. The related function, converttypei_new, does not appear to ever be # defined, but it is named used in converttypei as the GlobalNew, which I # presume we'll get to later. At any rate, converttypei appears to be # defunct. flowconvert, on the other hand, claims that it 'converts vaffine # piddles without physicalizing them'. However, its only use, in Core.pm, # is followed immediately by a "->make_physical->sever", so I don't see the # advantage of not making things physical. At any rate, FTypes needs to be # documented. =item PMCode PDL functions allow you to pass in a piddle into which you want the output saved. This is handy because you can allocate an output piddle once and reuse it many times; the alternative would be for PDL to create a new piddle each time, which may waste compute cycles or, more likely, RAM. This added flexibility comes at the cost of more complexity: PDL::PP has to write functions that are smart enough to count the arguments passed to it and create new piddles on the fly, but only if you want them. PDL::PP is smart enough to do that, but there are restrictions on argument order and the like. If you want a more flexible function, you can write your own Perl-side wrapper and specify it in the PMCode key. The string that you supply must (should) define a Perl function with a name that matches what you gave to pp_def in the first place. When you wish to eventually invoke the PP-generated function, you will need to supply all piddles in the exact order specified in the signature: output piddles are not optional, and the PP-generated function will not return anything. The obfuscated name that you will call is __int. I believe this documentation needs further clarification, but this will have to do. :-( =item PMFunc When pp_def generates functions, it typically defines them in the PDL package. Then, in the .pm file that it generates for your module, it typically adds a line that essentially copies that function into your current package's symbol table with code that looks like this: *func_name = \&PDL::func_name; It's a little bit smarter than that (it knows when to wrap that sort of thing in a BEGIN block, for example, and if you specified something different for pp_bless), but that's the gist of it. If you don't care to import the function into your current package's symbol table, you can specify PMFunc => '', PMFunc has no other side-effects, so you could use it to insert arbitrary Perl code into your module if you like. However, you should use pp_addpm if you want to add Perl code to your module. =back =head1 Appendix B: PP macros and functions =head2 Macros Macros labeled by (bad) are only used if bad-value support is compiled into PDL. =over 7 =item $I() access a pdl (by its name) that was specified in the signature =item $COMP(x) access a value in the private data structure of this transformation (mainly used to use an argument that is specified in the C section) =item $SIZE(n) replaced at runtime by the actual size of a I dimension (as specified in the I) =item $GENERIC() replaced by the C type that is equal to the runtime type of the operation =item $P(a) a pointer access to the PDL named C in the signature. Useful for interfacing to C functions =item $PP(a) a physical pointer access to pdl C; mainly for internal use =item $TXXX(Alternative,Alternative) expansion alternatives according to runtime type of operation, where XXX is some string that is matched by C. =item $PDL(a) return a pointer to the pdl data structure (pdl *) of piddle C =item $ISBAD(a()) (bad) returns true if the value stored in C equals the bad value for this piddle. Requires C being set to 1. =item $ISGOOD(a()) (bad) returns true if the value stored in C does not equal the bad value for this piddle. Requires C being set to 1. =item $SETBAD(a()) (bad) Sets C to equal the bad value for this piddle. Requires C being set to 1. =back =head2 functions =over 3 =item C loop over named dimensions; limits are generated automatically by PP =item C enclose following code in a thread loop =item C execute following code if type of operation is any of C =back =head1 Appendix C: Functions imported by PDL::PP A number of functions are imported when you C. These include functions that control the generated C or XS code, functions that control the generated Perl code, and functions that manipulate the packages and symbol tables into which the code is created. =head2 Generating C and XS Code PDL::PP's main purpose is to make it easy for you to wrap the threading engine around your own C code, but you can do some other things, too. =over =item pp_def Used to wrap the threading engine around your C code. Virtually all of this document discusses the use of pp_def. =item pp_done Indicates you are done with PDL::PP and that it should generate its .xs and .pm files based upon the other pp_* functions that you have called. This function takes no arguments. =item pp_addxs This lets you add XS code to your .xs file. This is useful if you want to create Perl-accessible functions that invoke C code but cannot or should not invoke the threading engine. XS is the standard means by which you wrap Perl-accessible C code. You can learn more at L. =item pp_add_boot This function adds whatever string you pass to the XS BOOT section. The BOOT section is C code that gets called by Perl when your module is loaded and is useful for automatic initialization. You can learn more about XS and the BOOT section at L. =item pp_addhdr Adds pure-C code to your XS file. XS files are structured such that pure C code must come before XS specifications. This allows you to specify such C code. =item pp_boundscheck PDL normally checks the bounds of your accesses before making them. You can turn that on or off at runtime by setting MyPackage::set_boundscheck. This function allows you to remove that runtime flexibility and B do bounds checking. It also returns the current boundschecking status if called without any argumens. NOTE: I have not found anything about bounds checking in other documentation. That needs to be addressed. =back =head2 Generating Perl Code Many functions imported when you use PDL::PP allow you to modify the contents of the generated .pm file. In addition to pp_def and pp_done, the role of these functions is primarily to add code to various parts of your generated .pm file. =over =item pp_addpm Adds Perl code to the generated .pm file. PDL::PP actually keeps track of three different sections of generated code: the Top, the Middle, and the Bottom. You can add Perl code to the Middle section using the one-argument form, where the argument is the Perl code you want to supply. In the two-argument form, the first argument is an anonymous hash with only one key that specifies where to put the second argument, which is the string that you want to add to the .pm file. The hash is one of these three: {At => 'Top'} {At => 'Middle'} {At => 'Bot'} For example: pp_addpm({At => 'Bot'}, < 'Top'}, ...) >>. Unlike pp_addpm, calling this overwrites whatever was there before. Generally, you probably shouldn't use it. =back =head2 Tracking Line Numbers When you get compile errors, either from your C-like code or your Perl code, it can help to make those errors back to the line numbers in the source file at which the error occurred. =over =item pp_line_numbers Takes a line number and a (usually long) string of code. The line number should indicate the line at which the quote begins. This is usually Perl's C<__LINE__> literal, unless you are using heredocs, in which case it is C<__LINE__ + 1>. The returned string has #line directives interspersed to help the compiler report errors on the proper line. =back =head2 Modifying the Symbol Table and Export Behavior PDL::PP usually exports all functions generated using pp_def, and usually installs them into the PDL symbol table. However, you can modify this behavior with these functions. =over =item pp_bless Sets the package (symbol table) to which the XS code is added. The default is PDL, which is generally what you want. If you use the default blessing and you create a function myfunc, then you can do the following: $piddle->myfunc(); PDL::myfunc($piddle, ); On the other hand, if you bless your functions into another package, you cannot invoke them as PDL methods, and must invoke them as: MyPackage::myfunc($piddle, ); Of course, you could always use the PMFunc key to add your function to the PDL symbol table, but why do that? =item pp_add_isa Adds to the list of modules from which your B inherits. The default list is qw(PDL::Exporter DynaLoader) =item pp_core_importlist At the top of your generated .pm file is a line that looks like this: use PDL::Core; You can modify that by specifying a string to pp_core_importlist. For example, pp_core_importlist('::Blarg'); will result in use PDL::Core::Blarg; You can use this, for example, to add a list of symbols to import from PDL::Core. For example: pp_core_importlist(" ':Internal'"); will lead to the following use statement: use PDL::Core ':Internal'; =item pp_setversion Sets your module's version. The version must be consistent between the .xs and the .pm file, and is used to ensure that your Perl's libraries do not suffer from version skew. =item pp_add_exported Adds to the export list whatever names you give it. Functions created using pp_def are automatically added to the list. This function is useful if you define any Perl functions using pp_addpm or pp_addxs that you want exported as well. =item pp_export_nothing This resets the list of exported symbols to nothing. This is probably better called C, since you can add exported symbols after calling C. When called just before calling pp_done, this ensures that your module does not export anything, for example, if you only want programmers to use your functions as methods. =back =head1 SEE ALSO I For the concepts of threading and slicing check L. L L for information on bad values I, I =head1 CURRENTLY UNDOCUMENTED Almost everything having to do with L. This includes much of the following (each entry is followed by a guess/description of where it is used or defined): =over 3 =item MACROS $CDIM() $CHILD() PDL::PP::Rule::Substitute::Usual $CHILD_P() PDL::PP::Rule::Substitute::Usual $CHILD_PTR() PDL::PP::Rule::Substitute::Usual $COPYDIMS() $COPYINDS() $CROAK() PDL::PP::Rule::Substitute::dosubst_private() $DOCOMPDIMS() Used in slices.pd, defined where? $DOPRIVDIMS() Used in slices.pd, defined where? Code comes from PDL::PP::CType::get_malloc, which is called by PDL::PP::CType::get_copy, which is called by PDL::PP::CopyOtherPars, PDL::PP::NT2Copies__, and PDL::PP::make_incsize_copy. But none of those three at first glance seem to have anything to do with $DOPRIVDIMS $EQUIVCPOFFS() $EQUIVCPTRUNC() $PARENT() PDL::PP::Rule::Substitute::Usual $PARENT_P() PDL::PP::Rule::Substitute::Usual $PARENT_PTR() PDL::PP::Rule::Substitute::Usual $PDIM() $PRIV() PDL::PP::Rule::Substitute::dosubst_private() $RESIZE() $SETDELTATHREADIDS() PDL::PP::Rule::MakeComp $SETDIMS() PDL::PP::Rule::MakeComp $SETNDIMS() PDL::PP::Rule::MakeComp $SETREVERSIBLE() PDL::PP::Rule::Substitute::dosubst_private() =item Keys AffinePriv BackCode BadBackCode CallCopy Comp (related to $COMP()?) DefaultFlow EquivCDimExpr EquivCPOffsCode EquivDimCheck EquivPDimExpr FTypes (see comment in this POD's source file between NoPthread and PMCode.) GlobalNew Identity MakeComp NoPdlThread P2Child ParentInds Priv ReadDataFuncName RedoDims (related to RedoDimsCode ?) Reversible WriteBckDataFuncName XCHGOnly =back =head1 BUGS Although PDL::PP is quite flexible and thoroughly used, there are surely bugs. First amongst them: this documentation needs a thorough revision. =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu), Karl Glaazebrook (kgb@aaocbn1.aao.GOV.AU) and Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. Documentation updates Copyright(C) 2011 David Mertens (dcmertens.perl@gmail.com). This documentation is licensed under the same terms as Perl itself. PDL-2.018/Basic/Pod/QuickStart.pod0000644060175006010010000005002012562522363014740 0ustar chmNone =head1 NAME PDL::QuickStart - Quick introduction to PDL features. =head1 SYNOPSIS A brief summary of the main PDL features and how to use them. =head1 DESCRIPTION =head2 Introduction Perl is an extremely good and versatile scripting language, well suited to beginners and allows rapid prototyping. However until recently it did not support data structures which allowed it to do fast number crunching. However with the development of Perl v5, Perl acquired 'Objects'. To put it simply users can define their own special data types, and write custom routines to manipulate them either in low level languages (C and Fortran) or in Perl itself. This has been fully exploited by the PerlDL developers. The 'PDL' module is a complete Object-Oriented extension to Perl (although you don't have to know what an object is to use it) which allows large N-dimensional data sets, such as large images, spectra, time series, etc to be stored B and manipulated B. For example with the PDL module we can write the Perl code C<$a = $b + $c>, where C<$b> and C<$c> are large datasets (e.g. 2048x2048 images), and get the result in only a fraction of a second. PDL variables (or 'piddles' as they have come to be known) support a wide range of fundamental data types - arrays can be bytes, short integers (signed or unsigned), long integers, floats or double precision floats. And because of the Object-Oriented nature of PDL new customised datatypes can be derived from them. As well as the PDL modules, that can be used by normal Perl programs, PerlDL comes with a command line Perl shell, called 'perldl', which supports command line editing. In combination with the various PDL graphics modules this allows data to be easily played with and visualised. =head2 Help PDL contains extensive documentation, available both within the I or I shells and from the command line, using the C program. For further information try either of: pdl> help help $ pdldoc HTML copies of the documentation should also be available. To find their location, try the following: pdl> foreach ( map{"$_/PDL/HtmlDocs"}@INC ) { p "$_\n" if -d $_ } =head2 Perl Datatypes and how PDL extends them The fundamental Perl data structures are scalar variables, e.g. C<$x>, which can hold numbers or strings, lists or arrays of scalars, e.g. C<@x>, and associative arrays/hashes of scalars, e.g. C<%x>. Perl v5 introduces to Perl data structures and objects. A simple scalar variable C<$x> now be a user-defined data type or full blown object (it actually holds a reference (a smart "pointer") to this but that is not relevant for ordinary use of perlDL) The fundamental idea behind perlDL is to allow C<$x> to hold a whole 1D spectrum, or a 2D image, a 3D data cube, and so on up to large N-dimensional data sets. These can be manipulated all at once, e.g. C<$a = $b + 2> does a vector operation on each value in the spectrum/image/etc. You may well ask: "Why not just store a spectrum as a simple Perl C<@x> style list with each pixel being a list item?" The two key answers to this are I and I. Because we know our spectrum consists of pure numbers we can compactly store them in a single block of memory corresponding to a C style numeric array. This takes up a LOT less memory than the equivalent Perl list. It is then easy to pass this block of memory to a fast addition routine, or to any other C function which deals with arrays. As a result perlDL is very fast --- for example one can multiply a 2048*2048 image in exactly the same time as it would take in C or FORTRAN (0.1 sec on my SPARC). A further advantage of this is that for simple operations (e.g. C<$x += 2>) one can manipulate the whole array without caring about its dimensionality. I find when using perlDL it is most useful to think of standard Perl C<@x> variables as "lists" of generic "things" and PDL variables like C<$x> as "arrays" which can be contained in lists or hashes. Quite often in my perlDL scripts I have C<@x> contain a list of spectra, or a list of images (or even a mix!). Or perhaps one could have a hash (e.g. C<%x>) of images... the only limit is memory! perlDL variables support a range of data types - arrays can be bytes, short integers (signed or unsigned), long integers, floats or double precision floats. =head2 Usage PerlDL is loaded into your Perl script using this command: use PDL; # in Perl scripts: use the standard perlDL modules There are also a lot of extension modules, e.g. L. Most of these (but not all as sometimes it is not appropriate) follow a standard convention. If you say: use PDL::Graphics::TriD; You import everything in a standard list from the module. Sometimes you might want to import nothing (e.g. if you want to use OO syntax all the time and save the import tax). For these you say: use PDL::Graphics::TriD qw(); And the empty C quotes are recognised as meaning 'nothing'. You can also specify a list of functions to import in the normal Perl way. There is also an interactive shell, C or C, see I or L for details. =head2 To create a new PDL variable Here are some ways of creating a PDL variable: $a = pdl [1..10]; # 1D array $a = pdl (1,2,3,4); # Ditto $a = pdl '[1 2 3 4]'; # Ditto $b = pdl [[1,2,3],[4,5,6]]; # 2D 3x2 array $b = pdl '[1 2 3; 4 5 6]'; # Ditto $b = pdl q[1,2,3; 4,5,6]; # Ditto $b = pdl < function is used to initialise a PDL variable from a scalar, list, list reference, another PDL variable, or a properly formatted string. In addition all PDL functions automatically convert normal Perl scalars to PDL variables on-the-fly. (also see "Type Conversion" and "Input/Output" sections below) =head2 Arithmetic (and boolean expressions) $a = $b + 2; $a++; $a = $b / $c; # Etc. $c=sqrt($a); $d = log10($b+100); # Etc $e = $a>42; # Vector conditional $e = 42*($a>42) + $a*($a<=42); # Cap top $b = $a->log10 unless any ($a <= 0); # avoid floating point error $a = $a / ( max($a) - min($a) ); $f = where($a, $a > 10); # where returns a piddle of elements for # which the condition is true print $a; # $a in string context prints it in a N-dimensional format (and other Perl operators/functions) When using piddles in conditional expressions (i.e. C, C and C constructs) only piddles with exactly one element are allowed, e.g. $a = pdl (1,0,0,1); print "is set" if $a->index(2); Note that the boolean operators return in general multi-element piddles. Therefore, the following will raise an error print "is ok" if $a > 3; since C<$a E 3> is a piddle with 4 elements. Rather use L or L to test if all or any of the elements fulfill the condition: print "some are > 3" if any $a>3; print "can't take logarithm" unless all $a>0; There are also many predefined functions, which are described on other man pages. Check L. =head2 Matrix functions C<'x'> is hijacked as the matrix multiplication operator. e.g. C<$c = $a x $b>; perlDL is row-major not column major so this is actually C - but when matrices are printed the results will look right. Just remember the indices are reversed. e.g.: $a = [ $b = [ [ 1 2 3 0] [1 1] [ 1 -1 2 7] [0 2] [ 1 0 0 1] [0 2] ] [1 1] ] gives $c = [ [ 1 11] [ 8 10] [ 2 2] ] Note: L does what it says and is a convenient way to turn row vectors into column vectors. =head2 How to write a simple function sub dotproduct { my ($a,$b) = @_; return sum($a*$b) ; } 1; If put in file dotproduct.pdl would be autoloaded if you are using L (see below). Of course, this function is already available as the L function, see L. =head2 Type Conversion Default for pdl() is double. Conversions are: $a = float($b); $c = long($d); # "long" is generally a 4 byte int $d = byte($a); Also double(), short(), ushort(), indx(). NOTE: The indx() routine is a special integer type that is the correct size for a PDL index value (dimension size, index, or offest) which can be either a 32bit (long) or 64bit (longlong) quantity depending on whether the perl is built with 32bit or 64bit support. These routines also automatically convert Perl lists to allow the convenient shorthand: $a = byte [[1..10],[1..10]]; # Create 2D byte array $a = float [1..1000]; # Create 1D float array etc. =head2 Printing Automatically expands array in N-dimensional format: print $a; $b = "Answer is = $a "; =head2 Sections PDL has very powerful multidimensional slicing and sectioning operators; see L for details; we'll describe the most important one here. PDL shows its Perl/C heritage in that arrays are zero-offset. Thus a 100x100 image has indices C<0..99,0..99>. (The convention is that the I

of pixel (0,0) is at coordinate (0.0,0.0). All PDL graphics functions conform to this definition and hide away the unit offsets of, for example, the PGPLOT FORTRAN library. Following the usual convention coordinate (0,0) is displayed at the bottom left when displaying an image. It appears at the top left when using "C" etc. Simple sectioning uses a syntax extension to Perl, L, that allows you to specify subranges via a null-method modifier to a PDL: $b = $a->($x1:$x2,$y1:$y2,($z1)); # Take subsection Here, C<$a> is a 3-dimensional variable, and C<$b> gets a planar cutout that is defined by the limits $x1, $x2, $y1, $y2, at the location $z1. The parenthesis around C<$z1> cause the trivial index to be omitted -- otherwise C<$b> would be three-dimensional with a third dimension of order 1. You can put PDL slices on either side of the element-wise assignment operator C<.=>, like so: # Set part of $bigimage to values from $smallimage $bigimage->($xa:$xb,$ya:$yb) .= $smallimage; Some other miscellany: $c = nelem($a); # Number of pixels $val = at($object, $x,$y,$z...) # Pixel value at position, as a Perl scalar $val = $object->at($x,$y,$z...) # equivalent (method syntax OK) $b = xvals($a); # Fill array with X-coord values (also yvals(), zvals(), # axisvals($x,$axis) and rvals() for radial distance # from centre). =head2 Input/Output The C modules implement several useful IO format functions. It would be too much to give examples of each, but you can find a nice overview at L. Here is a sample of some of the supported IO formats in PDL. =over 8 =item PDL::IO::Misc Ascii, FITS and FIGARO/NDF IO routines. =item PDL::IO::FastRaw Using the raw data types of your machine, an unportable but blindingly fast IO format. Also supports memory mapping to conserve memory as well as get more speed. =item PDL::IO::FlexRaw General raw data formats. Like FastRaw, only better. =item PDL::IO::Browser A Curses browser for arrays. =item PDL::IO::Pnm Portaple bitmap and pixmap support. =item PDL::IO::Pic Using the previous module and netpbm, makes it possible to easily write GIF, jpeg and whatever with simple commands. =back =head2 Graphics The philosophy behind perlDL is to make it work with a variety of existing graphics libraries since no single package will satisfy all needs and all people and this allows one to work with packages one already knows and likes. Obviously there will be some overlaps in functionality and some lack of consistency and uniformity. However this allows PDL to keep up with a rapidly developing field - the latest PDL modules provide interfaces to OpenGL and VRML graphics! =over 4 =item PDL::Graphics::PGPLOT PGPLOT provides a simple library for line graphics and image display. There is an easy interface to this in the internal module L, which calls routines in the separately available PGPLOT top-level module. =item PDL::Graphics::PLplot PLplot provides a simple library for creating graphics with multiple output drivers, including a direct-to-piddle driver. This module provides both high-level and low-level functionality built on PLplot. The low-level commands are pretty much direct bindings to PLplot's C interface. Read more at L. =item PDL::Graphics::IIS Many astronomers like to use SAOimage and Ximtool (or there derivations/clones). These are useful free widgets for inspection and visualisation of images. (They are not provided with perlDL but can easily be obtained from their official sites off the Net.) The L package provides allows one to display images in these ("IIS" is the name of an ancient item of image display hardware whose protocols these tools conform to.) =item PDL::Graphics::TriD See L, this is a collection of 3D routines for OpenGL and (soon) VRML and other 3D formats which allow 3D point, line, and surface plots from PDL. =back =head2 Autoloading See L. This allows one to autoload functions on demand, in a way perhaps familiar to users of MatLab. One can also write PDL extensions as normal Perl modules. =head2 PDL shells The Perl script C (or C) provides a simple command line interface to PDL. If the latest Readlines/ReadKey modules have been installed C detects this and enables command line recall and editing. See the man page for details. e.g.: % perldl perlDL shell v1.354 PDL comes with ABSOLUTELY NO WARRANTY. For details, see the file 'COPYING' in the PDL distribution. This is free software and you are welcome to redistribute it under certain conditions, see the same file for details. ReadLines, NiceSlice, MultiLines enabled Reading PDL/default.perldlrc... Found docs database /home/pdl/dev/lib/perl5/site_perl/PDL/pdldoc.db Type 'help' for online help Type 'demo' for online demos Loaded PDL v2.4.9_003 (supports bad values) pdl> $x = rfits 'm51.fits' Reading IMAGE data... BITPIX = 32 size = 147456 pixels Reading 589824 bytes BSCALE = && BZERO = pdl> use PDL::Graphics::PGPLOT; pdl> imag $x Displaying 384 x 384 image from 40 to 761, using 84 colors (16-99)... You can also run it from the Perl debugger (C) if you want. Miscellaneous shell features: =over 4 =item p The shell aliases C

to be a convenient short form of C, e.g. pdl> p ones 5,3 [ [1 1 1 1 1] [1 1 1 1 1] [1 1 1 1 1] ] =item Initialization The files C<~/.perldlrc> and C (in the current directory) are sourced if found. This allows the user to have global and local PDL code for startup. =item Help Type 'help'! One can search the PDL documentation, and look up documentation on any function. =item Escape Any line starting with the C<#> character is treated as a shell escape. This character is configurable by setting the Perl variable C<$PERLDL_ESCAPE>. This could, for example, be set in C<~/.perldlrc>. =back =head2 Overload operators The following builtin Perl operators and functions have been overloaded to work on PDL variables: + - * / > < >= <= << >> & | ^ == != <=> ** % ! ~ sin log abs atan2 sqrt cos exp [All the unary functions (sin etc.) may be used with inplace() - see "Memory" below.] =head2 Object-Orientation and perlDL PDL operations are available as functions and methods. Thus one can derive new types of object, to represent custom data classes. By using overloading one can make mathematical operators do whatever you please, and PDL has some built-in tricks which allow existing PDL functions to work unchanged, even if the underlying data representation is vastly changed! See L =head2 Memory usage and references Messing around with really huge data arrays may require some care. perlDL provides many facilities to let you perform operations on big arrays without generating extra copies though this does require a bit more thought and care from the programmer. NOTE: On some most systems it is better to configure Perl (during the build options) to use the system C function rather than Perl's built-in one. This is because Perl's one is optimised for speed rather than consumption of virtual memory - this can result in a factor of two improvement in the amount of memory storage you can use. The Perl malloc in 5.004 and later does have a number of compile-time options you can use to tune the behaviour. =over =item Simple arithmetic If $a is a big image (e.g. occupying 10MB) then the command $a = $a + 1; eats up another 10MB of memory. This is because the expression C<$a+1> creates a temporary copy of C<$a> to hold the result, then C<$a> is assigned a reference to that. After this, the original C<$a> is destroyed so there is no I memory waste. But on a small machine, the growth in the memory footprint can be considerable. It is obviously done this way so C<$c=$a+1> works as expected. Also if one says: $b = $a; # $b and $a now point to same data $a = $a + 1; Then C<$b> and C<$a> end up being different, as one naively expects, because a new reference is created and C<$a> is assigned to it. However if C<$a> was a huge memory hog (e.g. a 3D volume) creating a copy of it may not be a good thing. One can avoid this memory overhead in the above example by saying: $a++; The operations C<++,+=,--,-=>, etc. all call a special "in-place" version of the arithmetic subroutine. This means no more memory is needed - the downside of this is that if C<$b=$a> then C<$b> is also incremented. To force a copy explicitly: $b = pdl $a; # Real copy or, alternatively, perhaps better style: $b = $a->copy; =item Functions Most functions, e.g. C, return a result which is a transformation of their argument. This makes for good programming practice. However many operations can be done "in-place" and this may be required when large arrays are in use and memory is at a premium. For these circumstances the operator L is provided which prevents the extra copy and allows the argument to be modified. e.g.: $x = log($array); # $array unaffected log( inplace($bigarray) ); # $bigarray changed in situ WARNINGS: =over =item 1 The usual caveats about duplicate references apply. =item 2 Obviously when used with some functions which can not be applied in situ (e.g. C) unexpected effects may occur! We try to indicate C-safe functions in the documentation. =item 3 Type conversions, such asC, may cause hidden copying. =back =back =head2 Ensuring piddleness If you have written a simple function and you don't want it to blow up in your face if you pass it a simple number rather than a PDL variable. Simply call the function L first to make it safe. e.g.: sub myfiddle { my $pdl = topdl(shift); $pdl->fiddle_foo(...); ... } C does NOT perform a copy if a pdl variable is passed - it just falls through - which is obviously the desired behaviour. The routine is not of course necessary in normal user defined functions which do not care about internals. =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu) and Christian Soeller (c.soeller@auckland.ac.nz) 1997. Commercial reproduction of this documentation in a different format is forbidden. =cut PDL-2.018/Basic/Pod/Scilab.pod0000644060175006010010000005312412562522363014053 0ustar chmNone=head1 NAME PDL::Scilab - A guide for Scilab users. =head1 INTRODUCTION If you are a Scilab user, this page is for you. It explains the key differences between Scilab and PDL to help you get going as quickly as possible. B. For that, go to L. This document B the Quick Start guide, as it highlights the key differences between Scilab and PDL. =head1 Perl The key difference between Scilab and PDL is B. Perl is a general purpose programming language with thousands of modules freely available on the web. PDL is an extension of Perl. This gives PDL programs access to more features than most numerical tools can dream of. At the same time, most syntax differences between Scilab and PDL are a result of its Perl foundation. B. But if you wish to learn Perl, there is excellent documentation available on-line (L) or through the command C. There is also a beginner's portal (L). Perl's module repository is called CPAN (L) and it has a vast array of modules. Run C for more information. =head1 TERMINOLOGY: PIDDLE Scilab typically refers to vectors, matrices, and arrays. Perl already has arrays, and the terms "vector" and "matrix" typically refer to one- and two-dimensional collections of data. Having no good term to describe their object, PDL developers coined the term "I" to give a name to their data type. A I consists of a series of numbers organized as an N-dimensional data set. Piddles provide efficient storage and fast computation of large N-dimensional matrices. They are highly optimized for numerical work. For more information, see "B" later in this document. =head1 COMMAND WINDOW AND IDE PDL does not come with a dedicated IDE. It does however come with an interactive shell and you can use a Perl IDE to develop PDL programs. =head2 PDL interactive shell To start the interactive shell, open a terminal and run C or C. As in Scilab, the interactive shell is the best way to learn the language. To exit the shell, type C, just like Scilab. =head2 Writing PDL programs One popular IDE for Perl is called Padre (L). It is cross platform and easy to use. Whenever you write a stand-alone PDL program (i.e. outside the C or C shells) you must start the program with C. This command imports the PDL module into Perl. Here is a sample PDL program: use PDL; # Import main PDL module. use PDL::NiceSlice; # Import additional PDL module. $b = pdl [2,3,4]; # Statements end in semicolon. $A = pdl [ [1,2,3],[4,5,6] ]; # 2-dimensional piddle. print $A x $b->transpose; Save this file as C and run it with: perl myprogram.pl =head2 New: Flexible syntax In very recent versions of PDL (version 2.4.7 or later) there is a flexible matrix syntax that can look extremely similar to Scilab: 1) Use a ';' to delimit rows: $b = pdl q[ 2,3,4 ]; $A = pdl q[ 1,2,3 ; 4,5,6 ]; 2) Use spaces to separate elements: $b = pdl q[ 2 3 4 ]; $A = pdl q[ 1 2 3 ; 4 5 6 ]; Basically, as long as you put a C in front of the opening bracket, PDL should "do what you mean". So you can write in a syntax that is more comfortable for you. =head1 A MODULE FOR SCILAB USERS Here is a module that Scilab users will want to use: =over 5 =item L Gives PDL a syntax for slices (sub-matrices) that is shorter and more familiar to Scilab users. // Scilab b(1:5) --> Selects the first 5 elements from b. # PDL without NiceSlice $b->slice("0:4") --> Selects the first 5 elements from $b. # PDL with NiceSlice $b(0:4) --> Selects the first 5 elements from $b. =back =head1 BASIC FEATURES This section explains how PDL's syntax differs from Scilab. Most Scilab users will want to start here. =head2 General "gotchas" =over 5 =item Indices In PDL, indices start at '0' (like C and Java), not 1 (like Scilab). For example, if C<$b> is an array with 5 elements, the elements would be numbered from 0 to 4. =item Displaying an object Scilab normally displays object contents automatically. In PDL you display objects explicitly with the C command or the shortcut C

: Scilab: --> a = 12 a = 12. --> b = 23; // Suppress output. --> PerlDL: pdl> $a = 12 # No output. pdl> print $a # Print object. 12 pdl> p $a # "p" is a shorthand for "print" in the shell. 12 =back =head2 Creating Piddles =over 5 =item Variables in PDL Variables always start with the '$' sign. Scilab: value = 42 PerlDL: $value = 42 =item Basic syntax Use the "pdl" constructor to create a new I. Scilab: v = [1,2,3,4] PerlDL: $v = pdl [1,2,3,4] Scilab: A = [ 1,2,3 ; 3,4,5 ] PerlDL: $A = pdl [ [1,2,3] , [3,4,5] ] =item Simple matrices Scilab PDL ------ ------ Matrix of ones ones(5,5) ones 5,5 Matrix of zeros zeros(5,5) zeros 5,5 Random matrix rand(5,5) random 5,5 Linear vector 1:5 sequence 5 Notice that in PDL the parenthesis in a function call are often optional. It is important to keep an eye out for possible ambiguities. For example: pdl> p zeros 2, 2 + 2 Should this be interpreted as C or as C? Both are valid statements: pdl> p zeros(2,2) + 2 [ [2 2] [2 2] ] pdl> p zeros 2, (2+2) [ [0 0] [0 0] [0 0] [0 0] ] Rather than trying to memorize Perl's order of precedence, it is best to use parentheses to make your code unambiguous. =item Linearly spaced sequences Scilab: --> linspace(2,10,5) ans = 2. 4. 6. 8. 10. PerlDL: pdl> p zeroes(5)->xlinvals(2,10) [2 4 6 8 10] B: Start with a 1-dimensional piddle of 5 elements and give it equally spaced values from 2 to 10. Scilab has a single function call for this. On the other hand, PDL's method is more flexible: pdl> p zeros(5,5)->xlinvals(2,10) [ [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] ] pdl> p zeros(5,5)->ylinvals(2,10) [ [ 2 2 2 2 2] [ 4 4 4 4 4] [ 6 6 6 6 6] [ 8 8 8 8 8] [10 10 10 10 10] ] pdl> p zeros(3,3,3)->zlinvals(2,6) [ [ [2 2 2] [2 2 2] [2 2 2] ] [ [4 4 4] [4 4 4] [4 4 4] ] [ [6 6 6] [6 6 6] [6 6 6] ] ] =item Slicing and indices Extracting a subset from a collection of data is known as I. The PDL shell and Scilab have a similar syntax for slicing, but there are two important differences: 1) PDL indices start at 0, as in C and Java. Scilab starts indices at 1. 2) In Scilab you think "rows and columns". In PDL, think "x and y". Scilab PerlDL ------ ------ --> A pdl> p $A A = [ 1. 2. 3. [1 2 3] 4. 5. 6. [4 5 6] 7. 8. 9. [7 8 9] ] ------------------------------------------------------- (row = 2, col = 1) (x = 0, y = 1) --> A(2,1) pdl> p $A(0,1) ans = [ 4. [4] ] ------------------------------------------------------- (row = 2 to 3, col = 1 to 2) (x = 0 to 1, y = 1 to 2) --> A(2:3,1:2) pdl> p $A(0:1,1:2) ans = [ 4. 5. [4 5] 7. 8. [7 8] ] =over 5 =item B When you write a stand-alone PDL program you have to include the L module. See the previous section "B" for more information. use PDL; # Import main PDL module. use PDL::NiceSlice; # Nice syntax for slicing. $A = random 4,4; print $A(0,1); =back =back =head2 Matrix Operations =over 10 =item Matrix multiplication Scilab: A * B PerlDL: $A x $B =item Element-wise multiplication Scilab: A .* B PerlDL: $A * $B =item Transpose Scilab: A' PerlDL: $A->transpose =back =head2 Functions that aggregate data Some functions (like C, C and C) aggregate data for an N-dimensional data set. Scilab and PDL both give you the option to apply these functions to the entire data set or to just one dimension. =over 10 =item Scilab In Scilab, these functions work along the entire data set by default, and an optional parameter "r" or "c" makes them act over rows or columns. --> A = [ 1,5,4 ; 4,2,1 ] A = 1. 5. 4. 4. 2. 1. --> max(A) ans = 5 --> max(A, "r") ans = 4. 5. 4. --> max(A, "c") ans = 5. 4. =item PDL PDL offers two functions for each feature. sum vs sumover avg vs average max vs maximum min vs minimum The B works over a dimension, while the B works over the entire piddle. pdl> p $A = pdl [ [1,5,4] , [4,2,1] ] [ [1 5 4] [4 2 1] ] pdl> p $A->maximum [5 4] pdl> p $A->transpose->maximum [4 5 4] pdl> p $A->max 5 =back =head2 Higher dimensional data sets A related issue is how Scilab and PDL understand data sets of higher dimension. Scilab was designed for 1D vectors and 2D matrices with higher dimensional objects added on top. In contrast, PDL was designed for N-dimensional piddles from the start. This leads to a few surprises in Scilab that don't occur in PDL: =over 5 =item Scilab sees a vector as a 2D matrix. Scilab PerlDL ------ ------ --> vector = [1,2,3,4]; pdl> $vector = pdl [1,2,3,4] --> size(vector) pdl> p $vector->dims ans = 1 4 4 Scilab sees C<[1,2,3,4]> as a 2D matrix (1x4 matrix). PDL sees it as a 1D vector: A single dimension of size 4. =item But Scilab ignores the last dimension of a 4x1x1 matrix. Scilab PerlDL ------ ------ --> A = ones(4,1,1); pdl> $A = ones 4,1,1 --> size(A) pdl> p $A->dims ans = 4 1 4 1 1 =item And Scilab treats a 4x1x1 matrix differently from a 1x1x4 matrix. Scilab PerlDL ------ ------ --> A = ones(1,1,4); pdl> $A = ones 1,1,4 --> size(A) pdl> p $A->dims ans = 1 1 4 1 1 4 =item Scilab has no direct syntax for N-D arrays. pdl> $A = pdl [ [[1,2,3],[4,5,6]], [[2,3,4],[5,6,7]] ] pdl> p $A->dims 3 2 2 =item Feature support. In Scilab, several features are not available for N-D arrays. In PDL, just about any feature supported by 1D and 2D piddles, is equally supported by N-dimensional piddles. There is usually no distinction: Scilab PerlDL ------ ------ --> A = ones(3,3,3); pdl> $A = ones(3,3,3); --> A' pdl> transpose $A => ERROR => OK =back =head2 Loop Structures Perl has many loop structures, but we will only show the one that is most familiar to Scilab users: Scilab PerlDL ------ ------ for i = 1:10 for $i (1..10) { disp(i) print $i end } =over 5 =item B Never use for-loops for numerical work. Perl's for-loops are faster than Scilab's, but they both pale against a "vectorized" operation. PDL has many tools that facilitate writing vectorized programs. These are beyond the scope of this guide. To learn more, see: L, L, and L. Likewise, never use C<1..10> for numerical work, even outside a for-loop. C<1..10> is a Perl array. Perl arrays are designed for flexibility, not speed. Use I instead. To learn more, see the next section. =back =head2 Piddles vs Perl Arrays It is important to note the difference between a I and a Perl array. Perl has a general-purpose array object that can hold any type of element: @perl_array = 1..10; @perl_array = ( 12, "Hello" ); @perl_array = ( 1, 2, 3, \@another_perl_array, sequence(5) ); Perl arrays allow you to create powerful data structures (see B below), B. For that, use I: $pdl = pdl [ 1, 2, 3, 4 ]; $pdl = sequence 10_000_000; $pdl = ones 600, 600; For example: $points = pdl 1..10_000_000 # 4.7 seconds $points = sequence 10_000_000 # milliseconds B: You can use underscores in numbers (C<10_000_000> reads better than C<10000000>). =head2 Conditionals Perl has many conditionals, but we will only show the one that is most familiar to Scilab users: Scilab PerlDL ------ ------ if value > MAX if ($value > $MAX) { disp("Too large") print "Too large\n"; elseif value < MIN } elsif ($value < $MIN) { disp("Too small") print "Too small\n"; else } else { disp("Perfect!") print "Perfect!\n"; end } =over 5 =item B Here is a "gotcha": Scilab: elseif PerlDL: elsif If your conditional gives a syntax error, check that you wrote your C's correctly. =back =head2 TIMTOWDI (There Is More Than One Way To Do It) One of the most interesting differences between PDL and other tools is the expressiveness of the Perl language. TIMTOWDI, or "There Is More Than One Way To Do It", is Perl's motto. Perl was written by a linguist, and one of its defining properties is that statements can be formulated in different ways to give the language a more natural feel. For example, you are unlikely to say to a friend: "While I am not finished, I will keep working." Human language is more flexible than that. Instead, you are more likely to say: "I will keep working until I am finished." Owing to its linguistic roots, Perl is the only programming language with this sort of flexibility. For example, Perl has traditional while-loops and if-statements: while ( ! finished() ) { keep_working(); } if ( ! wife_angry() ) { kiss_wife(); } But it also offers the alternative B and B statements: until ( finished() ) { keep_working(); } unless ( wife_angry() ) { kiss_wife(); } And Perl allows you to write loops and conditionals in "postfix" form: keep_working() until finished(); kiss_wife() unless wife_angry(); In this way, Perl often allows you to write more natural, easy to understand code than is possible in more restrictive programming languages. =head2 Functions PDL's syntax for declaring functions differs significantly from Scilab's. Scilab PerlDL ------ ------ function retval = foo(x,y) sub foo { retval = x.**2 + x.*y my ($x, $y) = @_; endfunction return $x**2 + $x*$y; } Don't be intimidated by all the new syntax. Here is a quick run through a function declaration in PDL: 1) "B" stands for "subroutine". 2) "B" declares variables to be local to the function. 3) "B<@_>" is a special Perl array that holds all the function parameters. This might seem like a strange way to do functions, but it allows you to make functions that take a variable number of parameters. For example, the following function takes any number of parameters and adds them together: sub mysum { my ($i, $total) = (0, 0); for $i (@_) { $total += $i; } return $total; } 4) You can assign values to several variables at once using the syntax: ($a, $b, $c) = (1, 2, 3); So, in the previous examples: # This declares two local variables and initializes them to 0. my ($i, $total) = (0, 0); # This takes the first two elements of @_ and puts them in $x and $y. my ($x, $y) = @_; 5) The "B" statement gives the return value of the function, if any. =head1 ADDITIONAL FEATURES =head2 Data structures To create complex data structures, Scilab uses "I" and "I". Perl's arrays and hashes offer similar functionality. This section is only a quick overview of what Perl has to offer. To learn more about this, please go to L or run the command C. =over 5 =item Arrays Perl arrays are similar to Scilab's lists. They are both a sequential data structure that can contain any data type. Scilab ------ list( 1, 12, "hello", zeros(3,3) , list( 1, 2) ); PerlDL ------ @array = ( 1, 12, "hello" , zeros(3,3), [ 1, 2 ] ) Notice that Perl array's start with the "@" prefix instead of the "$" used by piddles. I or run the command C.> =item Hashes Perl hashes are similar to Scilab's structure arrays: Scilab ------ --> drink = struct('type', 'coke', 'size', 'large', 'myarray', ones(3,3,3)) --> drink.type = 'sprite' --> drink.price = 12 // Add new field to structure array. PerlDL ------ pdl> %drink = ( type => 'coke' , size => 'large', mypiddle => ones(3,3,3) ) pdl> $drink{type} = 'sprite' pdl> $drink{price} = 12 # Add new field to hash. Notice that Perl hashes start with the "%" prefix instead of the "@" for arrays and "$" used by piddles. I or run the command C.> =back =head2 Performance PDL has powerful performance features, some of which are not normally available in numerical computation tools. The following pages will guide you through these features: =over 5 =item L B: Beginner This beginner tutorial covers the standard "vectorization" feature that you already know from Scilab. Use this page to learn how to avoid for-loops to make your program more efficient. =item L B: Intermediate PDL's "vectorization" feature goes beyond what most numerical software can do. In this tutorial you'll learn how to "thread" over higher dimensions, allowing you to vectorize your program further than is possible in Scilab. =item Benchmarks B: Intermediate Perl comes with an easy to use benchmarks module to help you find how long it takes to execute different parts of your code. It is a great tool to help you focus your optimization efforts. You can read about it online (L) or through the command C. =item L B: Advanced PDL's Pre-Processor is one of PDL's most powerful features. You write a function definition in special markup and the pre-processor generates real C code which can be compiled. With PDL:PP you get the full speed of native C code without having to deal with the full complexity of the C language. =back =head2 Plotting PDL has full-featured plotting abilities. Unlike Scilab, PDL relies more on third-party libraries (pgplot and PLplot) for its 2D plotting features. Its 3D plotting and graphics uses OpenGL for performance and portability. PDL has three main plotting modules: =over 5 =item L B: Plotting 2D functions and data sets. This is an interface to the venerable PGPLOT library. PGPLOT has been widely used in the academic and scientific communities for many years. In part because of its age, PGPLOT has some limitations compared to newer packages such as PLplot (e.g. no RGB graphics). But it has many features that still make it popular in the scientific community. =item L B: Plotting 2D functions as well as 2D and 3D data sets. This is an interface to the PLplot plotting library. PLplot is a modern, open source library for making scientific plots. It supports plots of both 2D and 3D data sets. PLplot is best supported for unix/linux/macosx platforms. It has an active developers community and support for win32 platforms is improving. =item L B: Plotting 3D functions. The native PDL 3D graphics library using OpenGL as a backend for 3D plots and data visualization. With OpenGL, it is easy to manipulate the resulting 3D objects with the mouse in real time. =back =head2 Writing GUIs Through Perl, PDL has access to all the major toolkits for creating a cross platform graphical user interface. One popular option is wxPerl (L). These are the Perl bindings for wxWidgets, a powerful GUI toolkit for writing cross-platform applications. wxWidgets is designed to make your application look and feel like a native application in every platform. For example, the Perl IDE B is written with wxPerl. =head2 Xcos / Scicos Xcos (formerly Scicos) is a graphical dynamical system modeler and simulator. It is part of the standard Scilab distribution. PDL and Perl do not have a direct equivalent to Scilab's Xcos. If this feature is important to you, you should probably keep a copy of Scilab around for that. =head1 COPYRIGHT Copyright 2010 Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.018/Basic/Pod/Threading.pod0000644060175006010010000006230112562522363014560 0ustar chmNone=head1 NAME PDL::Threading - Tutorial for PDL's Threading feature =head1 INTRODUCTION One of the most powerful features of PDL is B, which can produce very compact and very fast PDL code by avoiding multiple nested for loops that C and BASIC users may be familiar with. The trouble is that it can take some getting used to, and new users may not appreciate the benefits of threading. Other vector based languages, such as MATLAB, use a subset of threading techniques, but PDL shines by completely generalizing them for all sorts of vector-based applications. =head1 TERMINOLOGY: PIDDLE MATLAB typically refers to vectors, matrices, and arrays. Perl already has arrays, and the terms "vector" and "matrix" typically refer to one- and two-dimensional collections of data. Having no good term to describe their object, PDL developers coined the term "I" to give a name to their data type. A I consists of a series of numbers organized as an N-dimensional data set. Piddles provide efficient storage and fast computation of large N-dimensional matrices. They are highly optimized for numerical work. =head1 THINKING IN TERMS OF THREADING If you have used PDL for a little while already, you may have been using threading without realising it. Start the PDL shell (type C or C on a terminal). Most examples in this tutorial use the PDL shell. Make sure that L and L are enabled. For example: % pdl2 perlDL shell v1.352 ... ReadLines, NiceSlice, MultiLines enabled ... Note: AutoLoader not enabled ('use PDL::AutoLoader' recommended) pdl> In this example, NiceSlice was automatically enabled, but AutoLoader was not. To enable it, type C. Let's start with a two-dimensional I: pdl> $a = sequence(11,9) pdl> p $a [ [ 0 1 2 3 4 5 6 7 8 9 10] [11 12 13 14 15 16 17 18 19 20 21] [22 23 24 25 26 27 28 29 30 31 32] [33 34 35 36 37 38 39 40 41 42 43] [44 45 46 47 48 49 50 51 52 53 54] [55 56 57 58 59 60 61 62 63 64 65] [66 67 68 69 70 71 72 73 74 75 76] [77 78 79 80 81 82 83 84 85 86 87] [88 89 90 91 92 93 94 95 96 97 98] ] The C method gives you basic information about a I: pdl> p $a->info PDL: Double D [11,9] This tells us that C<$a> is an 11 x 9 I composed of double precision numbers. If we wanted to add 3 to all elements in an C piddle, a traditional language would use two nested for-loops: # Pseudo-code. Traditional way to add 3 to an array. for (x=0; x < n; x++) { for (y=0; y < m; y++) { a(x,y) = a(x,y) + 3 } } B: Notice that indices start at 0, as in Perl, C and Java (and unlike MATLAB and IDL). But with PDL, we can just write: pdl> $b = $a + 3 pdl> p $b [ [ 3 4 5 6 7 8 9 10 11 12 13] [ 14 15 16 17 18 19 20 21 22 23 24] [ 25 26 27 28 29 30 31 32 33 34 35] [ 36 37 38 39 40 41 42 43 44 45 46] [ 47 48 49 50 51 52 53 54 55 56 57] [ 58 59 60 61 62 63 64 65 66 67 68] [ 69 70 71 72 73 74 75 76 77 78 79] [ 80 81 82 83 84 85 86 87 88 89 90] [ 91 92 93 94 95 96 97 98 99 100 101] ] This is the simplest example of threading, and it is something that all numerical software tools do. The C<+ 3> operation was automatically applied along two dimensions. Now suppose you want to to subtract a line from every row in C<$a>: pdl> $line = sequence(11) pdl> p $line [0 1 2 3 4 5 6 7 8 9 10] pdl> $c = $a - $line pdl> p $c [ [ 0 0 0 0 0 0 0 0 0 0 0] [11 11 11 11 11 11 11 11 11 11 11] [22 22 22 22 22 22 22 22 22 22 22] [33 33 33 33 33 33 33 33 33 33 33] [44 44 44 44 44 44 44 44 44 44 44] [55 55 55 55 55 55 55 55 55 55 55] [66 66 66 66 66 66 66 66 66 66 66] [77 77 77 77 77 77 77 77 77 77 77] [88 88 88 88 88 88 88 88 88 88 88] ] Two things to note here: First, the value of C<$a> is still the same. Try C

to check. Second, PDL automatically subtracted C<$line> from each row in C<$a>. Why did it do that? Let's look at the dimensions of C<$a>, C<$line> and C<$c>: pdl> p $line->info => PDL: Double D [11] pdl> p $a->info => PDL: Double D [11,9] pdl> p $c->info => PDL: Double D [11,9] So, both C<$a> and C<$line> have the same number of elements in the 0th dimension! What PDL then did was thread over the higher dimensions in C<$a> and repeated the same operation 9 times to all the rows on C<$a>. This is PDL threading in action. What if you want to subtract C<$line> from the first line in C<$a> only? You can do that by specifying the line explicitly: pdl> $a(:,0) -= $line pdl> p $a [ [ 0 0 0 0 0 0 0 0 0 0 0] [11 12 13 14 15 16 17 18 19 20 21] [22 23 24 25 26 27 28 29 30 31 32] [33 34 35 36 37 38 39 40 41 42 43] [44 45 46 47 48 49 50 51 52 53 54] [55 56 57 58 59 60 61 62 63 64 65] [66 67 68 69 70 71 72 73 74 75 76] [77 78 79 80 81 82 83 84 85 86 87] [88 89 90 91 92 93 94 95 96 97 98] ] See L and L to learn more about specifying subsets from piddles. The true power of threading comes when you realise that the piddle can have any number of dimensions! Let's make a 4 dimensional piddle: pdl> $piddle_4D = sequence(11,3,7,2) pdl> $c = $piddle_4D - $line Now C<$c> is a piddle of the same dimension as C<$piddle_4D>. pdl> p $piddle_4D->info => PDL: Double D [11,3,7,2] pdl> p $c->info => PDL: Double D [11,3,7,2] This time PDL has threaded over three higher dimensions automatically, subtracting C<$line> all the way. But, maybe you don't want to subtract from the rows (dimension 0), but from the columns (dimension 1). How do I subtract a column of numbers from each column in C<$a>? pdl> $cols = sequence(9) pdl> p $a->info => PDL: Double D [11,9] pdl> p $cols->info => PDL: Double D [9] Naturally, we can't just type C<$a - $cols>. The dimensions don't match: pdl> p $a - $cols PDL: PDL::Ops::minus(a,b,c): Parameter 'b' PDL: Mismatched implicit thread dimension 0: should be 11, is 9 How do we tell PDL that we want to subtract from dimension 1 instead? =head1 MANIPULATING DIMENSIONS There are many PDL functions that let you rearrange the dimensions of PDL arrays. They are mostly covered in L. The three most common ones are: xchg mv reorder =head2 Method: C The C method "B" two dimensions in a piddle: pdl> $a = sequence(6,7,8,9) pdl> $a_xchg = $a->xchg(0,3) pdl> p $a->info => PDL: Double D [6,7,8,9] pdl> p $a_xchg->info => PDL: Double D [9,7,8,6] | | V V (dim 0) (dim 3) Notice that dimensions 0 and 3 were exchanged without affecting the other dimensions. Notice also that C does not alter C<$a>. The original variable C<$a> remains untouched. =head2 Method: C The C method "B" one dimension, in a piddle, shifting other dimensions as necessary. pdl> $a = sequence(6,7,8,9) (dim 0) pdl> $a_mv = $a->mv(0,3) | pdl> V _____ pdl> p $a->info => PDL: Double D [6,7,8,9] pdl> p $a_mv->info => PDL: Double D [7,8,9,6] ----- | V (dim 3) Notice that when dimension 0 was moved to position 3, all the other dimensions had to be shifted as well. Notice also that C does not alter C<$a>. The original variable C<$a> remains untouched. =head2 Method: C The C method is a generalization of the C and C methods. It "B" the dimensions in any way you specify: pdl> $a = sequence(6,7,8,9) pdl> $a_reorder = $a->reorder(3,0,2,1) pdl> pdl> p $a->info => PDL: Double D [6,7,8,9] pdl> p $a_reorder->info => PDL: Double D [9,6,8,7] | | | | V V v V dimensions: 0 1 2 3 Notice what happened. When we wrote C we instructed PDL to: * Put dimension 3 first. * Put dimension 0 next. * Put dimension 2 next. * Put dimension 1 next. When you use the C method, all the dimensions are shuffled. Notice that C does not alter C<$a>. The original variable C<$a> remains untouched. =head1 GOTCHA: LINKING VS ASSIGNMENT =head2 Linking By default, piddles are B so that changes on one will go back and affect the original B. pdl> $a = sequence(4,5) pdl> $a_xchg = $a->xchg(1,0) Here, C<$a_xchg> B. It is merely a different way of looking at C<$a>. Any change in C<$a_xchg> will appear in C<$a> as well. pdl> p $a [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] [12 13 14 15] [16 17 18 19] ] pdl> $a_xchg += 3 pdl> p $a [ [ 3 4 5 6] [ 7 8 9 10] [11 12 13 14] [15 16 17 18] [19 20 21 22] ] =head2 Assignment Some times, linking is not the behaviour you want. If you want to make the piddles independent, use the C method: pdl> $a = sequence(4,5) pdl> $a_xchg = $a->copy->xchg(1,0) Now C<$a> and C<$a_xchg> are completely separate objects: pdl> p $a [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] [12 13 14 15] [16 17 18 19] ] pdl> $a_xchg += 3 pdl> p $a [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] [12 13 14 15] [16 17 18 19] ] pdl> $a_xchg [ [ 3 7 11 15 19] [ 4 8 12 16 20] [ 5 9 13 17 21] [ 6 10 14 18 22] ] =head1 PUTTING IT ALL TOGETHER Now we are ready to solve the problem that motivated this whole discussion: pdl> $a = sequence(11,9) pdl> $cols = sequence(9) pdl> pdl> p $a->info => PDL: Double D [11,9] pdl> p $cols->info => PDL: Double D [9] How do we tell PDL to subtract C<$cols> along dimension 1 instead of dimension 0? The simplest way is to use the C method and rely on PDL linking: pdl> p $a [ [ 0 1 2 3 4 5 6 7 8 9 10] [11 12 13 14 15 16 17 18 19 20 21] [22 23 24 25 26 27 28 29 30 31 32] [33 34 35 36 37 38 39 40 41 42 43] [44 45 46 47 48 49 50 51 52 53 54] [55 56 57 58 59 60 61 62 63 64 65] [66 67 68 69 70 71 72 73 74 75 76] [77 78 79 80 81 82 83 84 85 86 87] [88 89 90 91 92 93 94 95 96 97 98] ] pdl> $a->xchg(1,0) -= $cols pdl> p $a [ [ 0 1 2 3 4 5 6 7 8 9 10] [10 11 12 13 14 15 16 17 18 19 20] [20 21 22 23 24 25 26 27 28 29 30] [30 31 32 33 34 35 36 37 38 39 40] [40 41 42 43 44 45 46 47 48 49 50] [50 51 52 53 54 55 56 57 58 59 60] [60 61 62 63 64 65 66 67 68 69 70] [70 71 72 73 74 75 76 77 78 79 80] [80 81 82 83 84 85 86 87 88 89 90] ] =over 5 =item General Strategy: Move the dimensions you want to operate on to the start of your piddle's dimension list. Then let PDL thread over the higher dimensions. =back =head1 EXAMPLE: CONWAY'S GAME OF LIFE Okay, enough theory. Let's do something a bit more interesting: We'll write B in PDL and see how powerful PDL can be! The B is a simulation run on a big two dimensional grid. Each cell in the grid can either be alive or dead (represented by 1 or 0). The next generation of cells in the grid is calculated with simple rules according to the number of living cells in it's immediate neighbourhood: 1) If an empty cell has exactly three neighbours, a living cell is generated. 2) If a living cell has less than two neighbours, it dies of overfeeding. 3) If a living cell has 4 or more neighbours, it dies from starvation. Only the first generation of cells is determined by the programmer. After that, the simulation runs completely according to these rules. To calculate the next generation, you need to look at each cell in the 2D field (requiring two loops), calculate the number of live cells adjacent to this cell (requiring another two loops) and then fill the next generation grid. =head2 Classical implementation Here's a classic way of writing this program in Perl. We only use PDL for addressing individual cells. #!/usr/bin/perl -w use PDL; use PDL::NiceSlice; # Make a board for the game of life. my $nx = 20; my $ny = 20; # Current generation. my $a = zeroes($nx, $ny); # Next generation. my $n = zeroes($nx, $ny); # Put in a simple glider. $a(1:3,1:3) .= pdl ( [1,1,1], [0,0,1], [0,1,0] ); for (my $i = 0; $i < 100; $i++) { $n = zeroes($nx, $ny); $new_a = $a->copy; for ($x = 0; $x < $nx; $x++) { for ($y = 0; $y < $ny; $y++) { # For each cell, look at the surrounding neighbours. for ($dx = -1; $dx <= 1; $dx++) { for ($dy = -1; $dy <= 1; $dy++) { $px = $x + $dx; $py = $y + $dy; # Wrap around at the edges. if ($px < 0) {$px = $nx-1}; if ($py < 0) {$py = $ny-1}; if ($px >= $nx) {$px = 0}; if ($py >= $ny) {$py = 0}; $n($x,$y) .= $n($x,$y) + $a($px,$py); } } # Do not count the central cell itself. $n($x,$y) -= $a($x,$y); # Work out if cell lives or dies: # Dead cell lives if n = 3 # Live cell dies if n is not 2 or 3 if ($a($x,$y) == 1) { if ($n($x,$y) < 2) {$new_a($x,$y) .= 0}; if ($n($x,$y) > 3) {$new_a($x,$y) .= 0}; } else { if ($n($x,$y) == 3) {$new_a($x,$y) .= 1} } } } print $a; $a = $new_a; } If you run this, you will see a small glider crawl diagonally across the grid of zeroes. On my machine, it prints out a couple of generations per second. =head2 Threaded PDL implementation And here's the threaded version in PDL. Just four lines of PDL code, and one of those is printing out the latest generation! #!/usr/bin/perl -w use PDL; use PDL::NiceSlice; my $a = zeroes(20,20); # Put in a simple glider. $a(1:3,1:3) .= pdl ( [1,1,1], [0,0,1], [0,1,0] ); my $n; for (my $i = 0; $i < 100; $i++) { # Calculate the number of neighbours per cell. $n = $a->range(ndcoords($a)-1,3,"periodic")->reorder(2,3,0,1); $n = $n->sumover->sumover - $a; # Calculate the next generation. $a = ((($n == 2) + ($n == 3))* $a) + (($n==3) * !$a); print $a; } The threaded PDL version is much faster: Classical => 32.79 seconds. Threaded => 0.41 seconds. =head2 Explanation How does the threaded version work? There are many PDL functions designed to help you carry out PDL threading. In this example, the key functions are: =head3 Method: C At the simplest level, the C method is a different way to select a portion of a piddle. Instead of using the C<$a(2,3)> notation, we use another piddle. pdl> $a = sequence(6,7) pdl> p $a [ [ 0 1 2 3 4 5] [ 6 7 8 9 10 11] [12 13 14 15 16 17] [18 19 20 21 22 23] [24 25 26 27 28 29] [30 31 32 33 34 35] [36 37 38 39 40 41] ] pdl> p $a->range( pdl [1,2] ) 13 pdl> p $a(1,2) [ [13] ] At this point, the C method looks very similar to a regular PDL slice. But the C method is more general. For example, you can select several components at once: pdl> $index = pdl [ [1,2],[2,3],[3,4],[4,5] ] pdl> p $a->range( $index ) [13 20 27 34] Additionally, C takes a second parameter which determines the size of the chunk to return: pdl> $size = 3 pdl> p $a->range( pdl([1,2]) , $size ) [ [13 14 15] [19 20 21] [25 26 27] ] We can use this to select one or more 3x3 boxes. Finally, C can take a third parameter called the "boundary" condition. It tells PDL what to do if the size box you request goes beyond the edge of the piddle. We won't go over all the options. We'll just say that the option C means that the piddle "wraps around". For example: pdl> p $a [ [ 0 1 2 3 4 5] [ 6 7 8 9 10 11] [12 13 14 15 16 17] [18 19 20 21 22 23] [24 25 26 27 28 29] [30 31 32 33 34 35] [36 37 38 39 40 41] ] pdl> $size = 3 pdl> p $a->range( pdl([4,2]) , $size , "periodic" ) [ [16 17 12] [22 23 18] [28 29 24] ] pdl> p $a->range( pdl([5,2]) , $size , "periodic" ) [ [17 12 13] [23 18 19] [29 24 25] ] Notice how the box wraps around the boundary of the piddle. =head3 Method: C The C method is a convenience method that returns an enumerated list of coordinates suitable for use with the C method. pdl> p $piddle = sequence(3,3) [ [0 1 2] [3 4 5] [6 7 8] ] pdl> p ndcoords($piddle) [ [ [0 0] [1 0] [2 0] ] [ [0 1] [1 1] [2 1] ] [ [0 2] [1 2] [2 2] ] ] This can be a little hard to read. Basically it's saying that the coordinates for every element in C<$piddle> is given by: (0,0) (1,0) (2,0) (1,0) (1,1) (2,1) (2,0) (2,1) (2,2) =head3 Combining C and C What really matters is that C is designed to work together with C, with no C<$size> parameter, you get the same piddle back. pdl> p $piddle [ [0 1 2] [3 4 5] [6 7 8] ] pdl> p $piddle->range( ndcoords($piddle) ) [ [0 1 2] [3 4 5] [6 7 8] ] Why would this be useful? Because now we can ask for a series of "boxes" for the entire piddle. For example, 2x2 boxes: pdl> p $piddle->range( ndcoords($piddle) , 2 , "periodic" ) The output of this function is difficult to read because the "boxes" along the last two dimension. We can make the result more readable by rearranging the dimensions: pdl> p $piddle->range( ndcoords($piddle) , 2 , "periodic" )->reorder(2,3,0,1) [ [ [ [0 1] [3 4] ] [ [1 2] [4 5] ] ... ] Here you can see more clearly that [0 1] [3 4] Is the 2x2 box starting with the (0,0) element of C<$piddle>. We are not done yet. For the game of life, we want 3x3 boxes from C<$a>: pdl> p $a [ [ 0 1 2 3 4 5] [ 6 7 8 9 10 11] [12 13 14 15 16 17] [18 19 20 21 22 23] [24 25 26 27 28 29] [30 31 32 33 34 35] [36 37 38 39 40 41] ] pdl> p $a->range( ndcoords($a) , 3 , "periodic" )->reorder(2,3,0,1) [ [ [ [ 0 1 2] [ 6 7 8] [12 13 14] ] ... ] We can confirm that this is the 3x3 box starting with the (0,0) element of C<$a>. But there is one problem. We actually want the 3x3 box to be B on (0,0). That's not a problem. Just subtract 1 from all the coordinates in C. Remember that the "periodic" option takes care of making everything wrap around. pdl> p $a->range( ndcoords($a) - 1 , 3 , "periodic" )->reorder(2,3,0,1) [ [ [ [41 36 37] [ 5 0 1] [11 6 7] ] [ [36 37 38] [ 0 1 2] [ 6 7 8] ] ... Now we see a 3x3 box with the (0,0) element in the centre of the box. =head3 Method: C The C method adds along only the first dimension. If we apply it twice, we will be adding all the elements of each 3x3 box. pdl> $n = $a->range(ndcoords($a)-1,3,"periodic")->reorder(2,3,0,1) pdl> p $n [ [ [ [41 36 37] [ 5 0 1] [11 6 7] ] [ [36 37 38] [ 0 1 2] [ 6 7 8] ] ... pdl> p $n->sumover->sumover [ [144 135 144 153 162 153] [ 72 63 72 81 90 81] [126 117 126 135 144 135] [180 171 180 189 198 189] [234 225 234 243 252 243] [288 279 288 297 306 297] [216 207 216 225 234 225] ] Use a calculator to confirm that 144 is the sum of all the elements in the first 3x3 box and 135 is the sum of all the elements in the second 3x3 box. =head3 Counting neighbours We are almost there! Adding up all the elements in a 3x3 box is not B what we want. We don't want to count the center box. Fortunately, this is an easy fix: pdl> p $n->sumover->sumover - $a [ [144 134 142 150 158 148] [ 66 56 64 72 80 70] [114 104 112 120 128 118] [162 152 160 168 176 166] [210 200 208 216 224 214] [258 248 256 264 272 262] [180 170 178 186 194 184] ] When applied to Conway's Game of Life, this will tell us how many living neighbours each cell has: pdl> $a = zeroes(10,10) pdl> $a(1:3,1:3) .= pdl ( [1,1,1], ..( > [0,0,1], ..( > [0,1,0] ) pdl> p $a [ [0 0 0 0 0 0 0 0 0 0] [0 1 1 1 0 0 0 0 0 0] [0 0 0 1 0 0 0 0 0 0] [0 0 1 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] pdl> $n = $a->range(ndcoords($a)-1,3,"periodic")->reorder(2,3,0,1) pdl> $n = $n->sumover->sumover - $a pdl> p $n [ [1 2 3 2 1 0 0 0 0 0] [1 1 3 2 2 0 0 0 0 0] [1 3 5 3 2 0 0 0 0 0] [0 1 1 2 1 0 0 0 0 0] [0 1 1 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] For example, this tells us that cell (0,0) has 1 living neighbour, while cell (2,2) has 5 living neighbours. =head3 Calculating the next generation At this point, the variable C<$n> has the number of living neighbours for every cell. Now we apply the rules of the game of life to calculate the next generation. =over 5 =item If an empty cell has exactly three neighbours, a living cell is generated. Get a list of cells that have exactly three neighbours: pdl> p ($n == 3) [ [0 0 1 0 0 0 0 0 0 0] [0 0 1 0 0 0 0 0 0 0] [0 1 0 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] Get a list of B cells that have exactly three neighbours: pdl> p ($n == 3) * !$a =item If a living cell has less than 2 or more than 3 neighbours, it dies. Get a list of cells that have exactly 2 or 3 neighbours: pdl> p (($n == 2) + ($n == 3)) [ [0 1 1 1 0 0 0 0 0 0] [0 0 1 1 1 0 0 0 0 0] [0 1 0 1 1 0 0 0 0 0] [0 0 0 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] Get a list of B cells that have exactly 2 or 3 neighbours: pdl> p (($n == 2) + ($n == 3)) * $a =back Putting it all together, the next generation is: pdl> $a = ((($n == 2) + ($n == 3)) * $a) + (($n == 3) * !$a) pdl> p $a [ [0 0 1 0 0 0 0 0 0 0] [0 0 1 1 0 0 0 0 0 0] [0 1 0 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] =head2 Bonus feature: Graphics! If you have L installed, you can make a graphical version of the program by just changing three lines: #!/usr/bin/perl use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; my $a = zeroes(20,20); # Put in a simple glider. $a(1:3,1:3) .= pdl ( [1,1,1], [0,0,1], [0,1,0] ); my $n; for (my $i = 0; $i < 100; $i++) { # Calculate the number of neighbours per cell. $n = $a->range(ndcoords($a)-1,3,"periodic")->reorder(2,3,0,1); $n = $n->sumover->sumover - $a; # Calculate the next generation. $a = ((($n == 2) + ($n == 3))* $a) + (($n==3) * !$a); # Display. nokeeptwiddling3d(); imagrgb [$a]; } But if we really want to see something interesting, we should make a few more changes: 1) Start with a random collection of 1's and 0's. 2) Make the grid larger. 3) Add a small timeout so we can see the game evolve better. 4) Use a while loop so that the program can run as long as it needs to. #!/usr/bin/perl use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; use Time::HiRes qw(usleep); my $a = random(100,100); $a = ($a < 0.5); my $n; while (1) { # Calculate the number of neighbours per cell. $n = $a->range(ndcoords($a)-1,3,"periodic")->reorder(2,3,0,1); $n = $n->sumover->sumover - $a; # Calculate the next generation. $a = ((($n == 2) + ($n == 3))* $a) + (($n==3) * !$a); # Display. nokeeptwiddling3d(); imagrgb [$a]; # Sleep for 0.1 seconds. usleep(100000); } =head1 CONCLUSION: GENERAL STRATEGY The general strategy is: I Threading is a powerful tool that helps eliminate for-loops and can make your code more concise. Hopefully this tutorial has shown why it is worth getting to grips with threading in PDL. =head1 COPYRIGHT Copyright 2010 Matthew Kenworthy (kenworthy@strw.leidenuniv.nl) and Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.018/Basic/Pod/Tips.pod0000644060175006010010000000666513036512174013601 0ustar chmNone=head1 NAME PDL::Tips - Small tidbits of useful arcana. Programming tidbits and such. =head1 SYNOPSIS use PDL; # Whatever happens here. =head1 DESCRIPTION This page documents useful idioms, helpful hints and tips for using Perl Data Language v2.0. =head2 Help Use C within I or I or use the C program from the command line for access to the PerlDL documentation. HTML versions of the pages should also be present, in the F directory of the PDL distribution. To find this directory, try the following pdl> foreach ( map{"$_/PDL/HtmlDocs"}@INC ) { p "$_\n" if -d $_ } =head2 Indexing idioms The following code normalizes a bunch of vectors in $a. This works regardless of the dimensionality of $a. $a /= $a->sumover->dummy(0); =head2 What is actually happening? If you want to see what the code is actually doing, try the command PDL::Core::set_debugging(1); somewhere. This spews out a huge amount of debug info for PDL into STDOUT. Plans for the future include making it possible to redirect the output, and also making it possible to select messages with more precision. Many of the messages come from C and you can look at the source to see what is going on. If you have any extra time to work on these mechanisms, inform the pdl-porters mailing list. =head2 Memory savings If you are running recursively something that selects certain indices of a large piddle, like while(1) { $inds = where($a>0); $a = $a->index($inds); $b = $b->index($inds); func($b,$a); } If you are not writing to $b, it saves a lot of memory to change this to $b = $b->index($inds)->sever; The new method C is a causes the write-back relation to be forgotten. It is like copy except it changes the original piddle and returns it). Of course, the probably best way to do the above is $inds = xvals ($a->long); while(1) { $inds0 = where($a>0); $inds1 = $inds->index($inds)->sever; $a = $a0->index($inds1); $b = $b->index($inds1)->sever; func($b,$a); } which doesn't save all the temporary instances of $a in memory. See C in the Demos subdirectory of the PerlDL distribution for an example. =head2 PP speed If you really want to write speedy PP code, the first thing you need to do is to make sure that your C compiler is allowed to do the necessary optimizations. What this means is that you have to allow as many variables as possible to go into registers: loop(a) %{ $a() += $COMP(foo_member) * $b() %} expands to for(i=0; i<10000; i++) { a[i] += __privtrans->foo_member * b[i]; } is about the worst you can do, since your C compiler is not allowed to assume that C doesn't clobber C which completely inhibits vectorization. Instead, do float foo = $COMP(foo_member); loop(a) %{ $a() += foo * $b(); %} This is not a restriction caused by PP but by ANSI C semantics. Of course, we could copy the struct into local variables and back but that could cause very strange things sometimes. There are many other issues on organizing loops. We are currently planning to make PP able to do fixed-width things as well as physical piddles (where looping over the first dimensions would be cheaper as there are less distinct increments, which might make a difference on machines with a small number of registers). =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997. All rights reserved. Duplication in the same form and printing a copy for yourself allowed. PDL-2.018/Basic/Pod/Tutorials.pod0000644060175006010010000000704712562522363014647 0ustar chmNone=head1 NAME PDL::Tutorials - A guide to PDL's tutorial documentation. =head1 MIGRATION These are our migration guides for users familiar with other types of numerical analysis software. =over 5 =item L Migration guide for MATLAB users. This page explains the key differences between MATLAB and PDL from the point of view of a MATLAB user. =item L Migration guide for Scilab users. This page explains the key differences between Scilab and PDL from the point of view of a Scilab user. =back =head1 FOUNDATION =over 5 =item L Why did we write PDL? This document explains some of the history and motivation behind the Perl Data Language. It is an attempt to answer the question "Why PDL?". =item L Quick introduction to PDL features. A hands-on guide suitable for complete beginners. This page assumes no previous knowledge of Perl or PDL. =item L After you have read the QuickStart guide, you should follow up with this document. This guide goes more deeply into the concepts of "indexing" and "slicing" and how they form the core of numerical analysis with PDL. =back =head1 INTERMEDIATE =over 5 =item L B is one of PDL's most powerful features. If you know MATLAB, you've heard of "vectorizing". Well, B is like "vectorizing on steroids". It lets you make very fast and compact code by avoiding nested loops. All vector-based languages do this, but PDL generalizes the technique to all sorts of applications. This tutorial introduces PDL's threading feature, and it shows an example implementing Conway's Game of Life in 10 lines and 80 times faster than a classical implementation. =item L Sometimes it is useful to specify that a certain value is "bad" or "missing". Scientific instruments some times include portions of invalid data. For example, a CCD camera might produce an image with over-exposed pixels. PDL's "bad values" feature gives you an easy way to deal with this sort of imperfect data. =item L Tips and suggestions for using PDL. This page is an assorted collection of programming tidbits that some PDL users have found useful. Some of these tips might be of help when you write your programs. =back =head1 ADVANCED =over 5 =item L PDL's Pre-Processor is one of PDL's most powerful features. You write a function definition in special markup and the preprocessor generates real C code which can be compiled. With PDL:PP you get the full speed of native C code without having to deal with the full complexity of the C language. =item L A simple cookbook explaining how to create piddle manually, either from Perl or from C/XS code. This page covers the PDL core routines that comprise the PDL API. If you need to access piddles from C/XS, this is the document for you. =item L Description of the inner workings of the PDL module. Very few people need to see this. This page is mainly for PDL developers, or people interested in debugging PDL or changing the internals of PDL. If you can read this document and understand all of it, and you additionally understand L, you will be awarded the title of "PDL Guru". =back =head1 COPYRIGHT Copyright 2010 Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.018/Basic/Primitive/0000755060175006010010000000000013110402045013353 5ustar chmNonePDL-2.018/Basic/Primitive/Makefile.PL0000644060175006010010000000325412562522363015351 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; my @pack = (["primitive.pd", qw(Primitive PDL::Primitive)]); if ($^O eq 'dec_osf') { require Config; if ($Config::Config{cc} =~ /^cc/) { my $no_optimize = ($::PDL_OPTIONS{OPTIMIZE} && $::PDL_OPTIONS{OPTIMIZE}) || $Config::Config{optimize} || '-g2'; $no_optimize =~ s/(\s|^)(-O)\d/$1${2}0/; $no_optimize =~ s/(\s|^)(-g)\d/$1${2}2/; print <SUPER::const_cccmd(@_); $defval =~ s/\$\(OPTIMIZE\)/| . $no_optimize . q|/gs; print "$defval\n"; return $defval; }; |; } } my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS}->[0] .= ' -lm'; # If we don't do this, and Perl core is using the wrapped API, then it will # call (say) srand48_r(), and get its random numbers from drand48_r(), but we # will get ours from drand48(), and srand48() never gets called. $hash{CCFLAGS} ||= $Config{ccflags}; $hash{CCFLAGS} .= ' -DPERL_REENTR_API'; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Basic/Primitive/primitive.pd0000644060175006010010000027561713107136133015742 0ustar chmNoneuse strict; # check for bad value support use PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; pp_addhdr(<<'EOD'); #ifndef RAND_MAX #error "You must have a working RAND_MAX! Something's wrong with your include files" #endif EOD pp_addpm({At=>'Top'},<<'EOD'); use PDL::Slices; use Carp; =head1 NAME PDL::Primitive - primitive operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP and able to use the new indexing tricks. See L for how to use indices creatively. For explanation of the signature format, see L. =head1 SYNOPSIS # Pulls in PDL::Primitive, among other modules. use PDL; # Only pull in PDL::Primitive: use PDL::Primitive; =cut EOD =head1 FUNCTIONS =cut ################################################################ # a whole bunch of quite basic functions for inner, outer # and matrix products (operations that are not normally # available via operator overloading) ################################################################ =head2 inner =for sig Signature: (a(n); b(n); [o]c()) =cut pp_def( 'inner', HandleBad => 1, Pars => 'a(n); b(n); [o]c();', Code => 'double tmp = 0; loop(n) %{ tmp += $a() * $b(); %} $c() = tmp;', BadCode => 'double tmp = 0; int badflag = 0; loop(n) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) ) { tmp += $a() * $b(); } else { badflag = 1; } %} if ( badflag ) { $SETBAD(c()); $PDLSTATESETBAD(c); } else { $c() = tmp; }', CopyBadStatusCode => '', Doc => ' =for ref Inner product over one dimension c = sum_i a_i * b_i =cut ', BadDoc => ' =for bad If C contains only bad data, C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut ', ); # pp_def( inner ) =head2 outer =for sig Signature: (a(n); b(m); [o]c(n,m)) =cut pp_def( 'outer', HandleBad => 1, Pars => 'a(n); b(m); [o]c(n,m);', Code => 'loop(n,m) %{ $c() = $a() * $b(); %}', BadCode => 'loop(n,m) %{ if ( $ISBAD(a()) || $ISBAD(b()) ) { $SETBAD(c()); } else { $c() = $a() * $b(); } %}', Doc => ' =for ref outer product over one dimension Naturally, it is possible to achieve the effects of outer product simply by threading over the "C<*>" operator but this function is provided for convenience. =cut '); # pp_def( outer ) pp_addpm(<<'EOD'); =head2 x =for sig Signature: (a(i,z), b(x,i),[o]c(x,z)) =for ref Matrix multiplication PDL overloads the C operator (normally the repeat operator) for matrix multiplication. The number of columns (size of the 0 dimension) in the left-hand argument must normally equal the number of rows (size of the 1 dimension) in the right-hand argument. Row vectors are represented as (N x 1) two-dimensional PDLs, or you may be sloppy and use a one-dimensional PDL. Column vectors are represented as (1 x N) two-dimensional PDLs. Threading occurs in the usual way, but as both the 0 and 1 dimension (if present) are included in the operation, you must be sure that you don't try to thread over either of those dims. EXAMPLES Here are some simple ways to define vectors and matrices: pdl> $r = pdl(1,2); # A row vector pdl> $c = pdl([[3],[4]]); # A column vector pdl> $c = pdl(3,4)->(*1); # A column vector, using NiceSlice pdl> $m = pdl([[1,2],[3,4]]); # A 2x2 matrix Now that we have a few objects prepared, here is how to matrix-multiply them: pdl> print $r x $m # row x matrix = row [ [ 7 10] ] pdl> print $m x $r # matrix x row = ERROR PDL: Dim mismatch in matmult of [2x2] x [2x1]: 2 != 1 pdl> print $m x $c # matrix x column = column [ [ 5] [11] ] pdl> print $m x 2 # Trivial case: scalar mult. [ [2 4] [6 8] ] pdl> print $r x $c # row x column = scalar [ [11] ] pdl> print $c x $r # column x row = matrix [ [3 6] [4 8] ] INTERNALS The mechanics of the multiplication are carried out by the L method. =cut EOD pp_add_exported('', 'matmult'); pp_def('matmult', HandleBad=>0, Pars => 'a(t,h); b(w,t); [o]c(w,h);', PMCode => <<'EOPM', sub PDL::matmult { my ($a,$b,$c) = @_; $b = pdl($b) unless eval { $b->isa('PDL') }; $c = PDL->null unless eval { $c->isa('PDL') }; while($a->getndims < 2) {$a = $a->dummy(-1)} while($b->getndims < 2) {$b = $b->dummy(-1)} return ($c .= $a * $b) if( ($a->dim(0)==1 && $a->dim(1)==1) || ($b->dim(0)==1 && $b->dim(1)==1) ); if($b->dim(1) != $a->dim(0)) { barf(sprintf("Dim mismatch in matmult of [%dx%d] x [%dx%d]: %d != %d",$a->dim(0),$a->dim(1),$b->dim(0),$b->dim(1),$a->dim(0),$b->dim(1))); } PDL::_matmult_int($a,$b,$c); $c; } EOPM Code => <<'EOC', PDL_Indx ih, iw, it, ow, oh, ot, wlim, hlim, tlim; $GENERIC() *ad, *bd, *cd; PDL_Indx atdi, btdi; PDL_Indx resh, resw, rest; PDL_Indx tsiz = 64; // Zero the output loop(w) %{ loop(h) %{ $c() = 0; %} %} // Make sure we're physical // (Not needed if we don't need dimincs, see below) // PDL->make_physdims($PDL(a)); // PDL->make_physdims($PDL(b)); // Cache the dimincs to avoid constant lookups // These two lines are what I wanted, but they break sometimes (dimincs not set right despite calling physdims?) // I deleted them in favor of explicit offset calculation, which appears more robust. // atdi = $PDL(a)->dimincs[0]; // btdi = $PDL(b)->dimincs[1]; atdi = &($a(t=>1, h=>0)) - &($a(t=>0,h=>0)); btdi = &($b(t=>1, w=>0)) - &($b(t=>0,w=>0)); // Loop over tiles for( oh=0; oh < $SIZE(h); oh += tsiz ) { hlim = ( oh + tsiz > $SIZE(h) ) ? $SIZE(h) : oh + tsiz; for( ow=0; ow < $SIZE(w); ow += tsiz ) { wlim = ( ow + tsiz > $SIZE(w) ) ? $SIZE(w) : ow + tsiz; for( ot=0; ot < $SIZE(t); ot += tsiz ) { tlim = (ot + tsiz > $SIZE(t) ) ? $SIZE(t) : ot + tsiz; for( ih=oh; ihot, h=>ih)); bd = &($b(w=>iw, t=>ot)); // Cache the accumulated value for the output cc = $c(w=>iw, h=>ih); // Hotspot - run the 't' summation for( it=ot; itiw, h=>ih) = cc; } } } } } EOC Doc => <<'EOD' =for ref Matrix multiplication Notionally, matrix multiplication $a x $b is equivalent to the threading expression $a->dummy(1)->inner($b->xchg(0,1)->dummy(2),$c); but for large matrices that breaks CPU cache and is slow. Instead, matmult calculates its result in 32x32x32 tiles, to keep the memory footprint within cache as long as possible on most modern CPUs. For usage, see L, a description of the overloaded 'x' operator EOD ); =head2 innerwt =for sig Signature: (a(n); b(n); c(n); [o]d()) =cut pp_def( 'innerwt', HandleBad => 1, Pars => 'a(n); b(n); c(n); [o]d();', Code => 'double tmp = 0; loop(n) %{ tmp += $a() * $b() * $c(); %} $d() = tmp;', BadCode => 'double tmp = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) && $ISGOOD(c()) ) { tmp += $a() * $b() * $c(); flag = 1; } %} if ( flag ) { $d() = tmp; } else { $SETBAD(d()); }', Doc => ' =for ref Weighted (i.e. triple) inner product d = sum_i a(i) b(i) c(i) =cut ' ); =head2 inner2 =for sig Signature: (a(n); b(n,m); c(m); [o]d()) =cut pp_def( 'inner2', HandleBad => 1, Pars => 'a(n); b(n,m); c(m); [o]d();', Code => 'double tmp=0; loop(n,m) %{ tmp += $a() * $b() * $c(); %} $d() = tmp;', BadCode => 'double tmp = 0; int flag = 0; loop(n,m) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) && $ISGOOD(c()) ) { tmp += $a() * $b() * $c(); flag = 1; } %} if ( flag ) { $d() = tmp; } else { $SETBAD(d()); }', Doc => ' =for ref Inner product of two vectors and a matrix d = sum_ij a(i) b(i,j) c(j) Note that you should probably not thread over C and C since that would be very wasteful. Instead, you should use a temporary for C. =cut ' ); =head2 inner2d =for sig Signature: (a(n,m); b(n,m); [o]c()) =cut pp_def( 'inner2d', HandleBad => 1, Pars => 'a(n,m); b(n,m); [o]c();', Code => 'double tmp=0; loop(n,m) %{ tmp += $a() * $b(); %} $c() = tmp;', BadCode => 'double tmp = 0; int flag = 0; loop(n,m) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) ) { tmp += $a() * $b(); flag = 1; } %} if ( flag ) { $c() = tmp; } else { $SETBAD(c()); }', Doc => ' =for ref Inner product over 2 dimensions. Equivalent to $c = inner($a->clump(2), $b->clump(2)) =cut ' ); =head2 inner2t =for sig Signature: (a(j,n); b(n,m); c(m,k); [t]tmp(n,k); [o]d(j,k))) =cut pp_def( 'inner2t', HandleBad => 1, Pars => 'a(j,n); b(n,m); c(m,k); [t]tmp(n,k); [o]d(j,k));', Code => 'loop(n,k) %{ double tmp0 = 0; loop(m) %{ tmp0 += $b() * $c(); %} $tmp() = tmp0; %} loop(j,k) %{ double tmp1 = 0; loop(n) %{ tmp1 += $a() * $tmp(); %} $d() = tmp1; %}', BadCode => 'loop(n,k) %{ double tmp0 = 0; int flag = 0; loop(m) %{ if ( $ISGOOD(b()) && $ISGOOD(c()) ) { tmp0 += $b() * $c(); flag = 1; } %} if ( flag ) { $tmp() = tmp0; } else { $SETBAD(tmp()); } %} loop(j,k) %{ double tmp1 = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) && $ISGOOD(tmp()) ) { tmp1 += $a() * $tmp(); flag = 1; } %} if ( flag ) { $d() = tmp1; } else { $SETBAD(d()); } %}', Doc => ' =for ref Efficient Triple matrix product C Efficiency comes from by using the temporary C. This operation only scales as C whereas threading using L would scale as C. The reason for having this routine is that you do not need to have the same thread-dimensions for C as for the other arguments, which in case of large numbers of matrices makes this much more memory-efficient. It is hoped that things like this could be taken care of as a kind of closures at some point. =cut ' ); # pp_def inner2t() # a helper function for the cross product definition sub crassgn { "\$c(tri => $_[0]) = \$a(tri => $_[1])*\$b(tri => $_[2]) - \$a(tri => $_[2])*\$b(tri => $_[1]);" } =head2 crossp =for sig Signature: (a(tri=3); b(tri); [o] c(tri)) =cut pp_def('crossp', Doc => <<'EOD', =for ref Cross product of two 3D vectors After =for example $c = crossp $a, $b the inner product C<$c*$a> and C<$c*$b> will be zero, i.e. C<$c> is orthogonal to C<$a> and C<$b> =cut EOD Pars => 'a(tri=3); b(tri); [o] c(tri)', Code => crassgn(0,1,2)."\n". crassgn(1,2,0)."\n". crassgn(2,0,1), ); =head2 norm =for sig Signature: (vec(n); [o] norm(n)) Normalises a vector to unit Euclidean length =cut pp_def('norm', HandleBad => 1, Pars => 'vec(n); [o] norm(n)', Doc => 'Normalises a vector to unit Euclidean length', Code => 'double sum=0; loop(n) %{ sum += $vec()*$vec(); %} if (sum > 0) { sum = sqrt(sum); loop(n) %{ $norm() = $vec()/sum; %} } else { loop(n) %{ $norm() = $vec(); %} }', BadCode => 'double sum=0; int flag = 0; loop(n) %{ if ( $ISGOOD(vec()) ) { sum += $vec()*$vec(); flag = 1; } %} if ( flag ) { if (sum > 0) { sum = sqrt(sum); loop(n) %{ if ( $ISBAD(vec()) ) { $SETBAD(norm()); } else { $norm() = $vec()/sum; } %} } else { loop(n) %{ if ( $ISBAD(vec()) ) { $SETBAD(norm()); } else { $norm() = $vec(); } %} } } else { loop(n) %{ $SETBAD(norm()); %} }', ); # this one was motivated by the need to compute # the circular mean efficiently # without it could not be done efficiently or without # creating large intermediates (check pdl-porters for # discussion) # see PDL::ImageND for info about the circ_mean function =head2 indadd =for sig Signature: (a(); indx ind(); [o] sum(m)) =cut pp_def( 'indadd', HandleBad => 1, Pars => 'a(); indx ind(); [o] sum(m)', Code => 'register PDL_Indx foo = $ind(); if( foo<0 || foo>=$SIZE(m) ) { barf("PDL::indadd: invalid index"); } $sum(m => foo) += $a();', BadCode => 'register PDL_Indx foo = $ind(); if( $ISBADVAR(foo,ind) || foo<0 || foo>=$SIZE(m) ) { barf("PDL::indadd: invalid index"); } if ( $ISBAD(a()) ) { $SETBAD(sum(m => foo)); } else { $sum(m => foo) += $a(); }', BadDoc => ' =for bad The routine barfs if any of the indices are bad. =cut ', Doc=>' =for ref Threaded Index Add: Add C to the C element of C, i.e: sum(ind) += a =for example Simple Example: $a = 2; $ind = 3; $sum = zeroes(10); indadd($a,$ind, $sum); print $sum #Result: ( 2 added to element 3 of $sum) # [0 0 0 2 0 0 0 0 0 0] Threaded Example: $a = pdl( 1,2,3); $ind = pdl( 1,4,6); $sum = zeroes(10); indadd($a,$ind, $sum); print $sum."\n"; #Result: ( 1, 2, and 3 added to elements 1,4,6 $sum) # [0 1 0 0 2 0 3 0 0 0] =cut '); =head2 conv1d =for sig Signature: (a(m); kern(p); [o]b(m); int reflect) =cut # 1D convolution # useful for threaded 1D filters pp_addhdr(' /* Fast Modulus with proper negative behaviour */ #define REALMOD(a,b) while ((a)>=(b)) (a) -= (b); while ((a)<0) (a) += (b); '); pp_def('conv1d', Doc => << 'EOD', =for ref 1D convolution along first dimension The m-th element of the discrete convolution of an input piddle C<$a> of size C<$M>, and a kernel piddle C<$kern> of size C<$P>, is calculated as n = ($P-1)/2 ==== \ ($a conv1d $kern)[m] = > $a_ext[m - n] * $kern[n] / ==== n = -($P-1)/2 where C<$a_ext> is either the periodic (or reflected) extension of C<$a> so it is equal to C<$a> on C< 0..$M-1 > and equal to the corresponding periodic/reflected image of C<$a> outside that range. =for example $con = conv1d sequence(10), pdl(-1,0,1); $con = conv1d sequence(10), pdl(-1,0,1), {Boundary => 'reflect'}; By default, periodic boundary conditions are assumed (i.e. wrap around). Alternatively, you can request reflective boundary conditions using the C option: {Boundary => 'reflect'} # case in 'reflect' doesn't matter The convolution is performed along the first dimension. To apply it across another dimension use the slicing routines, e.g. $b = $a->mv(2,0)->conv1d($kernel)->mv(0,2); # along third dim This function is useful for threaded filtering of 1D signals. Compare also L, L, L, L, L =for bad WARNING: C processes bad values in its inputs as the numeric value of C<< $pdl->badvalue >> so it is not recommended for processing pdls with bad values in them unless special care is taken. =cut EOD Pars => 'a(m); kern(p); [o]b(m);', OtherPars => 'int reflect;', HandleBad => 0, PMCode => ' sub PDL::conv1d { my $opt = pop @_ if ref($_[$#_]) eq \'HASH\'; die \'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )\' if $#_<1 || $#_>2; my($a,$kern) = @_; my $c = $#_ == 2 ? $_[2] : PDL->null; &PDL::_conv1d_int($a,$kern,$c, !(defined $opt && exists $$opt{Boundary}) ? 0 : lc $$opt{Boundary} eq "reflect"); return $c; } ', Code => ' int i,i1,i2,poff,pflip; double tmp; int reflect = $COMP(reflect); int m_size = $COMP(__m_size); int p_size = $COMP(__p_size); poff = (p_size-1)/2; for(i=0; i=m_size) i2 = m_size-(i2-m_size+1); REALMOD(i2,m_size); tmp += $a(m=>i2) * $kern(p=>pflip); } $b(m=>i) = tmp; } '); =head2 in =for sig Signature: (a(); b(n); [o] c()) =cut # this can be achieved by # ($a->dummy(0) == $b)->orover # but this one avoids a larger intermediate and potentially shortcuts pp_def('in', Pars => 'a(); b(n); [o] c()', Code => '$c() = 0; loop(n) %{ if ($a() == $b()) {$c() = 1; break;} %}', Doc => <<'EOD', =for ref test if a is in the set of values b =for example $goodmsk = $labels->in($goodlabels); print pdl(3,1,4,6,2)->in(pdl(2,3,3)); [1 0 0 0 1] C is akin to the I of set theory. In principle, PDL threading could be used to achieve its functionality by using a construct like $msk = ($labels->dummy(0) == $goodlabels)->orover; However, C doesn't create a (potentially large) intermediate and is generally faster. =cut EOD ); pp_add_exported ('', 'uniq'); pp_addpm (<< 'EOPM'); =head2 uniq =for ref return all unique elements of a piddle The unique elements are returned in ascending order. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniq [-1 0 2 4 6] # 0 is returned 2nd (sorted order) PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniq [-1 2 4 6 nan] # NaN value is returned at end Note: The returned pdl is 1D; any structure of the input piddle is lost. C values are never compare equal to any other values, even themselves. As a result, they are always unique. C returns the NaN values at the end of the result piddle. This follows the Matlab usage. See L if you need the indices of the unique elements rather than the values. =cut EOPM if ( $bvalflag ) { pp_addpm(<<'EOPM'); =for bad Bad values are not considered unique by uniq and are ignored. $a=sequence(10); $a=$a->setbadif($a%3); print $a->uniq; [0 3 6 9] =cut EOPM } # if: $bvalflag pp_addpm(<<'EOPM'); *uniq = \&PDL::uniq; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniq { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) my $srt = $arr->clump(-1)->where($arr==$arr)->qsort; # no NaNs or BADs for qsort my $nans = $arr->clump(-1)->where($arr!=$arr); my $uniq = ($srt->nelem > 0) ? $srt->where($srt != $srt->rotate(-1)) : $srt; # make sure we return something if there is only one value my $answ = $nans; # NaN values always uniq if ( $uniq->nelem > 0 ) { $answ = $uniq->append($answ); } else { $answ = ( ($srt->nelem == 0) ? $srt : PDL::pdl( ref($srt), [$srt->index(0)] ) )->append($answ); } return $answ; } EOPM pp_add_exported ('', 'uniqind'); pp_addpm (<< 'EOPM'); =head2 uniqind =for ref Return the indices of all unique elements of a piddle The order is in the order of the values to be consistent with uniq. C values never compare equal with any other value and so are always unique. This follows the Matlab usage. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniqind [5 4 1 3 6] # the 0 at index 4 is returned 2nd, but... PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniqind [5 1 3 6 4] # ...the NaN at index 4 is returned at end Note: The returned pdl is 1D; any structure of the input piddle is lost. See L if you want the unique values instead of the indices. =cut EOPM if ($bvalflag ) { pp_addpm(<<'EOPM'); =for bad Bad values are not considered unique by uniqind and are ignored. =cut EOPM } # if: $bvalflag pp_addpm(<<'EOPM'); *uniqind = \&PDL::uniqind; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniqind { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) # Different from uniq we sort and store the result in an intermediary my $aflat = $arr->flat; my $nanind = which($aflat!=$aflat); # NaN indexes my $good = $aflat->sequence->long->where($aflat==$aflat); # good indexes my $i_srt = $aflat->where($aflat==$aflat)->qsorti; # no BAD or NaN values for qsorti my $srt = $aflat->where($aflat==$aflat)->index($i_srt); my $uniqind; if ($srt->nelem > 0) { $uniqind = which($srt != $srt->rotate(-1)); $uniqind = $i_srt->slice('0') if $uniqind->isempty; } else { $uniqind = which($srt); } # Now map back to the original space my $ansind = $nanind; if ( $uniqind->nelem > 0 ) { $ansind = ($good->index($i_srt->index($uniqind)))->append($ansind); } else { $ansind = $uniqind->append($ansind); } return $ansind; } EOPM pp_add_exported ('', 'uniqvec'); pp_addpm (<< 'EOPM'); =head2 uniqvec =for ref Return all unique vectors out of a collection NOTE: If any vectors in the input piddle have NaN values they are returned at the end of the non-NaN ones. This is because, by definition, NaN values never compare equal with any other value. NOTE: The current implementation does not sort the vectors containing NaN values. The unique vectors are returned in lexicographically sorted ascending order. The 0th dimension of the input PDL is treated as a dimensional index within each vector, and the 1st and any higher dimensions are taken to run across vectors. The return value is always 2D; any structure of the input PDL (beyond using the 0th dimension for vector index) is lost. See also L for a unique list of scalars; and L for sorting a list of vectors lexicographcally. =cut EOPM if ( $bvalflag ) { pp_addpm(<<'EOPM'); =for bad If a vector contains all bad values, it is ignored as in L. If some of the values are good, it is treated as a normal vector. For example, [1 2 BAD] and [BAD 2 3] could be returned, but [BAD BAD BAD] could not. Vectors containing BAD values will be returned after any non-NaN and non-BAD containing vectors, followed by the NaN vectors. =cut EOPM } # if: $bvalflag pp_addpm(<<'EOPM'); sub PDL::uniqvec { my($pdl) = shift; return $pdl if ( $pdl->nelem == 0 || $pdl->ndims < 2 ); return $pdl if ( $pdl->slice("(0)")->nelem < 2 ); # slice isn't cheap but uniqvec isn't either my $pdl2d = null; $pdl2d = $pdl->mv(0,-1)->clump($pdl->ndims-1)->mv(-1,0); # clump all but dim(0) my $ngood = null; $ngood = $pdl2d->ones->sumover; $ngood = $pdl2d->ngoodover if ($PDL::Bad::Status && $pdl->badflag); # number of good values each vector my $ngood2 = null; $ngood2 = $ngood->where($ngood); # number of good values with no all-BADs $pdl2d = $pdl2d->mv(0,-1)->dice($ngood->which)->mv(-1,0); # remove all-BAD vectors my $numnan = null; $numnan = ($pdl2d!=$pdl2d)->sumover; # works since no all-BADs to confuse my $presrt = null; $presrt = $pdl2d->mv(0,-1)->dice($numnan->not->which)->mv(0,-1); # remove vectors with any NaN values my $nanvec = null; $nanvec = $pdl2d->mv(0,-1)->dice($numnan->which)->mv(0,-1); # the vectors with any NaN values # use dice instead of nslice since qsortvec might be packing # the badvals to the front of the array instead of the end like # the docs say. If that is the case and it gets fixed, it won't # bust uniqvec. DAL 14-March 2006 my $srt = null; $srt = $presrt->qsortvec->mv(0,-1); # BADs are sorted by qsortvec my $srtdice = $srt; my $somebad = null; if ($PDL::Bad::Status && $srt->badflag) { $srtdice = $srt->dice($srt->mv(0,-1)->nbadover->not->which); $somebad = $srt->dice($srt->mv(0,-1)->nbadover->which); } my $uniq = null; if ($srtdice->nelem > 0) { $uniq = ($srtdice != $srtdice->rotate(-1))->mv(0,-1)->orover->which; } else { $uniq = $srtdice->orover->which; } my $ans = null; if ( $uniq->nelem > 0 ) { $ans = $srtdice->dice($uniq); } else { $ans = ($srtdice->nelem > 0) ? $srtdice->slice("0,:") : $srtdice; } return $ans->append($somebad)->append($nanvec->mv(0,-1))->mv(0,-1); } EOPM ##################################################################### # clipping routines ##################################################################### # clipping =head2 hclip =for sig Signature: (a(); b(); [o] c()) clip (threshold) C<$a> by C<$b> (C<$b> is upper bound) =head2 lclip =for sig Signature: (a(); b(); [o] c()) clip (threshold) C<$a> by C<$b> (C<$b> is lower bound) =cut for my $opt ( ['hclip','>'], ['lclip','<'] ) { my $name = $opt->[0]; my $op = $opt->[1]; pp_def( $name, HandleBad => 1, Pars => 'a(); b(); [o] c()', Code => '$c() = ($a() '.$op.' $b()) ? $b() : $a();', BadCode => 'if ( $ISBAD(a()) || $ISBAD(b()) ) { $SETBAD(c()); } else { $c() = ($a() '.$op.' $b()) ? $b() : $a(); }', Doc => 'clip (threshold) C<$a> by C<$b> (C<$b> is '. ($name eq 'hclip' ? 'upper' : 'lower').' bound)', PMCode=><<"EOD", sub PDL::$name { my (\$a,\$b) = \@_; my \$c; if (\$a->is_inplace) { \$a->set_inplace(0); \$c = \$a; } elsif (\$#_ > 1) {\$c=\$_[2]} else {\$c=PDL->nullcreate(\$a)} &PDL::_${name}_int(\$a,\$b,\$c); return \$c; } EOD ); # pp_def $name } # for: my $opt pp_add_exported('', 'clip'); pp_addpm(<<'EOD'); =head2 clip =for ref Clip (threshold) a piddle by (optional) upper or lower bounds. =for usage $b = $a->clip(0,3); $c = $a->clip(undef, $x); =cut EOD if ( $bvalflag ) { pp_addpm(<<'EOD'); =for bad clip handles bad values since it is just a wrapper around L and L. =cut EOD } # if: $bvalflag pp_def( 'clip', HandleBad => 1, Pars => 'a(); l(); h(); [o] c()', Code => '$c() = ( $a() > $h() ) ? $h() : ( $a() < $l() ? $l() : $a() );', BadCode => <<'EOBC', if( $ISBAD(a()) || $ISBAD(l()) || $ISBAD(h()) ) { $SETBAD(c()); } else { $c() = ( $a() > $h() ) ? $h() : ( $a() < $l() ? $l() : $a() ); } EOBC PMCode => <<'EOPM', *clip = \&PDL::clip; sub PDL::clip { my($a, $l, $h) = @_; my $d; unless(defined($l) || defined($h)) { # Deal with pathological case if($a->is_inplace) { $a->set_inplace(0); return $a; } else { return $a->copy; } } if($a->is_inplace) { $a->set_inplace(0); $d = $a } elsif ($#_ > 2) { $d=$_[3] } else { $d = PDL->nullcreate($a); } if(defined($l) && defined($h)) { &PDL::_clip_int($a,$l,$h,$d); } elsif( defined($l) ) { &PDL::_lclip_int($a,$l,$d); } elsif( defined($h) ) { &PDL::_hclip_int($a,$h,$d); } else { die "This can't happen (clip contingency) - file a bug"; } return $d; } EOPM ); # end of clip pp_def call ############################################################ # elementary statistics and histograms ############################################################ =head2 wtstat =for sig Signature: (a(n); wt(n); avg(); [o]b(); int deg) =cut pp_def( 'wtstat', HandleBad => 1, Pars => 'a(n); wt(n); avg(); [o]b();', OtherPars => 'int deg', Code => 'double wtsum = 0; double statsum = 0; loop(n) %{ register double tmp; register int i; wtsum += $wt(); tmp=1; for(i=0; i<$COMP(deg); i++) tmp *= $a(); statsum += $wt() * (tmp - $avg()); %} $b() = statsum / wtsum;', BadCode => 'double wtsum = 0; double statsum = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(wt()) && $ISGOOD(a()) && $ISGOOD(avg()) ) { register double tmp; register int i; wtsum += $wt(); tmp=1; for(i=0; i<$COMP(deg); i++) tmp *= $a(); statsum += $wt() * (tmp - $avg()); flag = 1; } %} if ( flag ) { $b() = statsum / wtsum; } else { $SETBAD(b()); $PDLSTATESETBAD(b); }', CopyBadStatusCode => '', Doc => ' =for ref Weighted statistical moment of given degree This calculates a weighted statistic over the vector C. The formula is b() = (sum_i wt_i * (a_i ** degree - avg)) / (sum_i wt_i) =cut ', BadDoc => ' =for bad Bad values are ignored in any calculation; C<$b> will only have its bad flag set if the output contains any bad data. =cut ', ); pp_def('statsover', HandleBad => 1, Pars => 'a(n); w(n); float+ [o]avg(); float+ [o]prms(); int+ [o]median(); int+ [o]min(); int+ [o]max(); float+ [o]adev(); float+ [o]rms()', Code => '$GENERIC(avg) tmp = 0; $GENERIC(avg) tmp1 = 0; $GENERIC(avg) diff = 0; $GENERIC(min) curmin, curmax; $GENERIC(avg) norm = 0; loop(n) %{ /* Accumulate sum and summed weight. */ tmp += $a()*$w(); norm += ($GENERIC(avg)) $w(); if (!n) { curmin = $a(); curmax = $a();} if ($a() < curmin) { curmin = $a(); } else if ($a() > curmax) { curmax = $a(); } %} $avg() = tmp / norm; /* Find mean */ $min() = curmin; $max() = curmax; /* Calculate the RMS and standard deviation. */ tmp = 0; loop(n) %{ diff = ($a() - $avg()); tmp += diff * diff * $w(); tmp1 += fabs(diff) * $w(); %} $rms() = sqrt ( tmp/norm ); $prms() = (norm>1) ? sqrt( tmp/(norm-1) ) : 0; $adev() = tmp1/norm ; ', BadCode => '$GENERIC(avg) tmp = 0; $GENERIC(avg) tmp1 = 0; $GENERIC(avg) diff = 0; $GENERIC(min) curmin, curmax; $GENERIC(w) norm = 0; int flag = 0; loop(n) %{ /* perhaps should check w() for bad values too ? */ if ( $ISGOOD(a()) ) { tmp += $a()*$w(); norm += $w(); if (!flag) { curmin = $a(); curmax = $a(); flag=1; } if ($a() < curmin) { curmin = $a(); } else if ($a() > curmax) { curmax = $a(); } } %} /* have at least one valid point if flag == 1 */ if ( flag ) { $avg() = tmp / norm; /* Find mean */ $min() = curmin; $max() = curmax; /* Calculate the RMS and standard deviation. */ tmp = 0; loop(n) %{ if ($ISGOOD(a())) { diff = $a()-$avg(); tmp += diff * diff * $w(); tmp1 += fabs(diff) * $w(); } %} $rms() = sqrt( tmp/norm ); if(norm>1) $prms() = sqrt( tmp/(norm-1) ); else $SETBAD(prms()); $adev() = tmp1 / norm ; } else { $SETBAD(avg()); $PDLSTATESETBAD(avg); $SETBAD(rms()); $PDLSTATESETBAD(rms); $SETBAD(adev()); $PDLSTATESETBAD(adev); $SETBAD(min()); $PDLSTATESETBAD(min); $SETBAD(max()); $PDLSTATESETBAD(max); $SETBAD(prms()); $PDLSTATESETBAD(prms); }', CopyBadStatusCode => '', PMCode => ' sub PDL::statsover { barf(\'Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($data,[$weights])\') if $#_>1; my ($data, $weights) = @_; $weights = $data->ones() if !defined($weights); my $median = $data->medover(); my $mean = PDL->nullcreate($data); my $rms = PDL->nullcreate($data); my $min = PDL->nullcreate($data); my $max = PDL->nullcreate($data); my $adev = PDL->nullcreate($data); my $prms = PDL->nullcreate($data); &PDL::_statsover_int($data, $weights, $mean, $prms, $median, $min, $max, $adev, $rms); return $mean unless wantarray; return ($mean, $prms, $median, $min, $max, $adev, $rms); } ', Doc => ' =for ref Calculate useful statistics over a dimension of a piddle =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = statsover($piddle, $weights); This utility function calculates various useful quantities of a piddle. These are: =over 3 =item * the mean: MEAN = sum (x)/ N with C being the number of elements in x =item * the population RMS deviation from the mean: PRMS = sqrt( sum( (x-mean(x))^2 )/(N-1) The population deviation is the best-estimate of the deviation of the population from which a sample is drawn. =item * the median The median is the 50th percentile data value. Median is found by L, so WEIGHTING IS IGNORED FOR THE MEDIAN CALCULATION. =item * the minimum =item * the maximum =item * the average absolute deviation: AADEV = sum( abs(x-mean(x)) )/N =item * RMS deviation from the mean: RMS = sqrt(sum( (x-mean(x))^2 )/N) (also known as the root-mean-square deviation, or the square root of the variance) =back This operator is a projection operator so the calculation will take place over the final dimension. Thus if the input is N-dimensional each returned value will be N-1 dimensional, to calculate the statistics for the entire piddle either use C directly on the piddle or call C. =cut ', BadDoc =>' =for bad Bad values are simply ignored in the calculation, effectively reducing the sample size. If all data are bad then the output data are marked bad. =cut ', ); pp_add_exported('','stats'); pp_addpm(<<'EOD'); =head2 stats =for ref Calculates useful statistics on a piddle =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = stats($piddle,[$weights]); This utility calculates all the most useful quantities in one call. It works the same way as L, except that the quantities are calculated considering the entire input PDL as a single sample, rather than as a collection of rows. See L for definitions of the returned quantities. =cut EOD if ( $bvalflag ) { pp_addpm(<<'EOD'); =for bad Bad values are handled; if all input values are bad, then all of the output values are flagged bad. =cut EOD } # if: bvalflag pp_addpm(<<'EOD'); *stats = \&PDL::stats; sub PDL::stats { barf('Usage: ($mean,[$rms]) = stats($data,[$weights])') if $#_>1; my ($data,$weights) = @_; # Ensure that $weights is properly threaded over; this could be # done rather more efficiently... if(defined $weights) { $weights = pdl($weights) unless UNIVERSAL::isa($weights,'PDL'); if( ($weights->ndims != $data->ndims) or (pdl($weights->dims) != pdl($data->dims))->or ) { $weights = $weights + zeroes($data) } $weights = $weights->flat; } return PDL::statsover($data->flat,$weights); } EOD =head2 histogram =for sig Signature: (in(n); int+[o] hist(m); double step; double min; int msize => m) =cut my $histogram_doc = <<'EOD'; =for ref Calculates a histogram for given stepsize and minimum. =for usage $h = histogram($data, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing piddle. histogram($data, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the number of values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. For a higher-level interface, see L. =for example pdl> p histogram(pdl(1,1,2),1,0,3) [0 2 1] =cut EOD =head2 whistogram =for sig Signature: (in(n); float+ wt(n);float+[o] hist(m); double step; double min; int msize => m) =cut my $whistogram_doc = <<'EOD'; =for ref Calculates a histogram from weighted data for given stepsize and minimum. =for usage $h = whistogram($data, $weights, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing piddle. whistogram($data, $weights, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. =for example pdl> p whistogram(pdl(1,1,2), pdl(0.1,0.1,0.5), 1, 0, 4) [0 0.2 0.5 0] =cut EOD for( {Name => 'histogram', WeightPar => '', HistType => 'int+', HistOp => '++', Doc => $histogram_doc, }, {Name => 'whistogram', WeightPar => 'float+ wt(n);', HistType => 'float+', HistOp => '+= $wt()', Doc => $whistogram_doc, } ) { pp_def($_->{Name}, Pars => 'in(n); '.$_->{WeightPar}.$_->{HistType}. '[o] hist(m)', # set outdim by Par! OtherPars => 'double step; double min; int msize => m', HandleBad => 1, Code => 'register int j; register int maxj = $SIZE(m)-1; register double min = $COMP(min); register double step = $COMP(step); threadloop %{ loop(m) %{ $hist() = 0; %} %} threadloop %{ loop(n) %{ j = (int) (($in()-min)/step); if (j<0) j=0; if (j > maxj) j = maxj; ($hist(m => j))'.$_->{HistOp}.'; %} %}', BadCode => 'register int j; register int maxj = $SIZE(m)-1; register double min = $COMP(min); register double step = $COMP(step); threadloop %{ loop(m) %{ $hist() = 0; %} %} threadloop %{ loop(n) %{ if ( $ISGOOD(in()) ) { j = (int) (($in()-min)/step); if (j<0) j=0; if (j > maxj) j = maxj; ($hist(m => j))'.$_->{HistOp}.'; } %} %}', Doc=>$_->{Doc}); } =head2 histogram2d =for sig Signature: (ina(n); inb(n); int+[o] hist(ma,mb); double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;) =cut my $histogram2d_doc = <<'EOD'; =for ref Calculates a 2d histogram. =for usage $h = histogram2d($datax, $datay, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing piddle. histogram2d($datax, $datay, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the number of values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p histogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),1,0,3,1,0,3) [ [0 0 0] [0 2 2] [0 1 0] ] =cut EOD =head2 whistogram2d =for sig Signature: (ina(n); inb(n); float+ wt(n);float+[o] hist(ma,mb); double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;) =cut my $whistogram2d_doc = <<'EOD'; =for ref Calculates a 2d histogram from weighted data. =for usage $h = whistogram2d($datax, $datay, $weights, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing piddle. whistogram2d($datax, $datay, $weights, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p whistogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),pdl(0.1,0.2,0.3,0.4,0.5),1,0,3,1,0,3) [ [ 0 0 0] [ 0 0.5 0.9] [ 0 0.1 0] ] =cut EOD for( {Name => 'histogram2d', WeightPar => '', HistType => 'int+', HistOp => '++', Doc => $histogram2d_doc, }, {Name => 'whistogram2d', WeightPar => 'float+ wt(n);', HistType => 'float+', HistOp => '+= $wt()', Doc => $whistogram2d_doc, } ) { pp_def($_->{Name}, Pars => 'ina(n); inb(n); '.$_->{WeightPar}.$_->{HistType}. '[o] hist(ma,mb)', # set outdim by Par! OtherPars => 'double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;', HandleBad => 1, Code => 'register int ja,jb; register int maxja = $SIZE(ma)-1; register int maxjb = $SIZE(mb)-1; register double mina = $COMP(mina); register double minb = $COMP(minb); register double stepa = $COMP(stepa); register double stepb = $COMP(stepb); threadloop %{ loop(ma,mb) %{ $hist() = 0; %} %} threadloop %{ loop(n) %{ ja = (int) (($ina()-mina)/stepa); jb = (int) (($inb()-minb)/stepb); if (ja<0) ja=0; if (ja > maxja) ja = maxja; if (jb<0) jb=0; if (jb > maxjb) jb = maxjb; ($hist(ma => ja,mb => jb))'.$_->{HistOp}.'; %} %} ', BadCode => 'register int ja,jb; register int maxja = $SIZE(ma)-1; register int maxjb = $SIZE(mb)-1; register double mina = $COMP(mina); register double minb = $COMP(minb); register double stepa = $COMP(stepa); register double stepb = $COMP(stepb); threadloop %{ loop(ma,mb) %{ $hist() = 0; %} %} threadloop %{ loop(n) %{ if ( $ISGOOD(ina()) && $ISGOOD(inb()) ) { ja = (int) (($ina()-mina)/stepa); jb = (int) (($inb()-minb)/stepb); if (ja<0) ja=0; if (ja > maxja) ja = maxja; if (jb<0) jb=0; if (jb > maxjb) jb = maxjb; ($hist(ma => ja,mb => jb))'.$_->{HistOp}.'; } %} %} ', Doc=> $_->{Doc}); } ########################################################### # a number of constructors: fibonacci, append, axisvalues & # random numbers ########################################################### =head2 fibonacci =for sig Signature: ([o]x(n)) Constructor - a vector with Fibonacci's sequence =cut pp_def('fibonacci', Pars => '[o]x(n);', Doc=>'Constructor - a vector with Fibonacci\'s sequence', PMFunc=>'', PMCode=><<'EOD', sub fibonacci { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->fibonacci : PDL->fibonacci(@_) } sub PDL::fibonacci{ my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; &PDL::_fibonacci_int($x->clump(-1)); return $x; } EOD Code => ' PDL_Indx i=0; $GENERIC() x1, x2; x1 = 1; x2 = 0; loop(n) %{ $x() = x1 + x2; if (i++>0) { x2 = x1; x1 = $x(); } %} '); =head2 append =for sig Signature: (a(n); b(m); [o] c(mn)) =cut pp_def('append', Pars => 'a(n); b(m); [o] c(mn)', # note that ideally we want to say '$SIZE(mn) = $SIZE(m)+$SIZE(n);' # but that requires placing RedoDimsParsedCode *after* assignment of # childdims to $SIZE(XXX)!!! XXXXXmake that workXXXXX RedoDimsCode => ' pdl * dpdla = $PDL(a); pdl * dpdlb = $PDL(b); $SIZE(mn) = (dpdla->ndims > 0 ? dpdla->dims[0] : 1) + (dpdlb->ndims > 0 ? dpdlb->dims[0] : 1); ', Code => 'register PDL_Indx mnp; PDL_Indx ns = $SIZE(n); threadloop %{ loop(n) %{ $c(mn => n) = $a(); %} loop(m) %{ mnp = m+ns; $c(mn => mnp) = $b(); %} %}', Doc => ' =for ref append two or more piddles by concatenating along their first dimensions =for example $a = ones(2,4,7); $b = sequence 5; $c = $a->append($b); # size of $c is now (7,4,7) (a jumbo-piddle ;) C appends two piddles along their first dims. Rest of the dimensions must be compatible in the threading sense. Resulting size of first dim is the sum of the sizes of the first dims of the two argument piddles - ie C. Similar functions include L (below) and L. =cut ' ); pp_addpm(<<'EOD') =head2 glue =for usage $c = $a->glue(,$b,...) =for ref Glue two or more PDLs together along an arbitrary dimension (N-D L). Sticks $a, $b, and all following arguments together along the specified dimension. All other dimensions must be compatible in the threading sense. Glue is permissive, in the sense that every PDL is treated as having an infinite number of trivial dimensions of order 1 -- so C<< $a->glue(3,$b) >> works, even if $a and $b are only one dimensional. If one of the PDLs has no elements, it is ignored. Likewise, if one of them is actually the undefined value, it is treated as if it had no elements. If the first parameter is a defined perl scalar rather than a pdl, then it is taken as a dimension along which to glue everything else, so you can say C<$cube = PDL::glue(3,@image_list);> if you like. C is implemented in pdl, using a combination of L and L. It should probably be updated (one day) to a pure PP function. Similar functions include L (above) and L. =cut sub PDL::glue{ my($a) = shift; my($dim) = shift; if(defined $a && !(ref $a)) { my $b = $dim; $dim = $a; $a = $b; } if(!defined $a || $a->nelem==0) { return $a unless(@_); return shift() if(@_<=1); $a=shift; return PDL::glue($a,$dim,@_); } if($dim - $a->dim(0) > 100) { print STDERR "warning:: PDL::glue allocating >100 dimensions!\n"; } while($dim >= $a->ndims) { $a = $a->dummy(-1,1); } $a = $a->xchg(0,$dim); while(scalar(@_)){ my $b = shift; next unless(defined $b && $b->nelem); while($dim >= $b->ndims) { $b = $b->dummy(-1,1); } $b = $b->xchg(0,$dim); $a = $a->append($b); } $a->xchg(0,$dim); } EOD ; =head2 axisvalues =for sig Signature: ([o,nc]a(n)) =cut pp_def( 'axisvalues', Pars => '[o,nc]a(n)', Code => 'loop(n) %{ $a() = n; %}', Doc => ' =for ref Internal routine C is the internal primitive that implements L and alters its argument. =cut ' ); # pp_def: axisvalues pp_addpm(<<'EOD'); =head2 random =for ref Constructor which returns piddle of random numbers =for usage $a = random([type], $nx, $ny, $nz,...); $a = random $b; etc (see L). This is the uniform distribution between 0 and 1 (assumedly excluding 1 itself). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the perl function L to seed the random generator. For further details consult Perl's L documentation. =head2 randsym =for ref Constructor which returns piddle of random numbers =for usage $a = randsym([type], $nx, $ny, $nz,...); $a = randsym $b; etc (see L). This is the uniform distribution between 0 and 1 (excluding both 0 and 1, cf L). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the perl function L to seed the random generator. For further details consult Perl's L documentation. =cut EOD pp_addhdr(<<'EOH'); #ifndef Drand01 #define Drand01() (((double)rand()) / (RAND_MAX+1.0)) #endif EOH pp_def( 'random', Pars=>'a();', PMFunc => '', Code => '$a() = Drand01();', 'NoPthread' => 1, # random isn't threadsafe Doc=>undef, PMCode=><<'EOD', sub random { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->random : PDL->random(@_) } sub PDL::random { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; &PDL::_random_int($x); return $x; } EOD ); pp_def( 'randsym', 'NoPthread' => 1, # random isn't threadsafe Pars=>'a();', PMFunc => '', Code => 'double tmp; do tmp = Drand01(); while (tmp == 0.0); /* 0 < tmp < 1 */ $a() = tmp;', Doc=>undef, PMCode=><<'EOD', sub randsym { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->randsym : PDL->randsym(@_) } sub PDL::randsym { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; &PDL::_randsym_int($x); return $x; } EOD ); pp_addpm(<<'EOD'); =head2 grandom =for ref Constructor which returns piddle of Gaussian random numbers =for usage $a = grandom([type], $nx, $ny, $nz,...); $a = grandom $b; etc (see L). This is generated using the math library routine C. Mean = 0, Stddev = 1 You can use the perl function L to seed the random generator. For further details consult Perl's L documentation. =cut sub grandom { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->grandom : PDL->grandom(@_) } sub PDL::grandom { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; use PDL::Math 'ndtri'; $x .= ndtri(randsym($x)); return $x; } EOD pp_add_exported('','grandom'); ############################################################### # binary searches in a piddle; various forms ############################################################### pp_add_exported('','vsearch'); # generic front end; defaults to vsearch_sample for backwards compatibility pp_addpm(<<'EOD'); =head2 vsearch =for sig Signature: ( vals(); xs(n); [o] indx(); [\%options] ) =for ref Efficiently search for values in a sorted piddle, returning indices. =for usage $idx = vsearch( $vals, $x, [\%options] ); vsearch( $vals, $x, $idx, [\%options ] ); B performs a binary search in the ordered piddle C<$x>, for the values from C<$vals> piddle, returning indices into C<$x>. What is a "match", and the meaning of the returned indices, are determined by the options. The C option indicates which method of searching to use, and may be one of: =over =item C invoke B, returning indices appropriate for sampling within a distribution. =item C invoke B, returning the left-most possible insertion point which still leaves the piddle sorted. =item C invoke B, returning the right-most possible insertion point which still leaves the piddle sorted. =item C invoke B, returning the index of a matching element, else -(insertion point + 1) =item C invoke B, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =item C invoke B, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =back The default value of C is C. =cut sub vsearch { my $opt = 'HASH' eq ref $_[-1] ? pop : { mode => 'sample' }; croak( "unknown options to vsearch\n" ) if ( ! defined $opt->{mode} && keys %$opt ) || keys %$opt > 1; my $mode = $opt->{mode}; goto $mode eq 'sample' ? \&vsearch_sample : $mode eq 'insert_leftmost' ? \&vsearch_insert_leftmost : $mode eq 'insert_rightmost' ? \&vsearch_insert_rightmost : $mode eq 'match' ? \&vsearch_match : $mode eq 'bin_inclusive' ? \&vsearch_bin_inclusive : $mode eq 'bin_exclusive' ? \&vsearch_bin_exclusive : croak( "unknown vsearch mode: $mode\n" ); } *PDL::vsearch = \&vsearch; EOD use Text::Tabs qw[ expand ]; sub undent { my $txt = expand( shift ); $txt =~ s/^([ \t]+)-{4}.*$//m; $txt =~ s/^$1//mg if defined $1; $txt; } for my $func ( [ vsearch_sample => { low => -1, high => '$SIZE(n)', up => '($x(n => n1) > $x(n => 0))', code => q[ while ( high - low > 1 ) { mid = %MID%; if ( ( value > $x(n => mid ) ) == up ) low = mid; else high = mid; } $idx() = low >= n1 ? n1 : up ? low + 1 : low < 0 ? 0 : low ; ---- ], ref => 'Search for values in a sorted array, return index appropriate for sampling from a distribution', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals> appropriate for sampling C<$vals> ---- ], doc_incr => q[ V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem -1 ---- ], doc_decr => q[ V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem - 1 ---- ], doc_post => q[ If all elements of C<$x> are equal, I<< I = $x->nelem - 1 >>. If C<$x> contains duplicated elements, I is the index of the leftmost (by position in array) duplicate if I matches. =for example This function is useful e.g. when you have a list of probabilities for events and want to generate indices to events: $a = pdl(.01,.86,.93,1); # Barnsley IFS probabilities cumulatively $b = random 20; $c = %FUNC%($b, $a); # Now, $c will have the appropriate distr. It is possible to use the L function to obtain cumulative probabilities from absolute probabilities. ---- ], }, ], [ # return left-most possible insertion point. # lowest index where x[i] >= value vsearch_insert_leftmost => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) >= value ) == up ) high = mid - 1; else low = mid + 1; } $idx() = up ? low : high; ], ref => 'Determine the insertion point for values in a sorted array, inserting before duplicates.', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals> equal to the leftmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. ---- ], doc_incr => q[ V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem ---- ], doc_decr => q[ V > x[0] : I = -1 x[0] >= V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem -1 ---- ], doc_post => q[ If all elements of C<$x> are equal, i = 0 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. ---- ], }, ], [ # return right-most possible insertion point. # lowest index where x[i] > value vsearch_insert_rightmost => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) > value ) == up ) high = mid - 1; else low = mid + 1; } $idx() = up ? low : high; ], ref => 'Determine the insertion point for values in a sorted array, inserting after duplicates.', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals> equal to the rightmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. ---- ], doc_incr => q[ V < x[0] : I = 0 x[0] <= V < x[-1] : I s.t. x[I-1] <= V < x[I] x[-1] <= V : I = $x->nelem ---- ], doc_decr => q[ V >= x[0] : I = -1 x[0] > V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] > V : I = $x->nelem -1 ---- ], doc_post => q[ If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. ---- ], }, ], [ # return index of matching element, else -( insertion point + 1 ) # patterned after the Java binarySearch interface; see # http://docs.oracle.com/javase/7/docs/api/java/util/Arrays.html vsearch_match => { low => 0, high => 'n1', code => q[ int done = 0; while (low <= high ) { $GENERIC() mid_value; mid = %MID%; mid_value = $x(n=>mid); if ( up ) { if ( mid_value > value ) { high = mid - 1; } else if ( mid_value < value ) { low = mid + 1; } else { done = 1; break; } } else { if ( mid_value < value ) { high = mid - 1; } else if ( mid_value > value ) { low = mid + 1; } else { done = 1; break; } } } $idx() = done ? mid : up ? - ( low + 1 ) : - ( high + 1 ); ], ref => 'Match values against a sorted array.', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals>. If I matches an element in C<$x>, I is the index of that element, otherwise it is I<-( insertion_point + 1 )>, where I is an index in C<$x> where I may be inserted while maintaining the order in C<$x>. If C<$x> has duplicated values, I may refer to any of them. ---- ], }, ], [ # x[i] is the INnclusive left edge of the bin # return i, s.t. x[i] <= value < x[i+1]. # returns -1 if x[0] > value # returns N-1 if x[-1] <= value vsearch_bin_inclusive => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) <= value ) == up ) low = mid + 1; else high = mid - 1; } $idx() = up ? high: low; ], ref => 'Determine the index for values in a sorted array of bins, lower bound inclusive.', doc_pre => q[ C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is inclusive to the bin, its outer bound is exclusive to it. B<%FUNC%> returns an index I for each value I of C<$vals> ---- ], doc_incr => q[ V < x[0] : I = -1 x[0] <= V < x[-1] : I s.t. x[I] <= V < x[I+1] x[-1] <= V : I = $x->nelem - 1 ---- ], doc_decr => q[ V >= x[0] : I = 0 x[0] > V >= x[-1] : I s.t. x[I+1] > V >= x[I] x[-1] > V : I = $x->nelem ---- ], doc_post => q[ If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. ---- ], }, ], [ # x[i] is the EXclusive left edge of the bin # return i, s.t. x[i] < value <= x[i+1]. # returns -1 if x[0] >= value # returns N-1 if x[-1] < value vsearch_bin_exclusive => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) < value ) == up ) low = mid + 1; else high = mid - 1; } $idx() = up ? high: low; ], ref => 'Determine the index for values in a sorted array of bins, lower bound exclusive.', doc_pre => q[ C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is exclusive to the bin, its upper bound is inclusive to it. B<%FUNC%> returns an index I for each value I of C<$vals>. ---- ], doc_incr => q[ V <= x[0] : I = -1 x[0] < V <= x[-1] : I s.t. x[I] < V <= x[I+1] x[-1] < V : I = $x->nelem - 1 ---- ], doc_decr => q[ V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I-1] >= V > x[I] x[-1] >= V : I = $x->nelem ---- ], doc_post => q[ If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. ---- ], } ], ) { my ( $func, $algo ) = @$func; my %replace = ( # calculate midpoint of range; ensure we don't overflow # (low+high)>>1 for large values of low + high # see sf.net bug #360 '%MID%' => 'low + (( high - low )>> 1);', # determine which way the data are sorted. vsearch_sample # overrides this. '%UP%' => '$x(n => n1) >= $x(n => 0)', '%FUNC%' => $func, '%PRE%' => undent( q[ %DOC_PRE% ---- ] ), '%BODY%' => undent( q[ I has the following properties: =over =item * if C<$x> is sorted in increasing order %DOC_INCR% =item * if C<$x> is sorted in decreasing order %DOC_DECR% =back ---- ] ), '%POST%' => undent( q[ %DOC_POST% ---- ] ), map { ( "%\U$_%" => undent( $algo->{$_} ) ) } keys %$algo, ); $replace{'%PRE%'} = '' unless defined $replace{'%DOC_PRE%'}; $replace{'%BODY%'} = '' unless defined $replace{'%DOC_INCR%'} || defined $replace{'%DOC_DECR%'}; $replace{'%POST%'} = '' unless defined $replace{'%DOC_POST%'}; my $code = undent q[ PDL_Indx n1 = $SIZE(n)-1; PDL_Indx low = %LOW%; PDL_Indx high = %HIGH%; PDL_Indx mid; $GENERIC() value = $vals(); /* determine sort order of data */ int up = %UP%; %CODE% ---- ]; my $doc = undent q[ =for ref %REF% =for usage $idx = %FUNC%($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. %PRE% %BODY% %POST% ---- ]; # redo until nothing changes for my $tref ( \$code, \$doc ) { 1 while $$tref =~ s/(%[\w_]+%)/$replace{$1}/ge; } pp_def( $func, HandleBad => 0, BadDoc => 'needs major (?) work to handles bad values', Pars => 'vals(); x(n); indx [o]idx()', GenericTypes => [ 'F', 'D' ], # too restrictive ? Code => $code, Doc => $doc, ); } ############################################################### # routines somehow related to interpolation ############################################################### =head2 interpolate =for sig Signature: (xi(); x(n); y(n); [o] yi(); int [o] err()) =cut pp_def('interpolate', HandleBad => 0, BadDoc => 'needs major (?) work to handles bad values', Pars => 'xi(); x(n); y(n); [o] yi(); int [o] err()', GenericTypes => ['F','D'], # too restrictive ? Code => ' $GENERIC() d; PDL_Indx n = $SIZE(n); PDL_Indx n1 = n-1; int up = ($x(n => n1) > $x(n => 0)); PDL_Indx jl, jh, m; int carp; threadloop %{ jl = -1; jh = n; carp = 0; while (jh-jl > 1) /* binary search */ { m = (jh+jl) >> 1; if ($xi() > $x(n => m) == up) jl = m; else jh = m; } if (jl == -1) { if ($xi() != $x(n => 0)) carp = 1; jl = 0; } else if (jh == n) { if ($xi() != $x(n => n1)) carp = 1; jl = n1-1; } jh = jl+1; if ((d = $x(n => jh)-$x(n => jl)) == 0) barf("identical abscissas"); d = ($x(n => jh)-$xi())/d; $yi() = d*$y(n => jl) + (1-d)*$y(n => jh); $err() = carp; %} ', Doc=><<'EOD'); =for ref routine for 1D linear interpolation =for usage ( $yi, $err ) = interpolate($xi, $x, $y) Given a set of points C<($x,$y)>, use linear interpolation to find the values C<$yi> at a set of points C<$xi>. C uses a binary search to find the suspects, er..., interpolation indices and therefore abscissas (ie C<$x>) have to be I ordered (increasing or decreasing). For interpolation at lots of closely spaced abscissas an approach that uses the last index found as a start for the next search can be faster (compare Numerical Recipes C routine). Feel free to implement that on top of the binary search if you like. For out of bounds values it just does a linear extrapolation and sets the corresponding element of C<$err> to 1, which is otherwise 0. See also L, which uses the same routine, differing only in the handling of extrapolation - an error message is printed rather than returning an error piddle. =cut EOD pp_add_exported('', 'interpol'); pp_addpm(<<'EOD'); =head2 interpol =for sig Signature: (xi(); x(n); y(n); [o] yi()) =for ref routine for 1D linear interpolation =for usage $yi = interpol($xi, $x, $y) C uses the same search method as L, hence C<$x> must be I ordered (either increasing or decreasing). The difference occurs in the handling of out-of-bounds values; here an error message is printed. =cut # kept in for backwards compatability sub interpol ($$$;$) { my $xi = shift; my $x = shift; my $y = shift; my $yi; if ( $#_ == 0 ) { $yi = $_[0]; } else { $yi = PDL->null; } interpolate( $xi, $x, $y, $yi, my $err = PDL->null ); print "some values had to be extrapolated\n" if any $err; return $yi if $#_ == -1; } # sub: interpol() *PDL::interpol = \&interpol; EOD pp_add_exported('','interpND'); pp_addpm(<<'EOD'); =head2 interpND =for ref Interpolate values from an N-D piddle, with switchable method =for example $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2.2,3.5],[4.1,5.0]],[[6.0,7.4],[8,9]]); print $source->interpND( $index ); InterpND acts like L, collapsing C<$index> by lookup into C<$source>; but it does interpolation rather than direct sampling. The interpolation method and boundary condition are switchable via an options hash. By default, linear or sample interpolation is used, with constant value outside the boundaries of the source pdl. No dataflow occurs, because in general the output is computed rather than indexed. All the interpolation methods treat the pixels as value-centered, so the C method will return C<< $a->(0) >> for coordinate values on the set [-0.5,0.5), and all methods will return C<< $a->(1) >> for a coordinate value of exactly 1. Recognized options: =over 3 =item method Values can be: =over 3 =item * 0, s, sample, Sample (default for integer source types) The nearest value is taken. Pixels are regarded as centered on their respective integer coordinates (no offset from the linear case). =item * 1, l, linear, Linear (default for floating point source types) The values are N-linearly interpolated from an N-dimensional cube of size 2. =item * 3, c, cube, cubic, Cubic The values are interpolated using a local cubic fit to the data. The fit is constrained to match the original data and its derivative at the data points. The second derivative of the fit is not continuous at the data points. Multidimensional datasets are interpolated by the successive-collapse method. (Note that the constraint on the first derivative causes a small amount of ringing around sudden features such as step functions). =item * f, fft, fourier, Fourier The source is Fourier transformed, and the interpolated values are explicitly calculated from the coefficients. The boundary condition option is ignored -- periodic boundaries are imposed. If you pass in the option "fft", and it is a list (ARRAY) ref, then it is a stash for the magnitude and phase of the source FFT. If the list has two elements then they are taken as already computed; otherwise they are calculated and put in the stash. =back =item b, bound, boundary, Boundary This option is passed unmodified into L, which is used as the indexing engine for the interpolation. Some current allowed values are 'extend', 'periodic', 'truncate', and 'mirror' (default is 'truncate'). =item bad contains the fill value used for 'truncate' boundary. (default 0) =item fft An array ref whose associated list is used to stash the FFT of the source data, for the FFT method. =back =cut *interpND = *PDL::interpND; sub PDL::interpND { my $source = shift; my $index = shift; my $options = shift; barf 'Usage: interp_nd($source,$index,[{%options}])\n' if(defined $options and ref $options ne 'HASH'); my($opt) = (defined $options) ? $options : {}; my($method) = $opt->{m} || $opt->{meth} || $opt->{method} || $opt->{Method}; if(!defined $method) { $method = ($source->type <= zeroes(long,1)->type) ? 'sample' : 'linear'; } my($boundary) = $opt->{b} || $opt->{boundary} || $opt->{Boundary} || $opt->{bound} || $opt->{Bound} || 'extend'; my($bad) = $opt->{bad} || $opt->{Bad} || 0.0; if($method =~ m/^s(am(p(le)?)?)?/i) { return $source->range(PDL::Math::floor($index+0.5),0,$boundary); } elsif (($method eq 1) || $method =~ m/^l(in(ear)?)?/i) { ## key: (ith = index thread; cth = cube thread; sth = source thread) my $d = $index->dim(0); my $di = $index->ndims - 1; # Grab a 2-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor,2,$boundary); # (ith, cth, sth) # Reorder to put the cube dimensions in front and convert to a list $samp = $samp->reorder( $di .. $di+$d-1, 0 .. $di-1, $di+$d .. $samp->ndims-1) # (cth, ith, sth) ->clump($d); # (clst, ith, sth) # Enumerate the corners of an n-cube and convert to a list # (the 'x' is the normal perl repeat operator) my $crnr = PDL::Basic::ndcoords( (2) x $index->dim(0) ) # (index,cth) ->mv(0,-1)->clump($index->dim(0))->mv(-1,0); # (index, clst) # a & b are the weighting coefficients. my($a,$b); my($indexwhere); ($indexwhere = $index->where( 0 * $index )) .= -10; # Change NaN to invalid { my $bb = PDL::Math::floor($index); $a = ($index - $bb) -> dummy(1,$crnr->dim(1)); # index, clst, ith $b = ($bb + 1 - $index) -> dummy(1,$crnr->dim(1)); # index, clst, ith } # Use 1/0 corners to select which multiplier happens, multiply # 'em all together to get sample weights, and sum to get the answer. my $out0 = ( ($a * ($crnr==1) + $b * ($crnr==0)) #index, clst, ith -> prodover #clst, ith ); my $out = ($out0 * $samp)->sumover; # ith, sth # Work around BAD-not-being-contagious bug in PDL <= 2.6 bad handling code --CED 3-April-2013 if($PDL::Bad::Status and $source->badflag) { my $baddies = $samp->isbad->orover; $out = $out->setbadif($baddies); } return $out; } elsif(($method eq 3) || $method =~ m/^c(u(b(e|ic)?)?)?/i) { my ($d,@di) = $index->dims; my $di = $index->ndims - 1; # Grab a 4-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor - 1,4,$boundary) #ith, cth, sth ->reorder( $di .. $di+$d-1, 0..$di-1, $di+$d .. $source->ndims-1 ); # (cth, ith, sth) # Make a cube of the subpixel offsets, and expand its dims to # a 4-on-a-side N-1 cube, to match the slices of $samp (used below). my $b = $index - $index->floor; for my $i(1..$d-1) { $b = $b->dummy($i,4); } # Collapse by interpolation, one dimension at a time... for my $i(0..$d-1) { my $a0 = $samp->slice("(1)"); # Just-under-sample my $a1 = $samp->slice("(2)"); # Just-over-sample my $a1a0 = $a1 - $a0; my $gradient = 0.5 * ($samp->slice("2:3")-$samp->slice("0:1")); my $s0 = $gradient->slice("(0)"); # Just-under-gradient my $s1 = $gradient->slice("(1)"); # Just-over-gradient $bb = $b->slice("($i)"); # Collapse the sample... $samp = ( $a0 + $bb * ( $s0 + $bb * ( (3 * $a1a0 - 2*$s0 - $s1) + $bb * ( $s1 + $s0 - 2*$a1a0 ) ) ) ); # "Collapse" the subpixel offset... $b = $b->slice(":,($i)"); } return $samp; } elsif($method =~ m/^f(ft|ourier)?/i) { eval "use PDL::FFT;"; my $fftref = $opt->{fft}; $fftref = [] unless(ref $fftref eq 'ARRAY'); if(@$fftref != 2) { my $a = $source->copy; my $b = zeroes($source); fftnd($a,$b); $fftref->[0] = sqrt($a*$a+$b*$b) / $a->nelem; $fftref->[1] = - atan2($b,$a); } my $i; my $c = PDL::Basic::ndcoords($source); # (dim, source-dims) for $i(1..$index->ndims-1) { $c = $c->dummy($i,$index->dim($i)) } my $id = $index->ndims-1; my $phase = (($c * $index * 3.14159 * 2 / pdl($source->dims)) ->sumover) # (index-dims, source-dims) ->reorder($id..$id+$source->ndims-1,0..$id-1); # (src, index) my $phref = $fftref->[1]->copy; # (source-dims) my $mag = $fftref->[0]->copy; # (source-dims) for $i(1..$index->ndims-1) { $phref = $phref->dummy(-1,$index->dim($i)); $mag = $mag->dummy(-1,$index->dim($i)); } my $out = cos($phase + $phref ) * $mag; $out = $out->clump($source->ndims)->sumover; return $out; } else { barf("interpND: unknown method '$method'; valid ones are 'linear' and 'sample'.\n"); } } EOD ############################################################## # things related to indexing: one2nd, which, where ############################################################## pp_add_exported("", 'one2nd'); pp_addpm(<<'EOD'); =head2 one2nd =for ref Converts a one dimensional index piddle to a set of ND coordinates =for usage @coords=one2nd($a, $indices) returns an array of piddles containing the ND indexes corresponding to the one dimensional list indices. The indices are assumed to correspond to array C<$a> clumped using C. This routine is used in the old vector form of L, but is useful on its own occasionally. Returned piddles have the L datatype. C<$indices> can have values larger than C<< $a->nelem >> but negative values in C<$indices> will not give the answer you expect. =for example pdl> $a=pdl [[[1,2],[-1,1]], [[0,-3],[3,2]]]; $c=$a->clump(-1) pdl> $maxind=maximum_ind($c); p $maxind; 6 pdl> print one2nd($a, maximum_ind($c)) 0 1 1 pdl> p $a->at(0,1,1) 3 =cut *one2nd = \&PDL::one2nd; sub PDL::one2nd { barf "Usage: one2nd \$array \$indices\n" if $#_ != 1; my ($a, $ind)=@_; my @dimension=$a->dims; $ind = indx($ind); my(@index); my $count=0; foreach (@dimension) { $index[$count++]=$ind % $_; $ind /= $_; } return @index; } EOD =head2 which =for sig Signature: (mask(n); indx [o] inds(m)) =cut my $doc_which = <<'EOD'; =for ref Returns indices of non-zero values from a 1-D PDL =for usage $i = which($mask); returns a pdl with indices for all those elements that are nonzero in the mask. Note that the returned indices will be 1D. If you feed in a multidimensional mask, it will be flattened before the indices are calculated. See also L for multidimensional masks. If you want to index into the original mask or a similar piddle with output from C, remember to flatten it before calling index: $data = random 5, 5; $idx = which $data > 0.5; # $idx is now 1D $bigsum = $data->flat->index($idx)->sum; # flatten before indexing Compare also L for similar functionality. SEE ALSO: L returns separately the indices of both zero and nonzero values in the mask. L returns associated values from a data PDL, rather than indices into the mask PDL. L returns N-D indices into a multidimensional PDL. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> $indx = which($x>6); p $indx [7 8 9] =cut EOD =head2 which_both =for sig Signature: (mask(n); indx [o] inds(m); indx [o]notinds(q)) =cut my $doc_which_both = <<'EOD'; =for ref Returns indices of zero and nonzero values in a mask PDL =for usage ($i, $c_i) = which_both($mask); This works just as L, but the complement of C<$i> will be in C<$c_i>. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> ($small, $big) = which_both ($x >= 5); p "$small\n $big" [5 6 7 8 9] [0 1 2 3 4] =cut EOD for ( {Name=>'which', Pars => 'mask(n); indx [o] inds(m);', Variables => 'int dm=0;', Elseclause => "", Autosize => '$SIZE(m) = sum;', Doc => $doc_which, PMCode=><<'EOD', sub which { my ($this,$out) = @_; $this = $this->flat; $out = $this->nullcreate unless defined $out; PDL::_which_int($this,$out); return $out; } *PDL::which = \&which; EOD }, {Name => 'which_both', Pars => 'mask(n); indx [o] inds(m); indx [o]notinds(q)', Variables => 'int dm=0; int dm2=0;', Elseclause => "else { \n \$notinds(q => dm2)=n; \n dm2++;\n }", Autosize => '$SIZE(m) = sum;'."\n".' $SIZE(q) = dpdl->dims[0]-sum;', Doc => $doc_which_both, PMCode=><<'EOD', sub which_both { my ($this,$outi,$outni) = @_; $this = $this->flat; $outi = $this->nullcreate unless defined $outi; $outni = $this->nullcreate unless defined $outni; PDL::_which_both_int($this,$outi,$outni); return wantarray ? ($outi,$outni) : $outi; } *PDL::which_both = \&which_both; EOD } ) { pp_def($_->{Name}, HandleBad => 1, Doc => $_->{Doc}, Pars => $_->{Pars}, PMCode => $_->{PMCode}, Code => $_->{Variables} . 'loop(n) %{ if($mask()) { $inds(m => dm) = n; dm++; }'.$_->{Elseclause} . "\n". ' %}', BadCode => $_->{Variables} . 'loop(n) %{ if ( $mask() && $ISGOOD($mask()) ) { $inds(m => dm) = n; dm++; }'.$_->{Elseclause} . "\n". ' %}', # the next one is currently a dirty hack # this will probably break once dataflow is enabled again # *unless* we have made sure that mask is physical by now!!! RedoDimsCode => ' PDL_Indx sum = 0; /* not sure if this is necessary */ pdl * dpdl = $PDL(mask); $GENERIC() *m_datap = (($GENERIC() *)(PDL_REPRP(dpdl))); PDL_Indx inc = PDL_REPRINC(dpdl,0); PDL_Indx offs = PDL_REPROFFS(dpdl); PDL_Indx i; if (dpdl->ndims != 1) barf("dimflag currently works only with 1D pdls"); '. ($bvalflag ? ' if(dpdl->state & PDL_BADVAL) for (i=0; idims[0]; i++) { $GENERIC() foo = *(m_datap+inc*i+offs); if(foo && $ISGOODVAR(foo,mask) )sum++; } else ':'').' for (i=0; idims[0]; i++) { $GENERIC() foo = *(m_datap+inc*i+offs); if(foo) sum++; } '. $_->{Autosize} . ' /* printf("RedoDimsCode: setting dim m to %ld\n",sum); */' ); } pp_addpm(<<'EOD' =head2 where =for ref Use a mask to select values from one or more data PDLs C accepts one or more data piddles and a mask piddle. It returns a list of output piddles, corresponding to the input data piddles. Each output piddle is a 1-dimensional list of values in its corresponding data piddle. The values are drawn from locations where the mask is nonzero. The output PDLs are still connected to the original data PDLs, for the purpose of dataflow. C combines the functionality of L and L into a single operation. BUGS: While C works OK for most N-dimensional cases, it does not thread properly over (for example) the (N+1)th dimension in data that is compared to an N-dimensional mask. Use C for that. =for usage $i = $x->where($x+5 > 0); # $i contains those elements of $x # where mask ($x+5 > 0) is 1 $i .= -5; # Set those elements (of $x) to -5. Together, these # commands clamp $x to a maximum of -5. It is also possible to use the same mask for several piddles with the same call: ($i,$j,$k) = where($x,$y,$z, $x+5>0); Note: C<$i> is always 1-D, even if C<$x> is E1-D. WARNING: The first argument (the values) and the second argument (the mask) currently have to have the exact same dimensions (or horrible things happen). You *cannot* thread over a smaller mask, for example. =cut sub PDL::where { barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; if($#_ == 1) { my($data,$mask) = @_; $data = $_[0]->clump(-1) if $_[0]->getndims>1; $mask = $_[1]->clump(-1) if $_[0]->getndims>1; return $data->index($mask->which()); } else { if($_[-1]->getndims > 1) { my $mask = $_[-1]->clump(-1)->which; return map {$_->clump(-1)->index($mask)} @_[0..$#_-1]; } else { my $mask = $_[-1]->which; return map {$_->index($mask)} @_[0..$#_-1]; } } } *where = \&PDL::where; EOD ); pp_add_exported("", 'where'); pp_addpm(<<'EOD' =head2 whereND =for ref C with support for ND masks and threading C accepts one or more data piddles and a mask piddle. It returns a list of output piddles, corresponding to the input data piddles. The values are drawn from locations where the mask is nonzero. C differs from C in that the mask dimensionality is preserved which allows for proper threading of the selection operation over higher dimensions. As with C the output PDLs are still connected to the original data PDLs, for the purpose of dataflow. =for usage $sdata = whereND $data, $mask ($s1, $s2, ..., $sn) = whereND $d1, $d2, ..., $dn, $mask where $data is M dimensional $mask is N < M dimensional dims($data) 1..N == dims($mask) 1..N with threading over N+1 to M dimensions =for example $data = sequence(4,3,2); # example data array $mask4 = (random(4)>0.5); # example 1-D mask array, has $n4 true values $mask43 = (random(4,3)>0.5); # example 2-D mask array, has $n43 true values $sdat4 = whereND $data, $mask4; # $sdat4 is a [$n4,3,2] pdl $sdat43 = whereND $data, $mask43; # $sdat43 is a [$n43,2] pdl Just as with C, you can use the returned value in an assignment. That means that both of these examples are valid: # Used to create a new slice stored in $sdat4: $sdat4 = $data->whereND($mask4); $sdat4 .= 0; # Used in lvalue context: $data->whereND($mask4) .= 0; =cut sub PDL::whereND :lvalue { barf "Usage: whereND( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; my $mask = pop @_; # $mask has 0==false, 1==true my @to_return; my $n = PDL::sum($mask); foreach my $arr (@_) { my $sub_i = $mask * ones($arr); my $where_sub_i = PDL::where($arr, $sub_i); # count the number of dims in $mask and $arr # $mask = a b c d e f..... my @idims = dims($arr); # ...and pop off the number of dims in $mask foreach ( dims($mask) ) { shift(@idims) }; my $ndim = 0; foreach my $id ($n, @idims[0..($#idims-1)]) { $where_sub_i = $where_sub_i->splitdim($ndim++,$id) if $n>0; } push @to_return, $where_sub_i; } return (@to_return == 1) ? $to_return[0] : @to_return; } *whereND = \&PDL::whereND; EOD ); pp_add_exported("", 'whereND'); pp_addpm(<<'EOD' =head2 whichND =for ref Return the coordinates of non-zero values in a mask. =for usage WhichND returns the N-dimensional coordinates of each nonzero value in a mask PDL with any number of dimensions. The returned values arrive as an array-of-vectors suitable for use in L or L. $coords = whichND($mask); returns a PDL containing the coordinates of the elements that are non-zero in C<$mask>, suitable for use in indexND. The 0th dimension contains the full coordinate listing of each point; the 1st dimension lists all the points. For example, if $mask has rank 4 and 100 matching elements, then $coords has dimension 4x100. If no such elements exist, then whichND returns a structured empty PDL: an Nx0 PDL that contains no values (but matches, threading-wise, with the vectors that would be produced if such elements existed). DEPRECATED BEHAVIOR IN LIST CONTEXT: whichND once delivered different values in list context than in scalar context, for historical reasons. In list context, it returned the coordinates transposed, as a collection of 1-PDLs (one per dimension) in a list. This usage is deprecated in PDL 2.4.10, and will cause a warning to be issued every time it is encountered. To avoid the warning, you can set the global variable "$PDL::whichND" to 's' to get scalar behavior in all contexts, or to 'l' to get list behavior in list context. In later versions of PDL, the deprecated behavior will disappear. Deprecated list context whichND expressions can be replaced with: @list = $a->whichND->mv(0,-1)->dog; SEE ALSO: L finds coordinates of nonzero values in a 1-D mask. L extracts values from a data PDL that are associated with nonzero values in a mask PDL. =for example pdl> $a=sequence(10,10,3,4) pdl> ($x, $y, $z, $w)=whichND($a == 203); p $x, $y, $z, $w [3] [0] [2] [0] pdl> print $a->at(list(cat($x,$y,$z,$w))) 203 =cut *whichND = \&PDL::whichND; sub PDL::whichND { my $mask = shift; $mask = PDL::pdl('PDL',$mask) unless(UNIVERSAL::isa($mask,'PDL')); # List context: generate a perl list by dimension if(wantarray) { if(!defined($PDL::whichND)) { printf STDERR "whichND: WARNING - list context deprecated. Set \$PDL::whichND. Details in pod."; } elsif($PDL::whichND =~ m/l/i) { # old list context enabled by setting $PDL::whichND to 'l' my $ind=($mask->clump(-1))->which; return $mask->one2nd($ind); } # if $PDL::whichND does not contain 'l' or 'L', fall through to scalar context } # Scalar context: generate an N-D index piddle unless($mask->nelem) { return PDL::new_from_specification('PDL',indx,$mask->ndims,0); } unless($mask->getndims) { return $mask ? pdl(indx,0) : PDL::new_from_specification('PDL',indx,0); } $ind = $mask->flat->which->dummy(0,$mask->getndims)->make_physical; if($ind->nelem==0) { # In the empty case, explicitly return the correct type of structured empty return PDL::new_from_specification('PDL',indx,$mask->ndims, 0); } my $mult = ones($mask->getndims)->long; my @mdims = $mask->dims; my $i; for $i(0..$#mdims-1) { # use $tmp for 5.005_03 compatibility (my $tmp = $mult->index($i+1)) .= $mult->index($i)*$mdims[$i]; } for $i(0..$#mdims) { my($s) = $ind->index($i); $s /= $mult->index($i); $s %= $mdims[$i]; } return $ind; } EOD ); pp_add_exported("", 'whichND'); # # Set operations suited for manipulation of the operations above. # pp_addpm(<<'EOD' =head2 setops =for ref Implements simple set operations like union and intersection =for usage Usage: $set = setops($a, , $b); The operator can be C, C or C. This is then applied to C<$a> viewed as a set and C<$b> viewed as a set. Set theory says that a set may not have two or more identical elements, but setops takes care of this for you, so C<$a=pdl(1,1,2)> is OK. The functioning is as follows: =over =item C The resulting vector will contain the elements that are either in C<$a> I in C<$b> or both. This is the union in set operation terms =item C The resulting vector will contain the elements that are either in C<$a> or C<$b>, but not in both. This is Union($a, $b) - Intersection($a, $b) in set operation terms. =item C The resulting vector will contain the intersection of C<$a> and C<$b>, so the elements that are in both C<$a> and C<$b>. Note that for convenience this operation is also aliased to L. =back It should be emphasized that these routines are used when one or both of the sets C<$a>, C<$b> are hard to calculate or that you get from a separate subroutine. Finally IDL users might be familiar with Craig Markwardt's C routine which has inspired this routine although it was written independently However the present routine has a few less options (but see the examples) =for example You will very often use these functions on an index vector, so that is what we will show here. We will in fact something slightly silly. First we will find all squares that are also cubes below 10000. Create a sequence vector: pdl> $x = sequence(10000) Find all odd and even elements: pdl> ($even, $odd) = which_both( ($x % 2) == 0) Find all squares pdl> $squares= which(ceil(sqrt($x)) == floor(sqrt($x))) Find all cubes (being careful with roundoff error!) pdl> $cubes= which(ceil($x**(1.0/3.0)) == floor($x**(1.0/3.0)+1e-6)) Then find all squares that are cubes: pdl> $both = setops($squares, 'AND', $cubes) And print these (assumes that C is loaded!) pdl> p $x($both) [0 1 64 729 4096] Then find all numbers that are either cubes or squares, but not both: pdl> $cube_xor_square = setops($squares, 'XOR', $cubes) pdl> p $cube_xor_square->nelem() 112 So there are a total of 112 of these! Finally find all odd squares: pdl> $odd_squares = setops($squares, 'AND', $odd) Another common occurrence is to want to get all objects that are in C<$a> and in the complement of C<$b>. But it is almost always best to create the complement explicitly since the universe that both are taken from is not known. Thus use L if possible to keep track of complements. If this is impossible the best approach is to make a temporary: This creates an index vector the size of the universe of the sets and set all elements in C<$b> to 0 pdl> $tmp = ones($n_universe); $tmp($b) .= 0; This then finds the complement of C<$b> pdl> $C_b = which($tmp == 1); and this does the final selection: pdl> $set = setops($a, 'AND', $C_b) =cut *setops = \&PDL::setops; sub PDL::setops { my ($a, $op, $b)=@_; # Check that $a and $b are 1D. if ($a->ndims() > 1 || $b->ndims() > 1) { warn 'setops: $a and $b must be 1D - flattening them!'."\n"; $a = $a->flat; $b = $b->flat; } #Make sure there are no duplicate elements. $a=$a->uniq; $b=$b->uniq; my $result; if ($op eq 'OR') { # Easy... $result = uniq(append($a, $b)); } elsif ($op eq 'XOR') { # Make ordered list of set union. my $union = append($a, $b)->qsort; # Index lists. my $s1=zeroes(byte, $union->nelem()); my $s2=zeroes(byte, $union->nelem()); # Find indices which are duplicated - these are to be excluded # # We do this by comparing x with x shifted each way. my $i1 = which($union != rotate($union, 1)); my $i2 = which($union != rotate($union, -1)); # # We then mark/mask these in the s1 and s2 arrays to indicate which ones # are not equal to their neighbours. # my $ts; ($ts = $s1->index($i1)) .= 1 if $i1->nelem() > 0; ($ts = $s2->index($i2)) .= 1 if $i2->nelem() > 0; my $inds=which($s1 == $s2); if ($inds->nelem() > 0) { return $union->index($inds); } else { return $inds; } } elsif ($op eq 'AND') { # The intersection of the arrays. # Make ordered list of set union. my $union = append($a, $b)->qsort; return $union->where($union == rotate($union, -1)); } else { print "The operation $op is not known!"; return -1; } } EOD ); pp_add_exported("", 'setops'); pp_addpm(<<'EOD' =head2 intersect =for ref Calculate the intersection of two piddles =for usage Usage: $set = intersect($a, $b); This routine is merely a simple interface to L. See that for more information =for example Find all numbers less that 100 that are of the form 2*y and 3*x pdl> $x=sequence(100) pdl> $factor2 = which( ($x % 2) == 0) pdl> $factor3 = which( ($x % 3) == 0) pdl> $ii=intersect($factor2, $factor3) pdl> p $x($ii) [0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96] =cut *intersect = \&PDL::intersect; sub PDL::intersect { return setops($_[0], 'AND', $_[1]); } EOD ); pp_add_exported("", 'intersect'); pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Craig DeForest (deforest@boulder.swri.edu) and Jarle Brinchmann (jarle@astro.up.pt) All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. Updated for CPAN viewing compatibility by David Mertens. =cut EOD pp_done(); PDL-2.018/Basic/Reduce.pm0000644060175006010010000001213312562522364013171 0ustar chmNone=head1 NAME PDL::Reduce -- a C function for PDL =head1 DESCRIPTION Many languages have a C function used to reduce the rank of an N-D array by one. It works by applying a selected operation along a specified dimension. This module implements such a function for PDL by providing a simplified interface to the existing projection functions (e.g. C, C, C, etc). =head1 SYNOPSIS use PDL::Reduce; $a = sequence 5,5; # reduce by adding all # elements along 2nd dimension $b = $a->reduce('add',1); @ops = $a->canreduce; # return a list of all allowed operations =head1 FUNCTIONS =cut # in a very similar vein we want the following methods # (1) accumulate # (2) outer # what's reduceat ?? # TODO # - aliases (e.g. plus -> add) # - other binary ops? # - allow general subs? package PDL::Reduce; use PDL::Core ''; # barf use PDL::Exporter; use strict; @PDL::Reduce::ISA = qw/PDL::Exporter/; @PDL::Reduce::EXPORT_OK = qw/reduce canreduce/; %PDL::Reduce::EXPORT_TAGS = (Func=>[@PDL::Reduce::EXPORT_OK]); # maps operations onto underlying PDL primitives my %reduce = ( add => 'sumover', '+' => 'sumover', plus => 'sumover', mult => 'prodover', '*' => 'prodover', dadd => 'dsumover', dmult => 'dprodover', avg => 'average', davg => 'daverage', and => 'andover', band => 'bandover', bor => 'borover', or => 'orover', median => 'medover', integral => 'intover', max => 'maximum', min => 'minimum', oddmedian => 'oddmedover', iszero => 'zcover', ); =head2 reduce =for ref reduce dimension of piddle by one by applying an operation along the specified dimension =for example $a = sequence 5,5; # reduce by adding all # elements along 2nd dimension $b = $a->reduce('add',1); $b = $a->reduce('plus',1); $b = $a->reduce('+',1); # three ways to do the same thing [ As an aside: if you are familiar with threading you will see that this is actually the same as $b = $a->mv(1,0)->sumover ] NOTE: You should quote the name of the operation (1st arg) that you want C to perform. This is important since some of the names are identical to the names of the actual PDL functions which might be imported into your namespace. And you definitely want a string as argument, not a function invocation! For example, this will probably fail: $b = $a->reduce(avg,1); # gives an error from invocation of 'avg' Rather use $b = $a->reduce('avg',1); C provides a simple and unified interface to the I functions and makes people coming from other data/array languages hopefully feel more at home. =for usage $result = $pdl->reduce($operation [,@dims]); C applies the named operation along the specified dimension(s) reducing the input piddle dimension by as many dimensions as supplied as arguments. If the dimension(s) argument is omitted the operation is applied along the first dimension. To get a list of valid operations see L. NOTE - new power user feature: you can now supply a code reference as operation to reduce with. =for example # reduce by summing over dims 0 and 2 $result = $pdl->reduce(\&sumover, 0, 2); It is your responsibility to ensure that this is indeed a PDL projection operation that turns vectors into scalars! You have been warned. =cut *reduce = \&PDL::reduce; sub PDL::reduce ($$;$) { my ($pdl, $op, @dims) = @_; barf "trying to reduce using unknown operation" unless exists $reduce{$op} || ref $op eq 'CODE'; my $dim; if (@dims > 1) { my $n = $pdl->getndims; @dims = map { $_ < 0 ? $_ + $n : $_ } @dims; my $min = $n; my $max = 0; for (@dims) { $min = $_ if $_ < $min; $max = $_ if $_ > $max } barf "dimension out of bounds (one of @dims >= $n)" if $min >= $n || $max >= $n; $dim = $min; # this will be the resulting dim of the clumped piddle $pdl = $pdl->clump(@dims); } else { $dim = @dims > 0 ? $dims[0] : 0; } if (defined $dim && $dim != 0) { # move the target dim to the front my $n = $pdl->getndims; $dim += $n if $dim < 0; barf "dimension out of bounds" if $dim <0 || $dim >= $n; $pdl = $pdl->mv($dim,0); } my $method = ref $op eq 'CODE' ? $op : $reduce{$op}; return $pdl->$method(); } =head2 canreduce =for ref return list of valid named C operations Some common operations can be accessed using a number of names, e.g. C<'+'>, C and C all sum the elements along the chosen dimension. =for example @ops = PDL->canreduce; This list is useful if you want to make sure which operations can be used with C. =cut *canreduce = \&PDL::canreduce; sub PDL::canreduce { my ($this) = @_; return keys %reduce; } =head1 AUTHOR Copyright (C) 2000 Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut 1; PDL-2.018/Basic/Slices/0000755060175006010010000000000013110402045012625 5ustar chmNonePDL-2.018/Basic/Slices/Makefile.PL0000644060175006010010000000040512562522364014617 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["slices.pd", qw(Slices PDL::Slices)]); my %hash =pdlpp_stdargs_int(@pack); undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Basic/Slices/slices.pd0000644060175006010010000035222013036512174014454 0ustar chmNonepp_addpm({At => 'Top'},<< 'EOD'); =head1 NAME PDL::Slices -- Indexing, slicing, and dicing =head1 SYNOPSIS use PDL; $a = ones(3,3); $b = $a->slice('-1:0,(1)'); $c = $a->dummy(2); =head1 DESCRIPTION This package provides many of the powerful PerlDL core index manipulation routines. These routines mostly allow two-way data flow, so you can modify your data in the most convenient representation. For example, you can make a 1000x1000 unit matrix with $a = zeroes(1000,1000); $a->diagonal(0,1) ++; which is quite efficient. See L and L for more examples. Slicing is so central to the PDL language that a special compile-time syntax has been introduced to handle it compactly; see L for details. PDL indexing and slicing functions usually include two-way data flow, so that you can separate the actions of reshaping your data structures and modifying the data themselves. Two special methods, L and L, help you control the data flow connection between related variables. $b = $a->slice("1:3"); # Slice maintains a link between $a and $b. $b += 5; # $a is changed! If you want to force a physical copy and no data flow, you can copy or sever the slice expression: $b = $a->slice("1:3")->copy; $b += 5; # $a is not changed. $b = $a->slice("1:3")->sever; $b += 5; # $a is not changed. The difference between C and C is that sever acts on (and returns) its argument, while copy produces a disconnected copy. If you say $b = $a->slice("1:3"); $c = $b->sever; then the variables C<$b> and C<$c> point to the same object but with C<-Ecopy> they would not. =cut use PDL::Core ':Internal'; use Scalar::Util 'blessed'; EOD =head1 FUNCTIONS =cut # $::PP_VERBOSE=1; pp_addhdr(<<'EOH'); #ifdef _MSC_VER #if _MSC_VER < 1300 #define strtoll strtol #else #define strtoll _strtoi64 #endif #endif EOH pp_add_boot( " PDL->readdata_affine = pdl_readdata_affineinternal;\n" . " PDL->writebackdata_affine = pdl_writebackdata_affineinternal;\n" ); ## Several routines use the 'Dims' and 'ParentInds' ## rules - these currently do nothing pp_def( 'affineinternal', HandleBad => 1, AffinePriv => 1, DefaultFlow => 1, P2Child => 1, NoPdlThread => 1, ReadDataFuncName => "pdl_readdata_affineinternal", WriteBackDataFuncName => "pdl_writebackdata_affineinternal", MakeComp => '$CROAK("AFMC MUSTNT BE CALLED");', RedoDims => '$CROAK("AFRD MUSTNT BE CALLED");', EquivCPOffsCode => ' PDL_Indx i; PDL_Indx poffs=$PRIV(offs); int nd; for(i=0; i<$CHILD_P(nvals); i++) { $EQUIVCPOFFS(i,poffs); for(nd=0; nd<$CHILD_P(ndims); nd++) { poffs += $PRIV(incs[nd]); if( (nd<$CHILD_P(ndims)-1 && (i+1)%$CHILD_P(dimincs[nd+1])) || nd == $CHILD_P(ndims)-1) break; poffs -= $PRIV(incs[nd]) * $CHILD_P(dims[nd]); } }', Doc => undef, # 'internal', ); =head2 s_identity =cut $doc = <<'DOC'; =for ref Internal vaffine identity function. =cut DOC pp_def( 's_identity', HandleBad => 1, P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, OtherPars => '', Reversible => 1, Dims => '$COPYDIMS();', ParentInds => '$COPYINDS();', Identity => 1, Doc => $doc, ); =head2 index, index1d, index2d =cut $doc = <<'EOD'; =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C works like C but uses separate piddles for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $a->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$a>. C provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $a = xvals(10,10)+10*yvals(10,10); $b = $a->index(3); $c = $a->index(9-xvals(10)); puts a single column from C<$a> into C<$b>, and puts a single element from each column of C<$a> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =cut EOD my $index_init_good = 'register PDL_Indx foo = $ind(); if( foo<0 || foo>=$SIZE(n) ) { barf("PDL::index: invalid index %d (valid range 0..%d)", foo,$SIZE(n)-1); }'; my $index_init_bad = 'register PDL_Indx foo = $ind(); if( $ISBADVAR(foo,ind) || foo<0 || foo>=$SIZE(n) ) { barf("PDL::index: invalid index %d (valid range 0..%d)", foo,$SIZE(n)-1); }'; pp_def( 'index', HandleBad => 1, DefaultFlow => 1, Reversible => 1, Pars => 'a(n); indx ind(); [oca] c();', Code => $index_init_good . ' $c() = $a(n => foo);', BadCode => $index_init_bad . ' $c() = $a(n => foo);', BackCode => $index_init_good . ' $a(n => foo) = $c();', BadBackCode => $index_init_bad . ' $a(n => foo) = $c();', Doc => $doc, BadDoc => 'index barfs if any of the index values are bad.', ); pp_def( 'index1d', HandleBad => 1, DefaultFlow => 1, Reversible => 1, Pars => 'a(n); indx ind(m); [oca] c(m);', Code => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( foo<0 || foo >= $SIZE(n) ) { barf("PDL::index1d: invalid index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $c(m=>i) = $a(n=>foo); } }, BadCode => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( $ISBADVAR(foo, ind) ) { $SETBAD(c(m=>i)); } else { if( foo<0 || foo >= $SIZE(n) ) { barf("PDL::index1d: invalid/bad index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $c(m=>i) = $a(n=>foo); } } }, BackCode => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( foo<0 || foo >= $SIZE(n) ) { barf("PDL::index1d: invalid index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $a(n=>foo) = $c(m=>i); } }, BadBackCode => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( $ISBADVAR(foo, ind) ) { /* do nothing */ } else { if( foo<0 || foo >= $SIZE(n) ) { barf("PDL::index1d: invalid/bad index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $a(n=>foo) = $c(m=>i); } } }, Doc => $doc, BadDoc => 'index1d propagates BAD index elements to the output variable.' ); my $index2d_init_good = 'register PDL_Indx fooa,foob; fooa = $inda(); if( fooa<0 || fooa>=$SIZE(na) ) { barf("PDL::index: invalid x-index %d (valid range 0..%d)", fooa,$SIZE(na)-1); } foob = $indb(); if( foob<0 || foob>=$SIZE(nb) ) { barf("PDL::index: invalid y-index %d (valid range 0..%d)", foob,$SIZE(nb)-1); }'; my $index2d_init_bad = 'register PDL_Indx fooa,foob; fooa = $inda(); if( $ISBADVAR(fooa,inda) || fooa<0 || fooa>=$SIZE(na) ) { barf("PDL::index: invalid index 1"); } foob = $indb(); if( $ISBADVAR(foob,indb) || foob<0 || foob>=$SIZE(nb) ) { barf("PDL::index: invalid index 2"); }'; pp_def( 'index2d', HandleBad => 1, DefaultFlow => 1, Reversible => 1, Pars => 'a(na,nb); indx inda(); indx indb(); [oca] c();', Code => $index2d_init_good . ' $c() = $a(na => fooa, nb => foob);', BadCode => $index2d_init_bad . '$c() = $a(na => fooa, nb => foob);', BackCode => $index2d_init_good . ' $a(na => fooa, nb => foob) = $c();', BadBackCode => $index2d_init_bad . '$a(na => fooa, nb => foob) = $c();', Doc => $doc, BadDoc => 'index2d barfs if either of the index values are bad.', ); # indexND: CED 2-Aug-2002 pp_add_exported('','indexND indexNDb'); pp_addpm(<<'EOD-indexND'); =head2 indexNDb =for ref Backwards-compatibility alias for indexND =head2 indexND =for ref Find selected elements in an N-D piddle, with optional boundary handling =for example $out = $source->indexND( $index, [$method] ) $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); print $source->indexND( $index ); [ [23 45] [67 89] ] IndexND collapses C<$index> by lookup into C<$source>. The 0th dimension of C<$index> is treated as coordinates in C<$source>, and the return value has the same dimensions as the rest of C<$index>. The returned elements are looked up from C<$source>. Dataflow works -- propagated assignment flows back into C<$source>. IndexND and IndexNDb were originally separate routines but they are both now implemented as a call to L, and have identical syntax to one another. =cut sub PDL::indexND { my($source,$index, $boundary) = @_; return PDL::range($source,$index,undef,$boundary); } *PDL::indexNDb = \&PDL::indexND; EOD-indexND pp_addpm(<<'EOD-range'); sub PDL::range { my($source,$ind,$sz,$bound) = @_; my $index = PDL->pdl($ind); my $size = defined($sz) ? PDL->pdl($sz) : undef; # Handle empty PDL case: return a properly constructed Empty. if($index->isempty) { my @sdims= $source->dims; splice(@sdims, 0, $index->dim(0) + ($index->dim(0)==0)); # added term is to treat Empty[0] like a single empty coordinate unshift(@sdims, $size->list) if(defined($size)); return PDL->new_from_specification(0 x ($index->ndims-1), @sdims); } $index = $index->dummy(0,1) unless $index->ndims; # Pack boundary string if necessary if(defined $bound) { if(ref $bound eq 'ARRAY') { my ($s,$el); foreach $el(@$bound) { barf "Illegal boundary value '$el' in range" unless( $el =~ m/^([0123fFtTeEpPmM])/ ); $s .= $1; } $bound = $s; } elsif($bound !~ m/^[0123ftepx]+$/ && $bound =~ m/^([0123ftepx])/i ) { $bound = $1; } } no warnings; # shut up about passing undef into rangeb $source->rangeb($index,$size,$bound); } EOD-range =head2 range =cut pp_def( 'rangeb', OtherPars => 'SV *index; SV *size; SV *boundary', Doc => <<'EOD', =for ref Engine for L =for example Same calling convention as L, but you must supply all parameters. C is marginally faster as it makes a direct PP call, avoiding the perl argument-parsing step. =cut =head2 range =for ref Extract selected chunks from a source piddle, with boundary conditions =for example $out = $source->range($index,[$size,[$boundary]]) Returns elements or rectangular slices of the original piddle, indexed by the C<$index> piddle. C<$source> is an N-dimensional piddle, and C<$index> is a piddle whose first dimension has size up to N. Each row of C<$index> is treated as coordinates of a single value or chunk from C<$source>, specifying the location(s) to extract. If you specify a single index location, then range is essentially an expensive slice, with controllable boundary conditions. B C<$index> and C<$size> can be piddles or array refs such as you would feed to L and its ilk. If C<$index>'s 0th dimension has size higher than the number of dimensions in C<$source>, then C<$source> is treated as though it had trivial dummy dimensions of size 1, up to the required size to be indexed by C<$index> -- so if your source array is 1-D and your index array is a list of 3-vectors, you get two dummy dimensions of size 1 on the end of your source array. You can extract single elements or N-D rectangular ranges from C<$source>, by setting C<$size>. If C<$size> is undef or zero, then you get a single sample for each row of C<$index>. This behavior is similar to L, which is in fact implemented as a call to L. If C<$size> is positive then you get a range of values from C<$source> at each location, and the output has extra dimensions allocated for them. C<$size> can be a scalar, in which case it applies to all dimensions, or an N-vector, in which case each element is applied independently to the corresponding dimension in C<$source>. See below for details. C<$boundary> is a number, string, or list ref indicating the type of boundary conditions to use when ranges reach the edge of C<$source>. If you specify no boundary conditions the default is to forbid boundary violations on all axes. If you specify exactly one boundary condition, it applies to all axes. If you specify more (as elements of a list ref, or as a packed string, see below), then they apply to dimensions in the order in which they appear, and the last one applies to all subsequent dimensions. (This is less difficult than it sounds; see the examples below). =over 3 =item 0 (synonyms: 'f','forbid') B<(default)> Ranges are not allowed to cross the boundary of the original PDL. Disallowed ranges throw an error. The errors are thrown at evaluation time, not at the time of the range call (this is the same behavior as L). =item 1 (synonyms: 't','truncate') Values outside the original piddle get BAD if you've got bad value support compiled into your PDL and set the badflag for the source PDL; or 0 if you haven't (you must set the badflag if you want BADs for out of bound values, otherwise you get 0). Reverse dataflow works OK for the portion of the child that is in-bounds. The out-of-bounds part of the child is reset to (BAD|0) during each dataflow operation, but execution continues. =item 2 (synonyms: 'e','x','extend') Values that would be outside the original piddle point instead to the nearest allowed value within the piddle. See the CAVEAT below on mappings that are not single valued. =item 3 (synonyms: 'p','periodic') Periodic boundary conditions apply: the numbers in $index are applied, strict-modulo the corresponding dimensions of $source. This is equivalent to duplicating the $source piddle throughout N-D space. See the CAVEAT below about mappings that are not single valued. =item 4 (synonyms: 'm','mirror') Mirror-reflection periodic boundary conditions apply. See the CAVEAT below about mappings that are not single valued. =back The boundary condition identifiers all begin with unique characters, so you can feed in multiple boundary conditions as either a list ref or a packed string. (The packed string is marginally faster to run). For example, the four expressions [0,1], ['forbid','truncate'], ['f','t'], and 'ft' all specify that violating the boundary in the 0th dimension throws an error, and all other dimensions get truncated. If you feed in a single string, it is interpreted as a packed boundary array if all of its characters are valid boundary specifiers (e.g. 'pet'), but as a single word-style specifier if they are not (e.g. 'forbid'). B The output threads over both C<$index> and C<$source>. Because implicit threading can happen in a couple of ways, a little thought is needed. The returned dimension list is stacked up like this: (index thread dims), (index dims (size)), (source thread dims) The first few dims of the output correspond to the extra dims of C<$index> (beyond the 0 dim). They allow you to pick out individual ranges from a large, threaded collection. The middle few dims of the output correspond to the size dims specified in C<$size>, and contain the range of values that is extracted at each location in C<$source>. Every nonzero element of C<$size> is copied to the dimension list here, so that if you feed in (for example) C<$size = [2,0,1]> you get an index dim list of C<(2,1)>. The last few dims of the output correspond to extra dims of C<$source> beyond the number of dims indexed by C<$index>. These dims act like ordinary thread dims, because adding more dims to C<$source> just tacks extra dims on the end of the output. Each source thread dim ranges over the entire corresponding dim of C<$source>. B: Dataflow is bidirectional. B: Here are basic examples of C operation, showing how to get ranges out of a small matrix. The first few examples show extraction and selection of individual chunks. The last example shows how to mark loci in the original matrix (using dataflow). pdl> $src = 10*xvals(10,5)+yvals(10,5) pdl> print $src->range([2,3]) # Cut out a single element 23 pdl> print $src->range([2,3],1) # Cut out a single 1x1 block [ [23] ] pdl> print $src->range([2,3], [2,1]) # Cut a 2x1 chunk [ [23 33] ] pdl> print $src->range([[2,3]],[2,1]) # Trivial list of 1 chunk [ [ [23] [33] ] ] pdl> print $src->range([[2,3],[0,1]], [2,1]) # two 2x1 chunks [ [ [23 1] [33 11] ] ] pdl> # A 2x2 collection of 2x1 chunks pdl> print $src->range([[[1,1],[2,2]],[[2,3],[0,1]]],[2,1]) [ [ [ [11 22] [23 1] ] [ [21 32] [33 11] ] ] ] pdl> $src = xvals(5,3)*10+yvals(5,3) pdl> print $src->range(3,1) # Thread over y dimension in $src [ [30] [31] [32] ] pdl> $src = zeroes(5,4); pdl> $src->range(pdl([2,3],[0,1]),pdl(2,1)) .= xvals(2,2,1) + 1 pdl> print $src [ [0 0 0 0 0] [2 2 0 0 0] [0 0 0 0 0] [0 0 1 1 0] ] B: It's quite possible to select multiple ranges that intersect. In that case, modifying the ranges doesn't have a guaranteed result in the original PDL -- the result is an arbitrary choice among the valid values. For some things that's OK; but for others it's not. In particular, this doesn't work: pdl> $photon_list = new PDL::RandVar->sample(500)->reshape(2,250)*10 pdl> histogram = zeroes(10,10) pdl> histogram->range($photon_list,1)++; #not what you wanted The reason is that if two photons land in the same bin, then that bin doesn't get incremented twice. (That may get fixed in a later version...) B: If C<$index> has too many dimensions compared to C<$source>, then $source is treated as though it had dummy dimensions of size 1, up to the required number of dimensions. These virtual dummy dimensions have the usual boundary conditions applied to them. If the 0 dimension of C<$index> is ludicrously large (if its size is more than 5 greater than the number of dims in the source PDL) then range will insist that you specify a size in every dimension, to make sure that you know what you're doing. That catches a common error with range usage: confusing the initial dim (which is usually small) with another index dim (perhaps of size 1000). If the index variable is Empty, then range() always returns the Empty PDL. If the index variable is not Empty, indexing it always yields a boundary violation. All non-barfing conditions are treated as truncation, since there are no actual data to return. B: Because C isn't an affine transformation (it involves lookup into a list of N-D indices), it is somewhat memory-inefficient for long lists of ranges, and keeping dataflow open is much slower than for affine transformations (which don't have to copy data around). Doing operations on small subfields of a large range is inefficient because the engine must flow the entire range back into the original PDL with every atomic perl operation, even if you only touch a single element. One way to speed up such code is to sever your range, so that PDL doesn't have to copy the data with each operation, then copy the elements explicitly at the end of your loop. Here's an example that labels each region in a range sequentially, using many small operations rather than a single xvals assignment: ### How to make a collection of small ops run fast with range... $a = $data->range($index, $sizes, $bound)->sever; $aa = $data->range($index, $sizes, $bound); map { $a($_ - 1) .= $_; } (1..$a->nelem); # Lots of little ops $aa .= $a; C is a perl front-end to a PP function, C. Calling C is marginally faster but requires that you include all arguments. DEVEL NOTES * index thread dimensions are effectively clumped internally. This makes it easier to loop over the index array but a little more brain-bending to tease out the algorithm. =cut EOD HandleBad => 1, DefaultFlow => 1, Reversible => 1, P2Child => 1, NoPdlThread => 1, # # rdim: dimensionality of each range (0 dim of index PDL) # # ntsize: number of nonzero size dimensions # sizes: array of range sizes, indexed (0..rdim-1). A zero element means # that the dimension is omitted from the child dim list. # corners: parent coordinates of each corner, running fastest over coord index. # (indexed 0 .. (nitems-1)*(rdim)+rdim-1) # nitems: total number of list elements (product of itdims) # itdim: number of index thread dimensions # itdims: Size of each index thread dimension, indexed (0..itdim-1) # # bsize: Number of independently specified boundary conditions # nsizes: Number of independently specified range dim sizes # boundary: Array containing all the boundary condition specs # indord: Order/size of the indexing dim (0th dim of $index) Comp => 'PDL_Indx rdim; PDL_Indx nitems; PDL_Indx itdim; PDL_Indx ntsize; PDL_Indx bsize; PDL_Indx nsizes; PDL_Indx sizes[$COMP(rdim)]; PDL_Indx itdims[$COMP(itdim)]; PDL_Indx corners[$COMP(rdim) * $COMP(nitems)]; char boundary[$COMP(rdim)]; ', MakeComp => <<'EOD-MakeComp', pdl *ind_pdl; pdl *size_pdl; /*** * Check and condition the index piddle. Some of this is apparently * done by XS -- but XS doesn't check for existing SVs that are undef. */ if ((index==NULL) || (index == &PL_sv_undef)) { $CROAK("rangeb: index variable must be defined"); } if(!(ind_pdl = PDL->SvPDLV(index))) /* assignment */ { $CROAK("rangeb: unable to convert index variable to a PDL"); } PDL->make_physdims(ind_pdl); /* Generalized empties are ok, but not in the special 0 dim (the index vector) */ if(ind_pdl->dims[0] == 0) { $CROAK("rangeb: can't handle Empty indices -- call range instead"); } /*** * Ensure that the index is a PDL_Indx. If there's no loss of information, * just upgrade it -- otherwise, make a temporary copy. */ switch(ind_pdl->datatype) { default: /* Most types: */ ind_pdl = PDL->hard_copy(ind_pdl); /* copy and fall through */ case PDL_B: case PDL_S: case PDL_US: case PDL_L: case PDL_LL: PDL->converttype(&ind_pdl,PDL_IND,1); /* convert in place. */ break; case PDL_IND: /* do nothing */ break; } /*** * Figure sizes of the COMP arrrays and allocate them. */ { PDL_Indx i,nitems; $COMP(rdim) = ind_pdl->ndims ? ind_pdl->dims[0] : 1; for(i=nitems=1; i < ind_pdl->ndims; i++) /* Accumulate item list size */ nitems *= ind_pdl->dims[i]; $COMP(nitems) = nitems; $COMP(itdim) = ind_pdl->ndims ? ind_pdl->ndims - 1 : 0; $DOCOMPDIMS(); } /*** * Fill in the boundary condition array */ { char *bstr; STRLEN blen; bstr = SvPV(boundary,blen); if(blen == 0) { /* If no boundary is specified then every dim gets forbidden */ int i; for (i=0;i<$COMP(rdim);i++) $COMP(boundary[i]) = 0; } else { int i; for(i=0;i<$COMP(rdim);i++) { switch(bstr[i < blen ? i : blen-1 ]) { case '0': case 'f': case 'F': /* forbid */ $COMP(boundary[i]) = 0; break; case '1': case 't': case 'T': /* truncate */ $COMP(boundary[i]) = 1; break; case '2': case 'e': case 'E': /* extend */ $COMP(boundary[i]) = 2; break; case '3': case 'p': case 'P': /* periodic */ $COMP(boundary[i]) = 3; break; case '4': case 'm': case 'M': /* mirror */ $COMP(boundary[i]) = 4; break; default: { /* No need to check if i < blen -- this will barf out the * first time it gets hit. I didn't use $ CROAK 'coz that * macro doesn't let you pass in a string variable -- only a * constant. */ barf("Error in rangeb: Unknown boundary condition '%c' in range",bstr[i]); } break; } // end of switch } } } /*** * Store the sizes of the index-thread dims */ { PDL_Indx i; PDL_Indx nd = ind_pdl->ndims - 1; for(i=0; i < nd ; i++) $COMP(itdims[i]) = ind_pdl->dims[i+1]; } /*** * Check and condition the size piddle, and store sizes of the ranges */ { PDL_Indx i,ntsize; if( (size == NULL) || (size == &PL_sv_undef) ) { // NO size was passed in (not normally executed even if you passed in no size to range(), // as range() generates a size array... for(i=0;i<$COMP(rdim);i++) $COMP(sizes[i]) = 0; } else { /* Normal case with sizes present in a PDL */ if(!(size_pdl = PDL->SvPDLV(size))) /* assignment */ $CROAK("Unable to convert size to a PDL in range"); if(size_pdl->nvals == 0) { // no values in the size_pdl - Empty or Null. Just copy 0s to all the range dims for(i=0;i<$COMP(rdim);i++) $COMP(sizes[i]) = 0; } else { // Convert size PDL to PDL_IND to support indices switch(size_pdl->datatype) { default: /* Most types: */ size_pdl = PDL->hard_copy(size_pdl); /* copy and fall through */ case PDL_B: case PDL_S: case PDL_US: case PDL_L: case PDL_LL: PDL->converttype(&size_pdl,PDL_IND,1); /* convert in place. */ break; case PDL_IND: break; } $COMP(nsizes) = size_pdl->nvals; /* Store for later permissiveness check */ /* Copy the sizes, or die if they're the wrong shape */ if(size_pdl->nvals == 1) { for(i=0;i<$COMP(rdim);i++) { $COMP(sizes[i]) = *((PDL_Indx *)(size_pdl->data)); } /* Check for nonnegativity of sizes. The rdim>0 mask ensures that */ /* we don't barf on the Empty PDL (as an index). */ if( $COMP(rdim) > 0 && $COMP(sizes[0]) < 0 ) { $CROAK(" Negative range size is not allowed in range\n"); } } else if( size_pdl->nvals <= $COMP(rdim) && size_pdl->ndims == 1) { for(i=0;i<$COMP(rdim);i++) { $COMP(sizes[i]) = ( (i < size_pdl->nvals) ? ((PDL_Indx *)(size_pdl->data))[i] : 0 ); if($COMP(sizes[i]) < 0) $CROAK(" Negative range sizes are not allowed in range\n"); } } else { $CROAK(" Size must match index's 0th dim in range\n"); } } /* end of nonempty size-piddle code */ } /* end of defined-size-piddle code */ /* Insert the number of nontrivial sizes (these get output dimensions) */ for(i=ntsize=0;i<$COMP(rdim);i++) if($COMP(sizes[i])) ntsize++; $COMP(ntsize) = ntsize; } /*** * Stash coordinates of the corners */ { PDL_Indx i,j,k,ioff; PDL_Indx *cptr; PDL_Indx *iter = (PDL_Indx *)(PDL->smalloc((STRLEN) (sizeof(PDL_Indx) * ($COMP(itdim))))); /* initialize iterator to loop over index threads */ cptr = iter; for(k=0;k<$COMP(itdim);k++) *(cptr++) = 0; cptr = $COMP(corners); do { /* accumulate offset into the index from the iterator */ for(k=ioff=0;k<$COMP(itdim);k++) ioff += iter[k] * ind_pdl->dimincs[k+1]; /* Loop over the 0th dim of index, copying coords. */ /* This is the natural place to check for permissive ranging; too */ /* bad we don't have access to the parent piddle here... */ for(j=0;j<$COMP(rdim);j++) *(cptr++) = ((PDL_Indx *)(ind_pdl->data))[ioff + ind_pdl->dimincs[0] * j]; /* Increment the iterator -- the test increments, the body carries. */ for(k=0; k<$COMP(itdim) && (++(iter[k]))>=($COMP(itdims)[k]) ;k++) iter[k] = 0; } while(k<$COMP(itdim)); } $SETREVERSIBLE(1); EOD-MakeComp RedoDims => <<'EOD-RedoDims' , { PDL_Indx stdim = $PARENT(ndims) - $COMP(rdim); PDL_Indx dim,inc; PDL_Indx i,rdvalid; // Speed bump for ludicrous cases if( $COMP(rdim) > $PARENT(ndims)+5 && $COMP(nsizes) != $COMP(rdim)) { barf("Ludicrous number of extra dims in range index; leaving child null.\n (%d implicit dims is > 5; index has %d dims; source has %d dim%s.)\n This often means that your index PDL is incorrect. To avoid this message,\n allocate dummy dims in the source or use %d dims in range's size field.\n",$COMP(rdim)-$PARENT(ndims),$COMP(rdim),$PARENT(ndims),($PARENT(ndims))>1?"s":"",$COMP(rdim)); } if(stdim < 0) stdim = 0; /* Set dimensionality of child */ $CHILD(ndims) = $COMP(itdim) + $COMP(ntsize) + stdim; $SETNDIMS($COMP(itdim)+$COMP(ntsize)+stdim); inc = 1; /* Copy size dimensions to child, crunching as we go. */ dim = $COMP(itdim); for(i=rdvalid=0;i<$COMP(rdim);i++) { if($COMP(sizes[i])) { rdvalid++; $CHILD(dimincs[dim]) = inc; inc *= ($CHILD(dims[dim++]) = $COMP(sizes[i])); /* assignment */ } } /* Copy index thread dimensions to child */ for(dim=0; dim<$COMP(itdim); dim++) { $CHILD(dimincs[dim]) = inc; inc *= ($CHILD(dims[dim]) = $COMP(itdims[dim])); /* assignment */ } /* Copy source thread dimensions to child */ dim = $COMP(itdim) + rdvalid; for(i=0;i <<'EOD-EquivCPOffsCode', { PDL_Indx *iter, *ip; /* vector iterator */ PDL_Indx *sizes, *sp; /* size vector including stdims */ PDL_Indx *coords; /* current coordinates */ PDL_Indx k; /* index */ PDL_Indx item; /* index thread iterator */ PDL_Indx pdim = $PARENT_P(ndims); PDL_Indx rdim = $COMP(rdim); PDL_Indx prdim = (rdim < pdim) ? rdim : pdim; PDL_Indx stdim = pdim - prdim; /* Allocate iterator and larger size vector -- do it all in one foop * to avoid extra calls to smalloc. */ if(!(iter = (PDL_Indx *)(PDL->smalloc((STRLEN) (sizeof(PDL_Indx) * ($PARENT_P(ndims) * 2 + rdim)))))) { barf("couldn't get memory for range iterator"); } sizes = iter + $PARENT_P(ndims); coords = sizes + $PARENT_P(ndims); /* Figure out size vector */ for(ip = $COMP(sizes), sp = sizes, k=0; k= $PARENT_P(dims[k])) { switch($COMP(boundary[k])) { case 0: /* no boundary breakage allowed */ barf("index out-of-bounds in range"); break; case 1: /* truncation */ trunc = 1; break; case 2: /* extension -- crop */ ck = (ck >= $PARENT_P(dims[k])) ? $PARENT_P(dims[k])-1 : 0; break; case 3: /* periodic -- mod it */ ck %= $PARENT_P(dims[k]); if(ck < 0) /* Fix mod breakage in C */ ck += $PARENT_P(dims[k]); break; case 4: /* mirror -- reflect off the edges */ ck += $PARENT_P(dims[k]); ck %= ($PARENT_P(dims[k]) * 2); if(ck < 0) /* Fix mod breakage in C */ ck += $PARENT_P(dims[k])*2; ck -= $PARENT_P(dims[k]); if(ck < 0) { ck *= -1; ck -= 1; } break; default: barf("Unknown boundary condition in range -- bug alert!"); break; } } coords[k] = ck; } /* Check extra dimensions -- pick up where k left off... */ for( ; k < rdim ; k++) { /* Check for indexing off the end of the dimension list */ PDL_Indx ck = iter[k] + $COMP(corners[ item * rdim + k ]) ; switch($COMP(boundary[k])) { case 0: /* No boundary breakage allowed -- nonzero corners cause barfage */ if(ck != 0) barf("Too many dims in range index (and you've forbidden boundary violations)"); break; case 1: /* truncation - just truncate if the corner is nonzero */ trunc |= (ck != 0); break; case 2: /* extension -- ignore the corner (same as 3) */ case 3: /* periodic -- ignore the corner */ case 4: /* mirror -- ignore the corner */ ck = 0; break; default: barf("Unknown boudnary condition in range -- bug alert!"); /* Note clever misspelling of boundary to distinguish from other case */ break; } } /* Find offsets into the child and parent arrays, from the N-D coords */ /* Note we only loop over real source dims (prdim) to accumulate -- */ /* because the offset is trivial and/or we're truncating for virtual */ /* dims caused by permissive ranging. */ coff = $CHILD_P(dimincs[0]) * item; for(k2 = $COMP(itdim), poff = k = 0; k < prdim; k++) { poff += coords[k]*$PARENT_P(dimincs[k]); if($COMP(sizes[k])) coff += iter[k] * $CHILD_P(dimincs[k2++]); } /* Loop the copy over all the source thread dims (above rdim). */ do { PDL_Indx poff1 = poff; PDL_Indx coff1 = coff; /* Accumulate the offset due to source threading */ for(k2 = $COMP(itdim) + $COMP(ntsize), k = rdim; k < pdim; k++) { poff1 += iter[k] * $PARENT_P(dimincs[k]); coff1 += iter[k] * $CHILD_P(dimincs[k2++]); } /* Finally -- make the copy * EQUIVCPTRUNC works like EQUIVCPOFFS but with checking for * out-of-bounds conditions. */ $EQUIVCPTRUNC(coff1,poff1,trunc); /* Increment the source thread iterator */ for( k=$COMP(rdim); k < $PARENT_P(ndims) && (++(iter[k]) >= $PARENT_P(dims[k])); k++) iter[k] = 0; } while(k < $PARENT_P(ndims)); /* end of source-thread iteration */ /* Increment the in-range iterator */ for(k = 0; k < $COMP(rdim) && (++(iter[k]) >= $COMP(sizes[k])); k++) iter[k] = 0; } while(k < $COMP(rdim)); /* end of main iteration */ } /* end of item do loop */ } EOD-EquivCPOffsCode ); =head2 rld =cut pp_def( 'rld', Pars=>'indx a(n); b(n); [o]c(m);', PMCode =><<'EOD', sub PDL::rld { my ($a,$b) = @_; my ($c); if ($#_ == 2) { $c = $_[2]; } else { # XXX Need to improve emulation of threading in auto-generating c my ($size) = $a->sumover->max; my (@dims) = $a->dims; shift @dims; $c = $b->zeroes($size,@dims); } &PDL::_rld_int($a,$b,$c); $c; } EOD Code=>' PDL_Indx i,j=0,an; $GENERIC(b) bv; loop (n) %{ an = $a(); bv = $b(); for (i=0;ij) = bv; j++; } %}', Doc => <<'EOD' =for ref Run-length decode a vector Given a vector C<$a> of the numbers of instances of values C<$b>, run-length decode to C<$c>. =for example rld($a,$b,$c=null); =cut EOD ); =head2 rle =cut pp_def( 'rle', Pars=>'c(n); indx [o]a(m); [o]b(m);', #this RedoDimsCode sets $SIZE(m)==$SIZE(n), but the slice in the PMCode below makes m<=n. RedoDimsCode=>'$SIZE(m)=$PDL(c)->dims[0];', PMCode=><<'EOC', sub PDL::rle { my $c = shift; my ($a,$b) = @_==2 ? @_ : (null,null); &PDL::_rle_int($c,$a,$b); my $max_ind = ($c->ndims<2) ? ($a!=0)->sumover-1 : ($a!=0)->clump(1..$a->ndims-1)->sumover->max-1; return ($a->slice("0:$max_ind"),$b->slice("0:$max_ind")); } EOC Code=>' PDL_Indx j=0,sn=$SIZE(n); $GENERIC(c) cv, clv; clv = $c(n=>0); $b(m=>0) = clv; $a(m=>0) = 0; loop (n) %{ cv = $c(); if (cv == clv) { $a(m=>j)++; } else { j++; $b(m=>j) = clv = cv; $a(m=>j) = 1; } %} for (j++;j<$SIZE(m);j++) { $a(m=>j) = 0; $b(m=>j) = 0; } ', Doc => <<'EOD' =for ref Run-length encode a vector Given vector C<$c>, generate a vector C<$a> with the number of each element, and a vector C<$b> of the unique values. New in PDL 2.017, only the elements up to the first instance of C<0> in C<$a> are returned, which makes the common use case of a 1-dimensional C<$c> simpler. For threaded operation, C<$a> and C<$b> will be large enough to hold the largest row of C<$a>, and only the elements up to the first instance of C<0> in each row of C<$a> should be considered. =for example $c = floor(4*random(10)); rle($c,$a=null,$b=null); #or ($a,$b) = rle($c); #for $c of shape [10, 4]: $c = floor(4*random(10,4)); ($a,$b) = rle($c); #to see the results of each row one at a time: foreach (0..$c->dim(1)-1){ my ($as,$bs) = ($a(:,($_)),$b(:,($_))); my ($ta,$tb) = where($as,$bs,$as!=0); #only the non-zero elements of $a print $c(:,($_)) . " rle==> " , ($ta,$tb) , "\trld==> " . rld($ta,$tb) . "\n"; } =cut EOD ); # this one can convert vaffine piddles without(!) physicalising them # maybe it can replace 'converttypei' in the future? # # XXX do not know whether the HandleBad stuff will work here # pp_def('flowconvert', HandleBad => 1, DefaultFlow => 1, Reversible => 1, Pars => 'PARENT(); [oca]CHILD()', OtherPars => 'int totype;', Reversible => 1, # Forced types FTypes => {CHILD => '$COMP(totype)'}, Code => '$CHILD() = $PARENT();', BadCode => 'if ( $ISBAD(PARENT()) ) { $SETBAD(CHILD()); } else { $CHILD() = $PARENT(); }', BackCode => '$PARENT() = $CHILD();', BadBackCode => 'if ( $ISBAD(CHILD()) ) { $SETBAD(PARENT()); } else { $PARENT() = $CHILD(); }', Doc => 'internal', ); pp_def( 'converttypei', HandleBad => 1, DefaultFlow => 1, GlobalNew => 'converttypei_new', OtherPars => 'int totype;', P2Child => 1, NoPdlThread => 1, Identity => 1, Reversible => 1, # Forced types FTypes => {CHILD => '$COMP(totype)'}, Doc => 'internal', ); # the perl wrapper clump is now defined in Core.pm # this is just the low level interface pp_def( '_clump_int', DefaultFlow => 1, OtherPars => 'int n', P2Child => 1, NoPdlThread=>1, Priv => 'int nnew; int nrem;', RedoDims => 'int i; PDL_Indx d1; /* truncate overly long clumps to just clump existing dimensions */ if($COMP(n) > $PARENT(ndims)) $COMP(n) = $PARENT(ndims); if($COMP(n) < -1) $COMP(n) = $PARENT(ndims) + $COMP(n) + 1; $PRIV(nrem) = ($COMP(n)==-1 ? $PARENT(threadids[0]) : $COMP(n)); $PRIV(nnew) = $PARENT(ndims) - $PRIV(nrem) + 1; $SETNDIMS($PRIV(nnew)); d1=1; for(i=0; i<$PRIV(nrem); i++) { d1 *= $PARENT(dims[i]); } $CHILD(dims[0]) = d1; for(; i<$PARENT(ndims); i++) { $CHILD(dims[i-$PRIV(nrem)+1]) = $PARENT(dims[i]); } $SETDIMS(); $SETDELTATHREADIDS(1-$PRIV(nrem)); ', EquivCPOffsCode => ' PDL_Indx i; for(i=0; i<$CHILD_P(nvals); i++) { $EQUIVCPOFFS(i,i); } ', Reversible => 1, Doc => 'internal', ); =head2 xchg =cut pp_def( 'xchg', OtherPars => 'int n1; int n2;', DefaultFlow => 1, Reversible => 1, P2Child => 1, NoPdlThread => 1, XCHGOnly => 1, EquivDimCheck => 'if ($COMP(n1) <0) $COMP(n1) += $PARENT(threadids[0]); if ($COMP(n2) <0) $COMP(n2) += $PARENT(threadids[0]); if ($COMP(n1) <0 ||$COMP(n2) <0 || $COMP(n1) >= $PARENT(threadids[0]) || $COMP(n2) >= $PARENT(threadids[0])) barf("One of dims %d, %d out of range: should be 0<=dim<%d", $COMP(n1),$COMP(n2),$PARENT(threadids[0]));', EquivPDimExpr => '(($CDIM == $COMP(n1)) ? $COMP(n2) : ($CDIM == $COMP(n2)) ? $COMP(n1) : $CDIM)', EquivCDimExpr => '(($PDIM == $COMP(n1)) ? $COMP(n2) : ($PDIM == $COMP(n2)) ? $COMP(n1) : $PDIM)', Doc => <<'EOD', =for ref exchange two dimensions Negative dimension indices count from the end. The command =for example $b = $a->xchg(2,3); creates C<$b> to be like C<$a> except that the dimensions 2 and 3 are exchanged with each other i.e. $b->at(5,3,2,8) == $a->at(5,3,8,2) =cut EOD ); pp_addpm(<< 'EOD'); =head2 reorder =for ref Re-orders the dimensions of a PDL based on the supplied list. Similar to the L method, this method re-orders the dimensions of a PDL. While the L method swaps the position of two dimensions, the reorder method can change the positions of many dimensions at once. =for usage # Completely reverse the dimension order of a 6-Dim array. $reOrderedPDL = $pdl->reorder(5,4,3,2,1,0); The argument to reorder is an array representing where the current dimensions should go in the new array. In the above usage, the argument to reorder C<(5,4,3,2,1,0)> indicates that the old dimensions (C<$pdl>'s dims) should be re-arranged to make the new pdl (C<$reOrderPDL>) according to the following: Old Position New Position ------------ ------------ 5 0 4 1 3 2 2 3 1 4 0 5 You do not need to specify all dimensions, only a complete set starting at position 0. (Extra dimensions are left where they are). This means, for example, that you can reorder() the X and Y dimensions of an image, and not care whether it is an RGB image with a third dimension running across color plane. =for example Example: pdl> $a = sequence(5,3,2); # Create a 3-d Array pdl> p $a [ [ [ 0 1 2 3 4] [ 5 6 7 8 9] [10 11 12 13 14] ] [ [15 16 17 18 19] [20 21 22 23 24] [25 26 27 28 29] ] ] pdl> p $a->reorder(2,1,0); # Reverse the order of the 3-D PDL [ [ [ 0 15] [ 5 20] [10 25] ] [ [ 1 16] [ 6 21] [11 26] ] [ [ 2 17] [ 7 22] [12 27] ] [ [ 3 18] [ 8 23] [13 28] ] [ [ 4 19] [ 9 24] [14 29] ] ] The above is a simple example that could be duplicated by calling C<$a-Exchg(0,2)>, but it demonstrates the basic functionality of reorder. As this is an index function, any modifications to the result PDL will change the parent. =cut sub PDL::reorder { my ($pdl,@newDimOrder) = @_; my $arrayMax = $#newDimOrder; #Error Checking: if( $pdl->getndims < scalar(@newDimOrder) ){ my $errString = "PDL::reorder: Number of elements (".scalar(@newDimOrder).") in newDimOrder array exceeds\n"; $errString .= "the number of dims in the supplied PDL (".$pdl->getndims.")"; barf($errString); } # Check to make sure all the dims are within bounds for my $i(0..$#newDimOrder) { my $dim = $newDimOrder[$i]; if($dim < 0 || $dim > $#newDimOrder) { my $errString = "PDL::reorder: Dim index $newDimOrder[$i] out of range in position $i\n(range is 0-$#newDimOrder)"; barf($errString); } } # Checking that they are all present and also not duplicated is done by thread() [I think] # a quicker way to do the reorder return $pdl->thread(@newDimOrder)->unthread(0); } EOD =head2 mv =cut pp_def( 'mv', OtherPars => 'int n1; int n2;', DefaultFlow => 1, Reversible => 1, P2Child => 1, NoPdlThread => 1, XCHGOnly => 1, EquivDimCheck => 'if ($COMP(n1) <0) $COMP(n1) += $PARENT(threadids[0]); if ($COMP(n2) <0) $COMP(n2) += $PARENT(threadids[0]); if ($COMP(n1) <0 ||$COMP(n2) <0 || $COMP(n1) >= $PARENT(threadids[0]) || $COMP(n2) >= $PARENT(threadids[0])) barf("One of dims %d, %d out of range: should be 0<=dim<%d", $COMP(n1),$COMP(n2),$PARENT(threadids[0]));', EquivPDimExpr => '(($COMP(n1) < $COMP(n2)) ? (($CDIM < $COMP(n1) || $CDIM > $COMP(n2)) ? $CDIM : (($CDIM == $COMP(n2)) ? $COMP(n1) : $CDIM+1)) : (($COMP(n2) < $COMP(n1)) ? (($CDIM > $COMP(n1) || $CDIM < $COMP(n2)) ? $CDIM : (($CDIM == $COMP(n2)) ? $COMP(n1) : $CDIM-1)) : $CDIM))', EquivCDimExpr => '(($COMP(n2) < $COMP(n1)) ? (($PDIM < $COMP(n2) || $PDIM > $COMP(n1)) ? $PDIM : (($PDIM == $COMP(n1)) ? $COMP(n2) : $PDIM+1)) : (($COMP(n1) < $COMP(n2)) ? (($PDIM > $COMP(n2) || $PDIM < $COMP(n1)) ? $PDIM : (($PDIM == $COMP(n1)) ? $COMP(n2) : $PDIM-1)) : $PDIM))', Doc => << 'EOD', =for ref move a dimension to another position The command =for example $b = $a->mv(4,1); creates C<$b> to be like C<$a> except that the dimension 4 is moved to the place 1, so: $b->at(1,2,3,4,5,6) == $a->at(1,5,2,3,4,6); The other dimensions are moved accordingly. Negative dimension indices count from the end. =cut EOD ); pp_addhdr << 'EOH'; #define sign(x) ( (x) < 0 ? -1 : 1) EOH =head2 oslice =cut # I think the quotes in the =item ":" lines # confuse the perldoc stuff # pp_def( 'oslice', Doc => << 'EOD', =for ref DEPRECATED: 'oslice' is the original 'slice' routine in pre-2.006_006 versions of PDL. It is left here for reference but will disappear in PDL 3.000 Extract a rectangular slice of a piddle, from a string specifier. C was the original Swiss-army-knife PDL indexing routine, but is largely superseded by the L source prefilter and its associated L method. It is still used as the basic underlying slicing engine for L, and is especially useful in particular niche applications. =for example $a->slice('1:3'); # return the second to fourth elements of $a $a->slice('3:1'); # reverse the above $a->slice('-2:1'); # return last-but-one to second elements of $a The argument string is a comma-separated list of what to do for each dimension. The current formats include the following, where I, I and I are integers and can take legal array index values (including -1 etc): =over 8 =item : takes the whole dimension intact. =item '' (nothing) is a synonym for ":" (This means that C<$a-Eslice(':,3')> is equal to C<$a-Eslice(',3')>). =item a slices only this value out of the corresponding dimension. =item (a) means the same as "a" by itself except that the resulting dimension of length one is deleted (so if C<$a> has dims C<(3,4,5)> then C<$a-Eslice(':,(2),:')> has dimensions C<(3,5)> whereas C<$a-Eslice(':,2,:')> has dimensions C<(3,1,5))>. =item a:b slices the range I to I inclusive out of the dimension. =item a:b:c slices the range I to I, with step I (i.e. C<3:7:2> gives the indices C<(3,5,7)>). This may be confusing to Matlab users but several other packages already use this syntax. =item '*' inserts an extra dimension of width 1 and =item '*a' inserts an extra (dummy) dimension of width I. =back An extension is planned for a later stage allowing C<$a-Eslice('(=1),(=1|5:8),3:6(=1),4:6')> to express a multidimensional diagonal of C<$a>. Trivial out-of-bounds slicing is allowed: if you slice a source dimension that doesn't exist, but only index the 0th element, then C treats the source as if there were a dummy dimension there. The following are all equivalent: xvals(5)->dummy(1,1)->slice('(2),0') # Add dummy dim, then slice xvals(5)->slice('(2),0') # Out-of-bounds slice adds dim. xvals(5)->slice((2),0) # NiceSlice syntax xvals(5)->((2))->dummy(0,1) # NiceSlice syntax This is an error: xvals(5)->slice('(2),1') # nontrivial out-of-bounds slice dies Because slicing doesn't directly manipulate the source and destination pdl -- it just sets up a transformation between them -- indexing errors often aren't reported until later. This is either a bug or a feature, depending on whether you prefer error-reporting clarity or speed of execution. =cut EOD P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, OtherPars => 'char* str', Comp => 'int nnew; int nthintact; int intactnew; int ndum; int corresp[$COMP(intactnew)]; PDL_Indx start[$COMP(intactnew)]; PDL_Indx inc[$COMP(intactnew)]; PDL_Indx end[$COMP(intactnew)]; int nolddims; int whichold[$COMP(nolddims)]; int oldind[$COMP(nolddims)]; ', AffinePriv => 1, MakeComp => q~ int i; int nthnew; int nthold; int nthreal; PDL_Indx dumsize; char *s; char *ns; int nums[3]; int nthnum; $COMP(nnew)=0; $COMP(ndum)=0; $COMP(nolddims) = 0; if(str[0] == '(') $COMP(nolddims)++; else if (str[0] == '*') $COMP(ndum)++; else if (str[0] != '\0') /* handle empty string */ $COMP(nnew)++; for(i=0; str[i]; i++) if(str[i] == ',') { if(str[i+1] == '(') $COMP(nolddims)++; else if(str[i+1] == '*') $COMP(ndum)++; else $COMP(nnew)++; } $COMP(nthintact) = $COMP(nolddims) + $COMP(nnew); $COMP(intactnew) = $COMP(nnew)+$COMP(ndum); $DOCOMPDIMS(); nthnew=0; nthold=0; i=0; nthreal=0; s=str-1; do { s++; if(isdigit(*s) || *s == '-') { nthnew++; nthreal++; $COMP(inc[nthnew-1]) = 1; $COMP(corresp[nthnew-1]) = nthreal-1; $COMP(start[nthnew-1]) = strtoll(s,&s,10); if(*s != ':') { $COMP(end[nthnew-1]) = $COMP(start[nthnew-1]); goto outlab; } s++; if(!isdigit(*s) && !(*s == '-')) { barf("Invalid slice str ind1 '%s': '%s'",str,s); } $COMP(end[nthnew-1]) = strtoll(s,&s,10); if(*s != ':') {goto outlab;} s++; if(!isdigit(*s) && !(*s == '-')) { barf("Invalid slice str ind2 '%s': '%s'",str,s); } $COMP(inc[nthnew-1]) = strtoll(s,&s,10); } else switch(*s) { case ':': s++; /* FALLTHRU */ case ',': case '\0': /* In these cases, no inc s */ if ($COMP(intactnew) > 0) { $COMP(start[nthnew]) = 0; $COMP(end[nthnew]) = -1; $COMP(inc[nthnew]) = 1; $COMP(corresp[nthnew]) = nthreal; nthnew++; nthreal++; } break; case '(': s++; $COMP(oldind[nthold]) = strtoll(s,&s,10); $COMP(whichold[nthold]) = nthreal; nthold++; nthreal++; if(*s != ')') { barf("Sliceoblit must end with ')': '%s': '%s'",str,s); } s++; break; case '*': s++; if(isdigit(*s)) { dumsize = strtoll(s,&s,10); } else {dumsize = 1;} $COMP(corresp[nthnew]) = -1; $COMP(start[nthnew]) = 0; $COMP(end[nthnew]) = dumsize-1; $COMP(inc[nthnew]) = 1; nthnew++; break; } outlab: if(*s != ',' && *s != '\0') { barf("Invalid slice str '%s': '%s'",str,s); } } while(*s); $SETREVERSIBLE(1); /* XXX Only if incs>0, no dummies */ ~, RedoDims => ' int i; PDL_Indx start; PDL_Indx end; PDL_Indx inc; if ($COMP(nthintact) > $PARENT(ndims)) { /* Slice has more dims than parent. Check that the extra dims are * all zero, and if they are then give back What You Probably Wanted, * which is a slice with dummy dimensions of order 1 in place of each excessive * dimension. (Note that there are two ways to indicate a zero index: "0" and "-", * where happens to be the size of that dim in the original * piddle. The latter case still causes an error. That is a feature.) * --CED 15-March-2002 */ int ii,parentdim,ok; int n_xtra_dims=0, n_xtra_olddims=0; /* Check index for each extra dim in the ordinary affine list */ for(ok=1, ii = 0; ok && ii < $COMP(intactnew) ; ii++) { parentdim = $COMP(corresp[ii]); /* fprintf(stderr,"ii=%d,parent=%d, ndum=%d, nnew=%d...",ii,parentdim,$COMP(ndum),$COMP(nnew)); */ if(parentdim >= $PARENT(ndims)) { ok = ( ( $COMP(start[ii]) == 0 ) && ( $COMP(end[ii]) == 0 || $COMP(end[ii])== -1 ) ); if(ok) { /* Change this into a dummy dimension, rank 1 */ $COMP(corresp[ii]) = -1; $COMP(start[ii]) = 0; $COMP(end[ii]) = 0; $COMP(inc[ii]) = 1; $COMP(ndum)++; /* One more dummy dimension... */ $COMP(nnew)--; /* ... one less real dimension */ $COMP(nthintact)--; /* ... one less intact dim */ /* fprintf(stderr,"ok, ndum=%d, nnew=%d\n",$COMP(ndum), $COMP(nnew));*/ } /* fflush(stderr);*/ } } /* Check index for each indexed parent dimension */ for(ii=0; ok && ii < $COMP(nolddims); ii++) { if($COMP(whichold[ii]) >= $PARENT(ndims)) { ok = ( $COMP(whichold[ii]) < $PARENT(ndims) ) || ( $COMP(oldind[ii]) == 0 ) || ( $COMP(oldind[ii]) == -1) ; if(ok) { int ij; /* crunch indexed dimensions -- slow but sure */ $COMP(nolddims)--; for(ij=ii; ij<$COMP(nolddims); ij++) { $COMP(oldind[ij]) = $COMP(oldind[ij+1]); $COMP(whichold[ij]) = $COMP(whichold[ij+1]); } $COMP(nthintact)--; } } } /* fprintf(stderr,"ok=%d\n",ok);fflush(stderr);*/ if(ok) { /* Valid slice: all extra dims are zero. Adjust indices accordingly. */ /* $COMP(intactnew) -= $COMP(nthintact) - $PARENT(ndims); */ /* $COMP(nthintact) = $PARENT(ndims);*/ } else { /* Invalid slice: nonzero extra dimension. Clean up and die. */ $SETNDIMS(0); /* dirty fix */ $PRIV(offs) = 0; $SETDIMS(); $CROAK("Too many dims in slice"); } } $SETNDIMS($PARENT(ndims)-$COMP(nthintact)+$COMP(intactnew)); $DOPRIVDIMS(); $PRIV(offs) = 0; for(i=0; i<$COMP(intactnew); i++) { int parentdim = $COMP(corresp[i]); start = $COMP(start[i]); end = $COMP(end[i]); inc = $COMP(inc[i]); if(parentdim!=-1) { if(-start > $PARENT(dims[parentdim]) || -end > $PARENT(dims[parentdim])) { /* set a state flag to re-trip the RedoDims code later, in * case this barf is caught in an eval. This slice will * always croak, so it may be smarter to find a way to * replace this whole piddle with a "barf" piddle, but this * will work for now. */ PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); barf("Negative slice cannot start or end above limit"); } if(start < 0) start = $PARENT(dims[parentdim]) + start; if(end < 0) end = $PARENT(dims[parentdim]) + end; if(start >= $PARENT(dims[parentdim]) || end >= $PARENT(dims[parentdim])) { /* set a state flag to re-trip the RedoDims code later, in * case this barf is caught in an eval. This slice will * always croak, so it may be smarter to find a way to * replace this whole piddle with a "barf" piddle, but this * will work for now. */ PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); barf("Slice cannot start or end above limit"); } if(sign(end-start)*sign(inc) < 0) inc = -inc; $PRIV(incs[i]) = $PARENT(dimincs[parentdim]) * inc; $PRIV(offs) += start * $PARENT(dimincs[parentdim]); } else { $PRIV(incs[i]) = 0; } $CHILD(dims[i]) = ((PDL_Indx)((end-start)/inc))+1; if ($CHILD(dims[i]) <= 0) barf("slice internal error: computed slice dimension must be positive"); } for(i=$COMP(nthintact); i<$PARENT(ndims); i++) { int cdim = i - $COMP(nthintact) + $COMP(intactnew); $PRIV(incs[cdim]) = $PARENT(dimincs[i]); $CHILD(dims[cdim]) = $PARENT(dims[i]); } for(i=0; i<$COMP(nolddims); i++) { int oi = $COMP(oldind[i]); int wo = $COMP(whichold[i]); if(oi < 0) oi += $PARENT(dims[wo]); if( oi >= $PARENT(dims[wo]) ) $CROAK("Cannot obliterate dimension after end"); $PRIV(offs) += $PARENT(dimincs[wo]) * oi; } /* for(i=0; i<$CHILD(ndims)-$PRIV(nnew); i++) { $CHILD(dims[i+$COMP(intactnew)]) = $PARENT(dims[i+$COMP(nthintact)]); $PRIV(incs[i+$COMP(intactnew)]) = $PARENT(dimincs[i+$COMP(nthintact)]); } */ $SETDIMS(); ', ); pp_addpm(<<'EOD' =head2 using =for ref Returns array of column numbers requested =for usage line $pdl->using(1,2); Plot, as a line, column 1 of C<$pdl> vs. column 2 =for example pdl> $pdl = rcols("file"); pdl> line $pdl->using(1,2); =cut *using = \&PDL::using; sub PDL::using { my ($x,@ind)=@_; @ind = list $ind[0] if (blessed($ind[0]) && $ind[0]->isa('PDL')); foreach (@ind) { $_ = $x->slice("($_)"); } @ind; } EOD ); pp_add_exported('', 'using'); pp_addhdr(<*b) return 1; else if(*a==*b) return 0; else return -1; } END ); pp_def( 'affine', P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, Reversible => 1, AffinePriv => 1, GlobalNew => 'affine_new', OtherPars => 'PDL_Indx offspar; SV *dimlist; SV *inclist;', Comp => 'int nd; PDL_Indx offset; PDL_Indx sdims[$COMP(nd)]; PDL_Indx sincs[$COMP(nd)];', MakeComp => ' int i,n2; PDL_Indx *tmpi; PDL_Indx *tmpd = PDL->packdims(dimlist,&($COMP(nd))); tmpi = PDL->packdims(inclist,&n2); if ($COMP(nd) < 0) { $CROAK("Affine: can not have negative no of dims"); } if ($COMP(nd) != n2) $CROAK("Affine: number of incs does not match dims"); $DOCOMPDIMS(); $COMP(offset) = offspar; for (i=0; i<$COMP(nd); i++) { $COMP(sdims)[i] = tmpd[i]; $COMP(sincs)[i] = tmpi[i]; } ', RedoDims => ' PDL_Indx i; $SETNDIMS($COMP(nd)); $DOPRIVDIMS(); $PRIV(offs) = $COMP(offset); for (i=0;i<$CHILD(ndims);i++) { $PRIV(incs)[i] = $COMP(sincs)[i]; $CHILD(dims)[i] = $COMP(sdims)[i]; } $SETDIMS(); ', Doc => undef, ); =head2 diagonalI =cut pp_def( 'diagonalI', P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, Reversible => 1, AffinePriv => 1, OtherPars => 'SV *list', Comp => 'int nwhichdims; int whichdims[$COMP(nwhichdims)];', MakeComp => ' int i,j; PDL_Indx *tmp= PDL->packdims(list,&($COMP(nwhichdims))); if($COMP(nwhichdims) < 1) { $CROAK("Diagonal: must have at least 1 dimension"); } $DOCOMPDIMS(); for(i=0; i<$COMP(nwhichdims); i++) $COMP(whichdims)[i] = tmp[i]; qsort($COMP(whichdims), $COMP(nwhichdims), sizeof(int), cmp_pdll); ', RedoDims => ' int nthp,nthc,nthd; int cd = $COMP(whichdims[0]); $SETNDIMS($PARENT(ndims)-$COMP(nwhichdims)+1); $DOPRIVDIMS(); $PRIV(offs) = 0; if ($COMP(whichdims)[$COMP(nwhichdims)-1] >= $PARENT(ndims) || $COMP(whichdims)[0] < 0) $CROAK("Diagonal: dim out of range"); nthd=0; nthc=0; for(nthp=0; nthp<$PARENT(ndims); nthp++) if (nthd < $COMP(nwhichdims) && nthp == $COMP(whichdims)[nthd]) { if (!nthd) { $CHILD(dims)[cd] = $PARENT(dims)[cd]; nthc++; $PRIV(incs)[cd] = 0; } if (nthd && $COMP(whichdims)[nthd] == $COMP(whichdims)[nthd-1]) $CROAK("Diagonal: dims must be unique"); nthd++; /* advance pointer into whichdims */ if($CHILD(dims)[cd] != $PARENT(dims)[nthp]) { $CROAK("Different dims %d and %d", $CHILD(dims)[cd], $PARENT(dims)[nthp]); } $PRIV(incs)[cd] += $PARENT(dimincs)[nthp]; } else { $PRIV(incs)[nthc] = $PARENT(dimincs)[nthp]; $CHILD(dims)[nthc] = $PARENT(dims)[nthp]; nthc++; } $SETDIMS(); ', Doc => << 'EOD', =for ref Returns the multidimensional diagonal over the specified dimensions. The diagonal is placed at the first (by number) dimension that is diagonalized. The other diagonalized dimensions are removed. So if C<$a> has dimensions C<(5,3,5,4,6,5)> then after =for example $b = $a->diagonal(0,2,5); the piddle C<$b> has dimensions C<(5,3,4,6)> and C<$b-Eat(2,1,0,1)> refers to C<$a-Eat(2,1,2,0,1,2)>. NOTE: diagonal doesn't handle threadids correctly. XXX FIX =cut EOD ); =head2 lags =cut pp_def( 'lags', Doc => <<'EOD', =for ref Returns a piddle of lags to parent. Usage: =for usage $lags = $a->lags($nthdim,$step,$nlags); I.e. if C<$a> contains [0,1,2,3,4,5,6,7] then =for example $b = $a->lags(0,2,2); is a (5,2) matrix [2,3,4,5,6,7] [0,1,2,3,4,5] This order of returned indices is kept because the function is called "lags" i.e. the nth lag is n steps behind the original. C<$step> and C<$nlags> must be positive. C<$nthdim> can be negative and will then be counted from the last dim backwards in the usual way (-1 = last dim). =cut EOD P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, Reversible => 1, # XXX Not really AffinePriv => 1, OtherPars => 'int nthdim; int step; int n;', RedoDims => ' int i; if ($PRIV(nthdim) < 0) /* the usual conventions */ $PRIV(nthdim) = $PARENT(ndims) + $PRIV(nthdim); if ($PRIV(nthdim) < 0 || $PRIV(nthdim) >= $PARENT(ndims)) $CROAK("lags: dim out of range"); if ($COMP(n) < 1) $CROAK("lags: number of lags must be positive"); if ($COMP(step) < 1) $CROAK("lags: step must be positive"); $PRIV(offs) = 0; $SETNDIMS($PARENT(ndims)+1); $DOPRIVDIMS(); for(i=0; i<$PRIV(nthdim); i++) { $CHILD(dims)[i] = $PARENT(dims)[i]; $PRIV(incs)[i] = $PARENT(dimincs)[i]; } $CHILD(dims)[i] = $PARENT(dims)[i] - $COMP(step) * ($COMP(n)-1); if ($CHILD(dims)[i] < 1) $CROAK("lags: product of step size and " "number of lags too large"); $CHILD(dims)[i+1] = $COMP(n); $PRIV(incs)[i] = ($PARENT(dimincs)[i]); $PRIV(incs)[i+1] = - $PARENT(dimincs)[i] * $COMP(step); $PRIV(offs) += ($CHILD(dims)[i+1] - 1) * (-$PRIV(incs)[i+1]); i++; for(; i<$PARENT(ndims); i++) { $CHILD(dims)[i+1] = $PARENT(dims)[i]; $PRIV(incs)[i+1] = $PARENT(dimincs)[i]; } $SETDIMS(); ' ); =head2 splitdim =cut pp_def( 'splitdim', Doc => <<'EOD', =for ref Splits a dimension in the parent piddle (opposite of L) After =for example $b = $a->splitdim(2,3); the expression $b->at(6,4,x,y,3,6) == $a->at(6,4,x+3*y) is always true (C has to be less than 3). =cut EOD P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, Reversible => 1, # XXX Not really OtherPars => 'int nthdim; int nsp;', AffinePriv => 1, RedoDims => ' int i = $COMP(nthdim); int nsp = $COMP(nsp); if(nsp == 0) {die("Splitdim: Cannot split to 0\n");} if(i <0 || i >= $PARENT(ndims)) { die("Splitdim: nthdim (%d) must not be negative or greater or equal to number of dims (%d)\n", i, $PARENT(ndims)); } if(nsp > $PARENT(dims[i])) { die("Splitdim: nsp (%d) cannot be greater than dim (%"IND_FLAG")\n", nsp, $PARENT(dims[i])); } $PRIV(offs) = 0; $SETNDIMS($PARENT(ndims)+1); $DOPRIVDIMS(); for(i=0; i<$PRIV(nthdim); i++) { $CHILD(dims)[i] = $PARENT(dims)[i]; $PRIV(incs)[i] = $PARENT(dimincs)[i]; } $CHILD(dims)[i] = $COMP(nsp); $CHILD(dims)[i+1] = $PARENT(dims)[i] / $COMP(nsp); $PRIV(incs)[i] = $PARENT(dimincs)[i]; $PRIV(incs)[i+1] = $PARENT(dimincs)[i] * $COMP(nsp); i++; for(; i<$PARENT(ndims); i++) { $CHILD(dims)[i+1] = $PARENT(dims)[i]; $PRIV(incs)[i+1] = $PARENT(dimincs)[i]; } $SETDIMS(); ', ); =head2 rotate =cut pp_def('rotate', Doc => <<'EOD', =for ref Shift vector elements along with wrap. Flows data back&forth. =cut EOD Pars=>'x(n); indx shift(); [oca]y(n)', DefaultFlow => 1, Reversible => 1, Code=>' PDL_Indx i,j; PDL_Indx n_size = $SIZE(n); if (n_size == 0) barf("can not shift zero size piddle (n_size is zero)"); j = ($shift()) % n_size; if (j < 0) j += n_size; for(i=0; ij) = $x(n=>i); }', BackCode=>' PDL_Indx i,j; PDL_Indx n_size = $SIZE(n); j = ($shift()) % n_size; if (j < 0) j += n_size; for(i=0; ii) = $y(n=>j); } ' ); # This is a bit tricky. Hope I haven't missed any cases. =head2 threadI =cut pp_def( 'threadI', Doc => <<'EOD', =for ref internal Put some dimensions to a threadid. =for example $b = $a->threadI(0,1,5); # thread over dims 1,5 in id 1 =cut EOD P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, Reversible => 1, AffinePriv => 1, CallCopy => 0, # Don't CallCopy for subclassed objects because PDL::Copy calls ThreadI # (Wouldn't cause recursive loop otherwise) OtherPars => 'int id; SV *list', Comp => 'int id; int nwhichdims; int whichdims[$COMP(nwhichdims)]; int nrealwhichdims; ', MakeComp => ' int i,j; PDL_Indx *tmp= PDL->packdims(list,&($COMP(nwhichdims))); $DOCOMPDIMS(); for(i=0; i<$COMP(nwhichdims); i++) $COMP(whichdims)[i] = tmp[i]; $COMP(nrealwhichdims) = 0; for(i=0; i<$COMP(nwhichdims); i++) { for(j=i+1; j<$COMP(nwhichdims); j++) if($COMP(whichdims[i]) == $COMP(whichdims[j]) && $COMP(whichdims[i]) != -1) { $CROAK("Thread: duplicate arg %d %d %d", i,j,$COMP(whichdims[i])); } if($COMP(whichdims)[i] != -1) { $COMP(nrealwhichdims) ++; } } $COMP(id) = id; ', RedoDims => ' int nthc,i,j,flag; $SETNDIMS($PARENT(ndims)); $DOPRIVDIMS(); $PRIV(offs) = 0; nthc=0; for(i=0; i<$PARENT(ndims); i++) { flag=0; if($PARENT(nthreadids) > $COMP(id) && $COMP(id) >= 0 && i == $PARENT(threadids[$COMP(id)])) { nthc += $COMP(nwhichdims); } for(j=0; j<$COMP(nwhichdims); j++) { if($COMP(whichdims[j] == i)) {flag=1; break;} } if(flag) { continue; } $CHILD(dims[nthc]) = $PARENT(dims[i]); $PRIV(incs[nthc]) = $PARENT(dimincs[i]); nthc++; } for(i=0; i<$COMP(nwhichdims); i++) { int cdim,pdim; cdim = i + ($PARENT(nthreadids) > $COMP(id) && $COMP(id) >= 0? $PARENT(threadids[$COMP(id)]) : $PARENT(ndims)) - $COMP(nrealwhichdims); pdim = $COMP(whichdims[i]); if(pdim == -1) { $CHILD(dims[cdim]) = 1; $PRIV(incs[cdim]) = 0; } else { $CHILD(dims[cdim]) = $PARENT(dims[pdim]); $PRIV(incs[cdim]) = $PARENT(dimincs[pdim]); } } $SETDIMS(); PDL->reallocthreadids($CHILD_PTR(), ($PARENT(nthreadids)<=$COMP(id) ? $COMP(id)+1 : $PARENT(nthreadids))); for(i=0; i<$CHILD(nthreadids); i++) { $CHILD(threadids[i]) = ($PARENT(nthreadids) > i ? $PARENT(threadids[i]) : $PARENT(ndims)) + (i <= $COMP(id) ? - $COMP(nrealwhichdims) : $COMP(nwhichdims) - $COMP(nrealwhichdims)); } $CHILD(threadids[$CHILD(nthreadids)]) = $CHILD(ndims); ', ); =head2 identvaff =cut # we don't really need this one since it can be achieved with # a ->threadI(-1,[]) pp_def('identvaff', P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, Reversible => 1, AffinePriv => 1, RedoDims => ' int i; $SETNDIMS($PARENT(ndims)); $DOPRIVDIMS(); $PRIV(offs) = 0; for(i=0; i<$PARENT(ndims); i++) { $CHILD(dims[i]) = $PARENT(dims[i]); $PRIV(incs[i]) = $PARENT(dimincs[i]); } $SETDIMS(); $SETDELTATHREADIDS(0); $CHILD(threadids[$CHILD(nthreadids)]) = $CHILD(ndims); ', Doc => <<'EOD', =for ref A vaffine identity transformation (includes thread_id copying). Mainly for internal use. =cut EOD ); =head2 unthread =cut pp_def( 'unthread', Doc => <<'EOD', =for ref All threaded dimensions are made real again. See [TBD Doc] for details and examples. =cut EOD P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, Reversible => 1, AffinePriv => 1, OtherPars => 'int atind;', RedoDims => ' int i; $SETNDIMS($PARENT(ndims)); $DOPRIVDIMS(); $PRIV(offs) = 0; for(i=0; i<$PARENT(ndims); i++) { int corc; if(i<$COMP(atind)) { corc = i; } else if(i < $PARENT(threadids[0])) { corc = i + $PARENT(ndims)-$PARENT(threadids[0]); } else { corc = i - $PARENT(threadids[0]) + $COMP(atind); } $CHILD(dims[corc]) = $PARENT(dims[i]); $PRIV(incs[corc]) = $PARENT(dimincs[i]); } $SETDIMS(); ', ); pp_add_exported('', 'dice dice_axis'); pp_addpm(<<'EOD'); =head2 dice =for ref Dice rows/columns/planes out of a PDL using indexes for each dimension. This function can be used to extract irregular subsets along many dimension of a PDL, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! This method is similar in functionality to the L method, but L requires that contiguous ranges or ranges with constant offset be extracted. ( i.e. L requires ranges of the form C<1,2,3,4,5> or C<2,4,6,8,10>). Because of this restriction, L is more memory efficient and slightly faster than dice =for usage $slice = $data->dice([0,2,6],[2,1,6]); # Dicing a 2-D array The arguments to dice are arrays (or 1D PDLs) for each dimension in the PDL. These arrays are used as indexes to which rows/columns/cubes,etc to dice-out (or extract) from the C<$data> PDL. Use C to select all indices along a given dimension (compare also L). As usual (in slicing methods) trailing dimensions can be omitted implying C'es for those. =for example pdl> $a = sequence(10,4) pdl> p $a [ [ 0 1 2 3 4 5 6 7 8 9] [10 11 12 13 14 15 16 17 18 19] [20 21 22 23 24 25 26 27 28 29] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $a->dice([1,2],[0,3]) # Select columns 1,2 and rows 0,3 [ [ 1 2] [31 32] ] pdl> p $a->dice(X,[0,3]) [ [ 0 1 2 3 4 5 6 7 8 9] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $a->dice([0,2,5]) [ [ 0 2 5] [10 12 15] [20 22 25] [30 32 35] ] As this is an index function, any modifications to the slice change the parent (use the C<.=> operator). =cut sub PDL::dice { my $self = shift; my @dim_indexes = @_; # array of dimension indexes # Check that the number of dim indexes <= # number of dimensions in the PDL my $no_indexes = scalar(@dim_indexes); my $noDims = $self->getndims; barf("PDL::dice: Number of index arrays ($no_indexes) not equal to the dimensions of the PDL ($noDims") if $no_indexes > $noDims; my $index; my $pdlIndex; my $outputPDL=$self; my $indexNo = 0; # Go thru each index array and dice the input PDL: foreach $index(@dim_indexes){ $outputPDL = $outputPDL->dice_axis($indexNo,$index) unless !ref $index && $index eq 'X'; $indexNo++; } return $outputPDL; } *dice = \&PDL::dice; =head2 dice_axis =for ref Dice rows/columns/planes from a single PDL axis (dimension) using index along a specified axis This function can be used to extract irregular subsets along any dimension, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! =for usage $slice = $data->dice_axis($axis,$index); =for example pdl> $a = sequence(10,4) pdl> $idx = pdl(1,2) pdl> p $a->dice_axis(0,$idx) # Select columns [ [ 1 2] [11 12] [21 22] [31 32] ] pdl> $t = $a->dice_axis(1,$idx) # Select rows pdl> $t.=0 pdl> p $a [ [ 0 1 2 3 4 5 6 7 8 9] [ 0 0 0 0 0 0 0 0 0 0] [ 0 0 0 0 0 0 0 0 0 0] [30 31 32 33 34 35 36 37 38 39] ] The trick to using this is that the index selects elements along the dimensions specified, so if you have a 2D image C will select certain C values - i.e. extract columns As this is an index function, any modifications to the slice change the parent. =cut sub PDL::dice_axis { my($self,$axis,$idx) = @_; # Convert to PDLs: array refs using new, otherwise use topdl: my $ix = (ref($idx) eq 'ARRAY') ? ref($self)->new($idx) : ref($self)->topdl($idx); my $n = $self->getndims; my $a = $ix->getndims; barf("index_axis: index must be <=1D") if $a>1; return $self->mv($axis,0)->index1d($ix)->mv(0,$axis); } *dice_axis = \&PDL::dice_axis; EOD pp_addpm(<<'EOD-slice'); =head2 slice =for usage $slice = $data->slice([2,3],'x',[2,2,0],"-1:1:-1", "*3"); =for ref Extract rectangular slices of a piddle, from a string specifier, an array ref specifier, or a combination. C is the main method for extracting regions of PDLs and manipulating their dimensionality. You can call it directly or via he L source prefilter that extends Perl syntax o include array slicing. C can extract regions along each dimension of a source PDL, subsample or reverse those regions, dice each dimension by selecting a list of locations along it, or basic PDL indexing routine. The selected subfield remains connected to the original PDL via dataflow. In most cases this neither allocates more memory nor slows down subsequent operations on either of the two connected PDLs. You pass in a list of arguments. Each term in the list controls the disposition of one axis of the source PDL and/or returned PDL. Each term can be a string-format cut specifier, a list ref that gives the same information without recourse to string manipulation, or a PDL with up to 1 dimension giving indices along that axis that should be selected. If you want to pass in a single string specifier for the entire operation, you can pass in a comma-delimited list as the first argument. C detects this condition and splits the string into a regular argument list. This calling style is fully backwards compatible with C calls from before PDL 2.006. B If a particular argument to C is a string, it is parsed as a selection, an affine slice, or a dummy dimension depending on the form. Leading or trailing whitespace in any part of each specifier is ignored (though it is not ignored within numbers). =over 3 =item C<< '' >>, C<< : >>, or C<< X >> -- keep The empty string, C<:>, or C cause the entire corresponding dimension to be kept unchanged. =item C<< >> -- selection A single number alone causes a single index to be selected from the corresponding dimension. The dimension is kept (and reduced to size 1) in the output. =item C<< () >> -- selection and collapse A single number in parenthesis causes a single index to be selected from the corresponding dimension. The dimension is discarded (completely eliminated) in the output. =item C<< : >> -- select an inclusive range Two numbers separated by a colon selects a range of values from the corresponding axis, e.g. C<< 3:4 >> selects elements 3 and 4 along the corresponding axis, and reduces that axis to size 2 in the output. Both numbers are regularized so that you can address the last element of the axis with an index of C< -1 >. If, after regularization, the two numbers are the same, then exactly one element gets selected (just like the C<< >> case). If, after regulariation, the second number is lower than the first, then the resulting slice counts down rather than up -- e.g. C<-1:0> will return the entire axis, in reversed order. =item C<< :: >> -- select a range with explicit step If you include a third parameter, it is the stride of the extracted range. For example, C<< 0:-1:2 >> will sample every other element across the complete dimension. Specifying a stride of 1 prevents autoreversal -- so to ensure that your slice is *always* forward you can specify, e.g., C<< 2:$n:1 >>. In that case, an "impossible" slice gets an Empty PDL (with 0 elements along the corresponding dimension), so you can generate an Empty PDL with a slice of the form C<< 2:1:1 >>. =item C<< * >> -- insert a dummy dimension Dummy dimensions aren't present in the original source and are "mocked up" to match dimensional slots, by repeating the data in the original PDL some number of times. An asterisk followed by a number produces a dummy dimension in the output, for example C<< *2 >> will generate a dimension of size 2 at the corresponding location in the output dim list. Omitting the numeber (and using just an asterisk) inserts a dummy dimension of size 1. =back B If you feed in an ARRAY ref as a slice term, then it can have 0-3 elements. The first element is the start of the slice along the corresponding dim; the second is the end; and the third is the stepsize. Different combinations of inputs give the same flexibility as the string syntax. =over 3 =item C<< [] >> - keep dim intact An empty ARRAY ref keeps the entire corresponding dim =item C<< [ 'X' ] >> - keep dim intact =item C<< [ '*',$n ] >> - generate a dummy dim of size $n If $n is missing, you get a dummy dim of size 1. =item C<< [ $dex, , 0 ] >> - collapse and discard dim C<$dex> must be a single value. It is used to index the source, and the corresponding dimension is discarded. =item C<< [ $start, $end ] >> - collect inclusive slice In the simple two-number case, you get a slice that runs up or down (as appropriate) to connect $start and $end. =item C<< [ $start, $end, $inc ] >> - collect inclusive slice The three-number case works exactly like the three-number string case above. =back B If you pass in a 0- or 1-D PDL as a slicing argument, the corresponding dimension is "diced" -- you get one position along the corresponding dim, per element of the indexing PDL, e.g. C<< $a->slice( pdl(3,4,9)) >> gives you elements 3, 4, and 9 along the 0 dim of C<< $a >>. Because dicing is not an affine transformation, it is slower than direct slicing even though the syntax is convenient. =for example $a->slice('1:3'); # return the second to fourth elements of $a $a->slice('3:1'); # reverse the above $a->slice('-2:1'); # return last-but-one to second elements of $a $a->slice([1,3]); # Same as above three calls, but using array ref syntax $a->slice([3,1]); $a->slice([-2,1]); =cut ############################## # 'slice' is now implemented as a small Perl wrapper around # a PP call. This permits unification of the former slice, # dice, and nslice into a single call. At the moment, dicing # is implemented a bit kludgily (it is detected in the Perl # front-end), but it is serviceable. # --CED 12-Sep-2013 *slice = \&PDL::slice; sub PDL::slice (;@) { my ($source, @others) = @_; # Deal with dicing. This is lame and slow compared to the # faster slicing, but works okay. We loop over each argument, # and if it's a PDL we dispatch it in the most straightforward # way. Single-element and zero-element PDLs are trivial and get # converted into slices for faster handling later. for my $i(0..$#others) { if( blessed($others[$i]) && $others[$i]->isa('PDL') ) { my $idx = $others[$i]; if($idx->ndims > 1) { barf("slice: dicing parameters must be at most 1D (arg $i)\n"); } my $nlm = $idx->nelem; if($nlm > 1) { #### More than one element - we have to dice (darn it). my $n = $source->getndims; $source = $source->mv($i,0)->index1d($idx)->mv(0,$i); $others[$i] = ''; } elsif($nlm) { #### One element - convert to a regular slice. $others[$i] = $idx->flat->at(0); } else { #### Zero elements -- force an extended empty. $others[$i] = "1:0:1"; } } } PDL::sliceb($source,\@others); } EOD-slice pp_add_exported('', 'slice'); ########## # This is a kludge to pull arbitrary data out of a single-element PDL, using the Types.pm stuff, # to make it easier to slice using single-element PDL arguments inside a slice specifier. # The string $sliceb_data_kludge generates some code that physicalizes a PDL, ensures it has # only one element, and extracts that element in a type-independent manner. It's a pain because # we have to generate the switch statement using information in the Config typehash. But it saves # time compared to parsing out any passed-in PDLs on the Perl side. # use PDL::Types; $sliceb_data_kludge = <<'KLUDGE'; { pdl *p = PDL->SvPDLV( *svp ); int i; PDL->make_physical(p); if(p->nvals==0) barf("slice: empty PDL in slice specifier"); if(p->nvals > 1) barf("slice: multi-element PDL in slice specifier"); if( !(p->data) ) { barf("slice: no data in slice specifier PDL! I give up."); } switch( p->datatype ) { KLUDGE for my $type( PDL::Types::typesrtkeys()) { $sliceb_data_kludge .= " case $type: nn = *( ($PDL::Types::typehash{$type}->{realctype} *)(p->data) ); break;\n"; } $sliceb_data_kludge .= <<'KLUDGE'; default: barf("Unknown PDL type in slice specifier! This should never happen."); break; } } KLUDGE ############################## # sliceb is the core of slice. The "foo/foob" nomenclature is used to avoid the argument # counting inherent in a direct Code section call -- "slice" is a front-end that just rolls up a # whole variable-length argument list into a single AV reference. # # I'm also too lazy to figure out how to make a PMCode section work right on a dataflow PP operator. # -- CED pp_def( 'sliceb', P2Child => 1, NoPdlThread => 1, DefaultFlow => 1, OtherPars => 'SV *args;', # # Comp stash definitions: # nargs - number of args in original call # odim[] - maps argno to output dim (or -1 for squished dims) # idim[] - maps argno to input dim (or -1 for squished dims) # odim_top - one more than the highest odim encountered # idim_top - one more than the highest idim encountered # start[] - maps argno to start index of slice range (inclusive) # inc[] - maps argno to increment of slice range # end[] - maps argno to end index of slice range (inclusive) # Comp => 'int nargs; int odim[$COMP(nargs)]; int idim[$COMP(nargs)]; int idim_top; int odim_top; PDL_Indx start[$COMP(nargs)]; PDL_Indx inc[$COMP(nargs)]; PDL_Indx end[$COMP(nargs)]; ', AffinePriv => 1, MakeComp => <<'SLICE-MC' int i; int idim; int odim; int imax; int nargs; AV *arglist; /*** Make sure we got an array ref as input and extract its corresponding AV ***/ if(!( args && SvROK(args) && SvTYPE(SvRV(args))==SVt_PVAV )){ barf("slice requires an ARRAY ref containing zero or more arguments"); } arglist = (AV *)(SvRV(args)); /* Detect special case of a single comma-delimited string; in that case, */ /* split out our own arglist. */ if( (av_len(arglist) == 0) ) { /*** single-element list: pull first element ***/ SV **svp; svp = av_fetch(arglist, 0, 0); if(svp && *svp && *svp != &PL_sv_undef && SvPOKp(*svp)) { /*** The element exists and is not undef and has a cached string value ***/ char *s,*ss; s = ss = SvPVbyte_nolen(*svp); for(; *ss && *ss != ','; ss++) {} if(*ss == ',') { char *s1; /* the string contains at least one comma. ATTACK! */ /* We make a temporary array and populate it with */ /* SVs containing substrings -- basically split(/\,/)... */ AV *al = (AV *)sv_2mortal((SV *)(newAV())); do { for(s1=s; *s1 && *s1 != ','; s1++); av_push(al, newSVpvn(s, s1-s)); if(*s1==',') s = ++s1; else s = s1; } while(*s); arglist = al; /* al is ephemeral and will evaporate at the next perl gc */ } /* end of contains-comma case */ } /* end of nontrivial single-element detection */ }/* end of single-element detection */ nargs = $COMP(nargs) = av_len( arglist ) + 1; $DOCOMPDIMS(); /**********************************************************************/ /**** Loop over the elements of the AV input and parse into values ****/ /**** in the start/inc/end array ****/ for(odim=idim=i=0; i 3) barf("slice: array refs can have at most 3 elements!"); if(nelem==0) { /* No elements - keep it all */ all_flag = 1; } else /* Got at least one element */{ /* Load the first into n0 and check for dummy or all-clear */ /* (if element is missing use the default value already in n0) */ svp = av_fetch(sublist, 0, 0); if(svp && *svp && *svp != &PL_sv_undef) { /* There is a first element. Check if it's a PDL, then a string, then an IV */ if(SvROK(*svp) && sv_isa(*svp, "PDL")) { PDL_Indx nn; SLICE-MC . $sliceb_data_kludge # Quick and dirty single-element parser (from above) . <<'SLICE-MC' n0 = nn; } else if( SvPOKp(*svp)) { /* Not a PDL but has associated string */ char *str = SvPVbyte_nolen(*svp); switch(*str) { case 'X': all_flag = 1; break; case '*': dummy_flag = 1; n0 = 1; /* n0 is 1 so 2nd field is element count */ n1 = 1; /* size defaults to 1 for dummy dims */ n2 = 1; /* n2 is forced to 1 so ['*',0] gives an empty */ break; default: /* Doesn't start with '*' or 'X' */ n0 = SvIV(*svp); n1 = n0; /* n1 defaults to n0 if n0 is present */ break; } } else /* the element has no associated string - just parse */ { n0 = SvIV(*svp); n1 = n0; /* n1 defaults to n0 if n0 is present */ } } /* end of defined check. if it's undef, leave the n's at their default value. */ /* Read the second element into n1 and check for alternate squish syntax */ if( (nelem > 1) && (!all_flag) ) { svp = av_fetch(sublist, 1, 0); if( svp && *svp && *svp != &PL_sv_undef ) { if( SvROK(*svp) && sv_isa(*svp, "PDL")) { PDL_Indx nn; SLICE-MC . $sliceb_data_kludge . <<'SLICE-MC' n1 = nn; } else if( SvPOKp(*svp) ) { /* Second element has a string - make sure it's not 'X'. */ char *str = SvPVbyte_nolen(*svp); if(*str == 'X') { squish_flag = 1; n1 = n0; } else { n1 = SvIV(*svp); } } else { /* Not a PDL, no string -- just get the IV */ n1 = SvIV(*svp); } } /* If not defined, leave at the default */ } /* End of second-element check */ /*** Now try to read the third element (inc). ***/ if( (nelem > 2) && !(all_flag) && !(squish_flag) && !(dummy_flag) ) { svp = av_fetch(sublist, 2, 0); if( svp && *svp && *svp != &PL_sv_undef ) { if(SvROK(*svp) && sv_isa(*svp, "PDL")) { PDL_Indx nn; SLICE-MC . $sliceb_data_kludge . << 'SLICE-MC' n2 = nn; } else { STRLEN len; SvPV( *svp, len ); if(len>0) { /* nonzero length -> actual value given */ n2 = SvIV(*svp); /* if the step is passed in as 0, it is a squish */ if(n2==0) { n1 = n0; squish_flag = 1; } } } } /* end of nontrivial third-element parsing */ } /* end of third-element parsing */ } /* end of nontrivial sublist parsing */ } else /* this argument is not an ARRAY ref - parse as a scalar */ { /****************************************************************/ /*** String handling part of slice is here. Parse out each ***/ /*** term: ***/ /*** (or NV) - extract one element from this dim ***/ /*** : - extract to ; autoreverse if nec. ***/ /*** :: - extract to , stepping by ***/ /*** () - extract element and discard this dim ***/ /*** * - insert a dummy dimension of size ***/ /*** : - keep this dim in its entirety ***/ /*** X - keep this dim in its entirety ***/ /****************************************************************/ if(SvPOKp(this)) { /* this argument has a cached string */ char *s; STRLEN len; int subargno = 0; int flagged = 0; int squish_closed = 0; char buf[161]; char ii; s = SvPVbyte(this, len); /* Very stoopid parsing - should probably make some calls to perl string utilities... */ while(*s) { if( isspace( *s ) ) { s++; /* ignore and loop again */ } else { /* not whitespace */ switch(*(s++)) { case '*': if(flagged || subargno) barf("slice: Erroneous '*' (arg %d)",i); dummy_flag = flagged = 1; n0 = 1; /* default this number to 1 (size 1); '*0' yields an empty */ n1 = 1; /* no second arg allowed - default to 1 so n0 is element count */ n2 = -1; /* -1 so we count down to n1 from n0 */ break; case '(': if(flagged || subargno) barf("slice: Erroneous '(' (arg %d)",i); squish_flag = flagged = 1; break; case 'X': case 'x': if(flagged || subargno > 1) barf("slice: Erroneous 'X' (arg %d)",i); if(subargno==0) { all_flag = flagged = 1; } else /* subargno is 1 - squish */ { squish_flag = squish_closed = flagged = 1; } break; case '+': case '-': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': switch(subargno) { case 0: /* first arg - change default to 1 element */ n0 = strtoll(--s, &s, 10); n1 = n0; if(dummy_flag) { n0 = 1; } break; case 1: /* second arg - parse and keep end */ n1 = strtoll(--s, &s, 10); break; case 2: /* third arg - parse and keep inc */ if( squish_flag || dummy_flag ) { barf("slice: erroneous third field in slice specifier (arg %d)",i); } n2 = strtoll(--s, &s, 10); break; default: /* oops */ barf("slice: too many subargs in scalar slice specifier %d",i); break; } break; case ')': if( squish_closed || !squish_flag || subargno > 0) { barf("nslice: erroneous ')' (arg %d)",i); } squish_closed = 1; break; case ':': if(squish_flag && !squish_closed) { barf("slice: must close squishing parens (arg %d)",i); } if( subargno == 0 ) { n1 = -1; /* Set ":" default to get the rest of the range */ } if( subargno > 1 ) { barf("slice: too many ':'s in scalar slice specifier %d",i); } subargno++; break; case ',': barf("slice: ',' not allowed (yet) in scalar slice specifiers!"); break; default: barf("slice: unexpected '%c' in slice specifier (arg %d)",*s,i); break; } } /* end of conditional in parse loop */ } /* end of parse loop */ } else /* end of string parsing */ { /* Simplest case -- there's no cached string, so it */ /* must be a number. In that case it's a simple */ /* extraction. Treated as a separate case for speed. */ n0 = SvNV(this); n1 = SvNV(this); n2 = 0; } } /* end of scalar handling */ } /* end of defined-element handling (!all_flag) */ if( (!all_flag) + (!squish_flag) + (!dummy_flag) < 2 ) { barf("Looks like you triggered a bug in slice. two flags set in dim %d",i); } /* Force all_flag case to be a "normal" slice */ if(all_flag) { n0 = 0; n1 = -1; n2 = 1; } /* Copy parsed values into the limits */ $COMP(start[i]) = n0; $COMP(end[i]) = n1; $COMP(inc[i]) = n2; /* Deal with dimensions */ if(squish_flag) { $COMP(odim[i]) = -1; } else { $COMP(odim[i]) = odim++; } if(dummy_flag) { $COMP(idim[i]) = -1; } else { $COMP(idim[i]) = idim++; } } /* end of arg-parsing loop */ $COMP(idim_top) = idim; $COMP(odim_top) = odim; $SETREVERSIBLE(1); /*** End of MakeComp for slice */ /****************************************/ SLICE-MC , RedoDims => q{ int o_ndims_extra = 0; PDL_Indx i; PDL_Indx PDIMS; if( $COMP(idim_top) < $PARENT(ndims) ) { o_ndims_extra = $PARENT(ndims) - $COMP(idim_top); } /* slurped dims from the arg parsing, plus any extra thread dims */ $SETNDIMS( $COMP(odim_top) + o_ndims_extra ); $DOPRIVDIMS(); $PRIV(offs) = 0; /* Offset vector to start of slice */ for(i=0; i<$COMP(nargs); i++) { PDL_Indx start, end; /** Belt-and-suspenders **/ if( ($COMP(idim[i]) < 0) && ($COMP(odim[i]) < 0) ) { PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); barf("slice: Hmmm, both dummy and squished -- this can never happen. I quit."); } /** First handle dummy dims since there's no input from the parent **/ if( $COMP(idim[i]) < 0 ) { /* dummy dim - offset or diminc. */ $CHILD( dims[ $COMP(odim[i]) ] ) = $COMP(end[i]) - $COMP(start[i]) + 1; $PRIV( incs[ $COMP(odim[i]) ] ) = 0; } else { PDL_Indx pdsize; /** This is not a dummy dim -- deal with a regular slice along it. **/ /** Get parent dim size for this idim, and/or allow permissive slicing **/ if( $COMP(idim[i]) < $PARENT(ndims)) { pdsize = $PARENT( dims[$COMP(idim[i])] ); } else { pdsize = 1; } start = $COMP(start[i]); end = $COMP(end[i]); if( pdsize==0 && start==0 && end==-1 && $COMP(inc[i])==0 ) { /** Trap special case: full slices of an empty dim are empty **/ $CHILD( dims[ $COMP(odim[i]) ] ) = 0; $PRIV( incs[$COMP(odim[i]) ] ) = 0; } else { /** Regularize and bounds-check the start location **/ if(start < 0) start += pdsize; if( start < 0 || start >= pdsize ) { PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); if(i >= $PARENT( ndims )) { barf("slice: slice has too many dims (indexes dim %d; highest is %d)",i,$PARENT( ndims )-1); } else { barf("slice: slice starts out of bounds in pos %d (start is %d; source dim %d runs 0 to %d)",i,start,$COMP(idim[i]),pdsize-1); } } if( $COMP(odim[i]) < 0) { /* squished dim - just update the offset. */ /* start is always defined and regularized if we are here here, since */ /* both idim[i] and odim[i] can't be <0 */ $PRIV(offs) += start * $PARENT( dimincs[ $COMP(idim[i]) ] ); } else /* normal operation */ { PDL_Indx siz; PDL_Indx inc; /** Regularize and bounds-check the end location **/ if(end<0) end += pdsize; if( end < 0 || end >= pdsize ) { PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); barf("slice: slice ends out of bounds in pos %d (end is %d; source dim %d runs 0 to %d)",i,end,$COMP(idim[i]),pdsize-1); } /* regularize inc */ inc = $COMP(inc[i]); if(!inc) inc = (start <= end) ? 1 : -1; siz = (end - start + inc) / inc ; if(siz<0) siz=0; $CHILD( dims[ $COMP(odim[i]) ] ) = siz; $PRIV( incs[ $COMP(odim[i]) ] ) = $PARENT( dimincs[ $COMP(idim[i]) ] ) * inc; $PRIV(offs) += start * $PARENT( dimincs[ $COMP(idim[i]) ] ); } /* end of normal slice case */ } /* end of trapped strange slice case */ } /* end of non-dummy slice case */ } /* end of nargs loop */ /* Now fill in thread dimensions as needed. idim and odim persist from the parsing loop */ /* up above. */ for(i=0; i 'Bot'},<< 'EOD'); =head1 BUGS For the moment, you can't slice one of the zero-length dims of an empty piddle. It is not clear how to implement this in a way that makes sense. Many types of index errors are reported far from the indexing operation that caused them. This is caused by the underlying architecture: slice() sets up a mapping between variables, but that mapping isn't tested for correctness until it is used (potentially much later). =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Contributions by Craig DeForest, deforest@boulder.swri.edu. Documentation contributions by David Mertens. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.018/Basic/SourceFilter/0000755060175006010010000000000013110402046014012 5ustar chmNonePDL-2.018/Basic/SourceFilter/Changes0000644060175006010010000000213212562522364015323 0ustar chmNone1.0.0 - fix parsing foreach: detect embedded niceslice expressions 0.99.2 - changed to 2 dot version number - fix parsing problems with interspersed whitespace and comments 0.991 - don't translate method invocation via string, e.g. $a->$method(0) - require PDL in Makefile.PL 0.99 - allow more than one modifier - fix modifier parsing 0.97 - nslice updates (indexing with multidim piddles) yet undocumented I think 0.96 - splitprotected interface similar to split's 0.95 - squeeze modifier (;-) 0.91 - leave 'for(each)? (my|our) $y(0,1) {}' alone 0.9 - source filters clobber the DATA file handle unless they are disabled upon encountering __DATA__|__END__ ! Fixed NiceSlice to avoid that. (now uses Filter::Util::Call directly) - doc updates - doc updates 0.8 - CED: leave 'for(each)? $x(...) {}' alone - fix error bug (reported by Doug Burke) - docs clarification 0.7 - fixed a bug that sometimes screwed up error reporting - modifiers: _,?,| 0.6 - doc updates - declare nslice lvalue sub if perl version >= 5.6.0 - KGB: fix multiline parsing 0.5 - initial public release PDL-2.018/Basic/SourceFilter/example0000644060175006010010000000171112562522364015410 0ustar chmNoneuse PDL::LiteF; use PDL::NiceSlice; $a = sequence(10); print "\n",'source $a'.'((4)) translated -> $a((4))',"\n"; print "Result ",$a((4)),"\n\n"; print 'alternative syntax: $a->'.'((4)) translated -> $a->((4))',"\n\n"; print 'source $a'.'(1:4) .= 2; translated -> $a(1:4) .= 2;',"\n"; # this should be rewritten ($tmp = $a(1:4)) .= 2; print "Result: $a","\n\n"; print << 'EOP'; The arglist is split at commas but commas within matched brackets are protected. That should allow function invocations etc within the arglist: EOP print '$a'.'(1:end(0,22)) -> $a(1:end(0,22))',"\n\n"; print "recursive invocation is also supported:\n"; print '$a'.'(1,$b'.'(0:22)) -> $a(1,$b(0:22))',"\n\n"; no PDL::NiceSlice; print << 'EOP'; Now we have switched off source filtering by issuing no PDL::NiceSlice; Therefore, the next slice expression should not be touched: EOP # this shouldn't be touched print 'Source $a'.'(1:4) translation -> $a(1:4)',"\n\n"; PDL-2.018/Basic/SourceFilter/FilterSimple.pm0000644060175006010010000000075512562522364016776 0ustar chmNone# This is the new Filter::Simple engine for PDL::NiceSlice # use Filter::Simple; FILTER_ONLY all => sub { s/\r\n/\n/g if $^V lt v5.14.0 and $^O eq 'MSWin32'; }, code_no_comments => sub { my ($text1,$text2) = ($_,''); ## print STDERR "**************** Input: \n$text1\n"; $text2 = perldlpp('PDL::NiceSlice', $text1); ## print STDERR "**************** Output: $text2\n"; $_ = $text2; }, all => sub { print if $PDL::NiceSlice::debug_filter }; 1; PDL-2.018/Basic/SourceFilter/FilterUtilCall.pm0000644060175006010010000000217612562522364017255 0ustar chmNone# This original Filter::Util::Call-based # PDL::NiceSlice engine. # use Filter::Util::Call; ############################## # If you mess with the import filter, please also change the pdlpp importer # just above this comment! They both do similar things, but one to an eval string # and one to an import file. # --CED 5-Nov-2007 # sub import { my ($class) = @_; ($file,$offset) = (caller)[1,2]; # for error reporting $offset++; ## Parse class name into a regexp suitable for filtration my $terminator = terminator_regexp($class); filter_add( sub { my ($status, $off, $end); my $count = 0; my $data = ""; while ($status = filter_read()) { return $status if $status < 0; if (defined($terminator) && m/$terminator/) { $off=1; last; } if (m/^\s*(__END__|__DATA__)\s*$/) { $end=$1; $off = 1; last; } $data .= $_; $count++; $_ = ""; } $_ = $data; $_ = findslice $_ unless $status < 0; # the actual filter $_ .= "no $class;\n" if $off; $_ .= "$end\n" if $end; return $count; } ); } sub unimport { filter_del(); } 1; PDL-2.018/Basic/SourceFilter/local.perldlrc0000644060175006010010000000140712562522364016657 0ustar chmNone# some useful functions to experiment with # the new PDL source filter within the perldl shell # report switches translation reporting on/off # trans and notrans switch source filtering on/off # include the perl code below in your standard # perldl startup file ($ENV{HOME}/.perldlrc) # to have it always available when working # in the perldl shell $PERLDL::report = 0; sub report { my $ret = $PERLDL::report; $PERLDL::report = $_[0] if $#_ > -1; return $ret; } use PDL::NiceSlice; my $preproc = sub { my ($txt) = @_; my $new = PDL::NiceSlice::perldlpp $txt; print STDERR "processed $new\n" if report && $new ne $txt; return $new; }; sub trans { $PERLDL::PREPROCESS = $preproc } sub notrans { $PERLDL::PREPROCESS = undef } trans; # switch on by default 1; PDL-2.018/Basic/SourceFilter/Makefile.PL0000644060175006010010000000127512562522364016011 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; undef &MY::postamble; # suppress warning *MY::postamble = sub { " README: README.head NiceSlice.pm \tcp README.head README \tpod2text NiceSlice.pm >> README "; }; WriteMakefile( NAME => 'PDL::NiceSlice', VERSION_FROM => 'NiceSlice.pm', PM => { 'NiceSlice.pm' => '$(INST_LIBDIR)/NiceSlice.pm', 'FilterUtilCall.pm' => '$(INST_LIBDIR)/NiceSlice/FilterUtilCall.pm', 'FilterSimple.pm' => '$(INST_LIBDIR)/NiceSlice/FilterSimple.pm', 'ModuleCompile.pm' => '$(INST_LIBDIR)/NiceSlice/ModuleCompile.pm', }, PREREQ_PM => { 'Filter::Util::Call' => 0, 'Text::Balanced' => 0, 'PDL' => 2.003000, }, ); PDL-2.018/Basic/SourceFilter/ModuleCompile.pm0000644060175006010010000000036212562522364017127 0ustar chmNone## package Foo; use Module::Compile -base; sub pmc_compile { my ($class, $source) = @_; # Convert $source into (most likely Perl 5) $compiled_output my $filtered = perldlpp('PDL::NiceSlice', $source); return $filtered; } 1; PDL-2.018/Basic/SourceFilter/NiceSlice.pm0000644060175006010010000010422713036512174016227 0ustar chmNoneBEGIN { my %engine_ok = ( 'Filter::Util::Call' => 'PDL/NiceSlice/FilterUtilCall.pm', 'Filter::Simple' => 'PDL/NiceSlice/FilterSimple.pm', 'Module::Compile' => 'PDL/NiceSlice/ModuleCompile.pm', ); # to validate names ## $PDL::NiceSlice::engine = $engine_ok{'Filter::Simple'}; # default engine type ## TODO: Add configuration argument to perldl.conf $PDL::NiceSlice::engine = $engine_ok{'Filter::Util::Call'}; # default engine type if ( exists $ENV{PDL_NICESLICE_ENGINE} ) { my $engine = $ENV{PDL_NICESLICE_ENGINE}; if ( exists $engine_ok{$engine} and $engine_ok{$engine} ) { $PDL::NiceSlice::engine = $engine_ok{$engine}; warn "PDL::NiceSlice using engine '$engine'\n" if $PDL::verbose; } elsif ( exists $engine_ok{$engine} and not $engine_ok{$engine} ) { warn "PDL::NiceSlice using default engine\n" if $PDL::verbose; } else { die "PDL::NiceSlice: PDL_NICESLICE_ENGINE set to invalid engine '$engine'\n"; } } } no warnings; package PDL::NiceSlice; our $VERSION = '1.001'; $VERSION = eval $VERSION; $PDL::NiceSlice::debug = defined($PDL::NiceSlice::debug) ? $PDL::NiceSlice::debug : 0; # replace all occurences of the form # # $pdl(args); # or # $pdl->(args); # with # # $pdl->slice(processed_args); # # # Modified 2-Oct-2001: don't modify $var(LIST) if it's part of a # "for $var(LIST)" or "foreach $var(LIST)" statement. CED. # # Modified 5-Nov-2007: stop processing if we encounter m/^no\s+PDL\;:\;:NiceSlice\;\s*$/. # the next one is largely stolen from Regexp::Common my $RE_cmt = qr'(?:(?:\#)(?:[^\n]*)(?:\n))'; require PDL::Version; # get PDL version number # # remove code for PDL versions earlier than 2.3 # use Text::Balanced; # used to find parenthesis-delimited blocks # Try overriding the current extract_quotelike() routine # needed before using Filter::Simple to work around a bug # between Text::Balanced and Filter::Simple for our purpose. # BEGIN { no warnings; # quiet warnings for this sub Text::Balanced::extract_quotelike (;$$) { my $textref = $_[0] ? \$_[0] : \$_; my $wantarray = wantarray; my $pre = defined $_[1] ? $_[1] : '\s*'; my @match = Text::Balanced::_match_quotelike($textref,$pre,0,0); # do not match // alone as m// return Text::Balanced::_fail($wantarray, $textref) unless @match; return Text::Balanced::_succeed($wantarray, $textref, $match[2], $match[18]-$match[2], # MATCH @match[18,19], # REMAINDER @match[0,1], # PREFIX @match[2..17], # THE BITS @match[20,21], # ANY FILLET? ); }; }; # a call stack for error processing my @callstack = ('stackbottom'); sub curarg { my $arg = $callstack[-1]; # return top element of stack $arg =~ s/\((.*)\)/$1/s; return $arg; } sub savearg ($) {push @callstack,$_[0]} sub poparg () {pop @callstack} my @srcstr = (); # stack for refs to current source strings my $offset = 1; # line offset my $file = 'unknown'; my $mypostfix = ''; sub autosever { my ($this,$arg) = @_; $arg = 1 unless defined $arg; if ($arg) {$mypostfix = '->sever'} else {$mypostfix = ''} } sub line { die __PACKAGE__." internal error: can't determine line number" if $#srcstr < 0; my $pretext = substr ${$srcstr[0]}, 0, pos(${$srcstr[0]})-1; return ($pretext =~ tr/\n/\n/)+$offset; } sub filterdie { my ($msg) = @_; die "$msg\n\t at $file near line ". line().", slice expression '".curarg()."'\n"; } # non-bracketed prefix matching regexp my $prebrackreg = qr/^([^\(\{\[]*)/; # split regex $re separated arglist # but ignore bracket-protected bits # (i.e. text that is within matched brackets) sub splitprotected ($$) { my ($re,$txt) = @_; my ($got,$pre) = (1,''); my @chunks = (''); my $ct = 0; # infinite loop protection while ($got && $txt =~ /[({\[]/ && $ct++ < 1000) { # print "iteration $ct\n"; ($got,$txt,$pre) = Text::Balanced::extract_bracketed($txt,'{}()[]',$prebrackreg); my @partialargs = split $re, $pre, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs; $chunks[-1] .= $got; } filterdie "possible infinite parse loop, slice arg '".curarg()."'" if $ct == 1000; my @partialargs = split $re, $txt, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs; return @chunks; } # a pattern that finds occurences of the form # # $var( # # and # # ->( # # used as the prefix pattern for findslice my $prefixpat = qr/.*? # arbitrary leading stuff ((?) # or just '->' (\s|$RE_cmt)* # ignore comments \s* # more whitespace (?=\()/smx; # directly followed by open '(' (look ahead) # translates a single arg into corresponding slice format sub onearg ($) { my ($arg) = @_; print STDERR "processing arg '$arg'\n" if $PDL::NiceSlice::debug; return q|'X'| if $arg =~ /^\s*:??\s*$/; # empty arg or just colon # recursively process args for slice syntax $arg = findslice($arg,$PDL::debug) if $arg =~ $prefixpat; # no doubles colon are matched to avoid confusion with Perl's C<::> if ($arg =~ /(? 3; $args[0] = 0 if !defined $args[0] || $args[0] =~ /^\s*$/; $args[1] = -1 if !defined $args[1] || $args[1] =~ /^\s*$/; $args[2] = undef if !defined $args[2] || $args[2] =~ /^\s*$/; return "[".join(',',@args)."]"; # replace single ':' with ',' } # the (pos) syntax, i.e. 0D slice return "[$arg,0,0]" if $arg =~ s/^\s*\((.*)\)\s*$/$1/; # use the new [x,x,0] # we don't allow [] syntax (although that's what slice uses) filterdie "invalid slice expression containing '[', expression was '". curarg()."'" if $arg =~ /^\s*\[/; # If the arg starts with '*' it's a dummy call -- force stringification # and prepend a '*' for handling by slice. return "(q(*).($arg))" if($arg =~ s/^\s*\*//); # this must be a simple position, leave as is return "$arg"; } # process the arg list sub procargs { my ($txt) = @_; print STDERR "procargs: got '$txt'\n" if $PDL::NiceSlice::debug; # $txt =~ s/^\s*\((.*)\)\s*$/$1/s; # this is now done by findslice # push @callstack, $txt; # for later error reporting my $args = $txt =~ /^\s*$/s ? '' : join ',', map {onearg $_} splitprotected ',', $txt; ## Leave whitespace/newlines in so line count ## is preserved in error messages. Makes the ## filtered output ugly---iffi the input was ## ugly... ## ## $args =~ s/\s//sg; # get rid of whitespace # pop @callstack; # remove from call stack print STDERR "procargs: returned '($args)'\n" if $PDL::NiceSlice::debug; return "($args)"; } # this is the real workhorse that translates occurences # of $a(args) into $args->slice(processed_arglist) # sub findslice { my ($src,$verb) = @_; push @srcstr, \$src; $verb = 0 unless defined $verb; my $processed = ''; my $ct=0; # protect against infinite loop my ($found,$prefix,$dummy); while ( $src =~ m/\G($prefixpat)/ && (($found,$dummy,$prefix) = Text::Balanced::extract_bracketed($src,'()',$prefixpat))[0] && $ct++ < 1000) { print STDERR "pass $ct: found slice expr $found at line ".line()."\n" if $verb; # Do final check for "for $var(LIST)" and "foreach $var(LIST)" syntax. # Process into an 'slice' call only if it's not that. if ($prefix =~ m/for(each)?(\s+(my|our))?\s+\$\w+(\s|$RE_cmt)*$/s || # foreach statement: Don't translate $prefix =~ m/->\s*\$\w+$/s) # e.g. $a->$method(args) # method invocation via string, don't translate either { # note: even though we reject this one we need to call # findslice on $found in case # it contains slice expressions $processed .= "$prefix".findslice($found); } else { # statement is a real slice and not a foreach my ($call,$pre,$post,$arg); # the following section got an overhaul in v0.99 # to fix modifier parsing and allow >1 modifier # this code still needs polishing savearg $found; # error reporting print STDERR "findslice: found '$found'\n" if $PDL::NiceSlice::debug; $found =~ s/^\s*\((.*)\)\s*$/$1/s; my ($slicearg,@mods) = splitprotected ';', $found; filterdie "more than 1 modifier group: @mods" if @mods > 1; # filterdie "invalid modifier $1" # if $found =~ /(;\s*[[:graph:]]{2,}?\s*)\)$/; print STDERR "MODS: " . join(',',@mods) . "\n" if $PDL::NiceSlice::debug; my @post = (); # collects all post slice operations my @pre = (); if (@mods) { (my $mod = $mods[0]) =~ s/\s//sg; # eliminate whitespace my @modflags = split '', $mod; print STDERR "MODFLAGS: @modflags\n" if $PDL::NiceSlice::debug; filterdie "more than 1 modifier incompatible with ?: @modflags" if @modflags > 1 && grep (/\?/, @modflags); # only one flag with where my %seen = (); if (@modflags) { for my $mod1 (@modflags) { if ($mod1 eq '?') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; $call = 'where'; $arg = "(" . findslice($slicearg) . ")"; # $post = ''; # no post action required } elsif ($mod1 eq '_') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; push @pre, 'flat->'; $call ||= 'slice'; # do only once $arg = procargs($slicearg); # $post = ''; # no post action required } elsif ($mod1 eq '|') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; $call ||= 'slice'; $arg ||= procargs($slicearg); push @post, '->sever'; } elsif ($mod1 eq '-') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; $call ||= 'slice'; $arg ||= procargs($slicearg); push @post, '->reshape(-1)'; } else { filterdie "unknown modifier $mod1"; } } } else { # empty modifier block $call = 'slice'; $arg = procargs($slicearg); # $post = ''; } } else { # no modifier block $call = 'slice'; $arg = procargs($slicearg); # $post = ''; # $call = 'slice_if_pdl'; # handle runtime checks for $self type # $arg =~ s/\)$/,q{$found})/; # add original argument string # in case $self is not a piddle # and the original call must be # generated } $pre = join '', @pre; # assumption here: sever should be last # and order of other modifiers doesn't matter $post = join '', sort @post; # need to ensure that sever is last $processed .= "$prefix". ($prefix =~ /->(\s*$RE_cmt*)*$/ ? '' : '->'). $pre.$call.$arg.$post.$mypostfix; } } # end of while loop poparg; # clean stack pop @srcstr; # clear stack # append the remaining text portion # use substr only if we have had at least one pass # through above loop (otherwise pos is uninitialized) $processed .= $ct > 0 ? substr $src, pos($src) : $src; } ############################## # termstr - generate a regexp to find turn-me-off strings # CED 5-Nov-2007 sub terminator_regexp{ my $clstr = shift; $clstr =~ s/([^a-zA-Z0-9])/\\$1/g; my $termstr = '^\s*no\s+'.$clstr.'\s*;\s*(#.*)*$'; return qr/$termstr/o; # allow trailing comments } sub reinstator_regexp{ my $clstr = shift; $clstr =~ s/([^a-zA-Z0-9])/\\$1/g; my $reinstr = '^\s*use\s+'.$clstr.'\s*;\s*(#.*)*$'; return qr/$reinstr/o; # allow trailing comments } # save eval of findslice that should be used within perldl or pdl2 # as a preprocessor sub perldlpp { my ($class, $txt) = @_; local($_); ############################## # Backwards compatibility to before the two-parameter form. The only # call should be around line 206 of PDL::AutoLoader, but one never # knows.... # -- CED 5-Nov-2007 if(!defined($txt)) { print "PDL::NiceSlice::perldlpp -- got deprecated one-argument form, from ".(join("; ",caller))."...\n"; $txt = $class; $class = "PDL::NiceSlice"; } ## Debugging to track exactly what is going on -- left in, in case it's needed again if($PDL::debug > 1) { print "PDL::NiceSlice::perldlpp - got:\n$txt\n"; my $i; for $i(0..5){ my($package,$filename,$line,$subroutine, $hasargs) = caller($i); printf("layer %d: %20s, %40s, line %5d, sub %20s, args: %d\n",$i,$package,$filename,$line,$subroutine,$hasargs); } } my $new; ############################## ## This block sort-of echoes import(), below... ## Crucial difference: we don't give up the ghost on termination conditions, only ## mask out current findslices. That's because future uses won't be processed ## (for some reason source filters don't work on evals). my @lines= split /\n/,$txt; my $terminator = terminator_regexp($class); my $reinstator = reinstator_regexp($class); my($status, $off, $end); eval { do { my $data = ""; while(@lines) { $_= shift @lines; if(defined($terminator) && m/$terminator/) { $_ = "## $_"; $off = 1; last; } if(defined($reinstator) && m/$reinstator/) { $_ = "## $_"; } if(m/^\s*(__END__|__DATA__)\s*$/) { $end=$1; $off = 1; last; } $data .= "$_\n"; $count++; $_=""; } $_ = $data; $_ = findslice $_ ; $_ .= "no $class;\n" if $off; $_ .= "$end\n" if $end; $new .= "$_"; while($off && @lines) { $_ = shift @lines; if(defined($reinstator) && m/$reinstator/) { $off = 0; $_ = "## $_"; } if(defined($terminator) && m/$terminator/) { $_ = "## $_"; } $new .= "$_\n"; } } while(@lines && !$end); }; if ($@) { my $err = $@; for (split '','#!|\'"%~/') { return "print q${_}NiceSlice error: $err${_}" unless $err =~ m{[$_]}; } return "print q{NiceSlice error: $err}"; # if this doesn't work # we're stuffed } if($PDL::debug > 1) { print "PDL::NiceSlice::perldlpp - returning:\n$new\n"; } return $new; } BEGIN { require "$PDL::NiceSlice::engine"; } =head1 NAME PDL::NiceSlice - toward a nicer slicing syntax for PDL =head1 SYNOPSYS use PDL::NiceSlice; $a(1:4) .= 2; # concise syntax for ranges print $b((0),1:$end); # use variables in the slice expression $a->xchg(0,1)->(($pos-1)) .= 0; # default method syntax $idx = long 1, 7, 3, 0; # a piddle of indices $a(-3:2:2,$idx) += 3; # mix explicit indexing and ranges $a->clump(1,2)->(0:30); # 'default method' syntax $a(myfunc(0,$var),1:4)++; # when using functions in slice expressions # use parentheses around args! $b = $a(*3); # Add dummy dimension of order 3 # modifiers are specified in a ;-separated trailing block $a($a!=3;?)++; # short for $a->where($a!=3)++ $a(0:1114;_) .= 0; # short for $a->flat->(0:1114) $b = $a(0:-1:3;|); # short for $a(0:-1:3)->sever $n = sequence 3,1,4,1; $b = $n(;-); # drop all dimensions of size 1 (AKA squeeze) $b = $n(0,0;-|); # squeeze *and* sever $c = $a(0,3,0;-); # more compact way of saying $a((0),(3),(0)) =head1 DESCRIPTION Slicing is a basic, extremely common operation, and PDL's L method would be cumbersome to use in many cases. C rectifies that by incorporating new slicing syntax directly into the language via a perl I (see L). NiceSlice adds no new functionality, only convenient syntax. NiceSlice is loaded automatically in the perldl or pdl2 shell, but (to avoid conflicts with other modules) must be loaded explicitly in standalone perl/PDL scripts (see below). If you prefer not to use a prefilter on your standalone scripts, you can use the L method in those scripts, rather than the more compact NiceSlice constructs. =head1 Use in scripts and C or C shell The new slicing syntax can be switched on and off in scripts and perl modules by using or unloading C. But now back to scripts and modules. Everything after C will be translated and you can use the new slicing syntax. Source filtering will continue until the end of the file is encountered. You can stop sourcefiltering before the end of the file by issuing a C statement. Here is an example: use PDL::NiceSlice; # this code will be translated # and you can use the new slicing syntax no PDL::NiceSlice; # this code won't # and the new slicing syntax will raise errors! See also L and F in this distribution for further examples. NOTE: Unlike "normal" modules you need to include a C call in each and every file that contains code that uses the new slicing syntax. Imagine the following situation: a file F # start test0.pl use PDL; use PDL::NiceSlice; $a = sequence 10; print $a(0:4),"\n"; require 'test1.pl'; # end test0.pl that Cs a second file F # begin test1.pl $aa = sequence 11; print $aa(0:7),"\n"; 1; # end test1.pl Following conventional perl wisdom everything should be alright since we Cd C and C already from within F and by the time F is Cd things should be defined and imported, etc. A quick test run will, however, produce something like the following: perl test0.pl [0 1 2 3 4] syntax error at test1.pl line 3, near "0:" Compilation failed in require at test0.pl line 7. This can be fixed by adding the line use PDL::NiceSlice; C the code in F that uses the new slicing syntax (to play safe just include the line near the top of the file), e.g. # begin corrected test1.pl use PDL::NiceSlice; $aa = sequence 11; print $aa(0:7),"\n"; 1; # end test1.pl Now things proceed more smoothly perl test0.pl [0 1 2 3 4] [0 1 2 3 4 5 6 7] Note that we don't need to issue C again. C is a somewhat I module in that respect. It is a consequence of the way source filtering works in Perl (see also the IMPLEMENTATION section below). =head2 evals and C Due to C being a source filter it won't work in the usual way within evals. The following will I do what you want: $a = sequence 10; eval << 'EOE'; use PDL::NiceSlice; $b = $a(0:5); EOE print $b; Instead say: use PDL::NiceSlice; $a = sequence 10; eval << 'EOE'; $b = $a(0:5); EOE print $b; Source filters I be executed at compile time to be effective. And C is just a source filter (although it is not necessarily obvious for the casual user). =head1 The new slicing syntax Using C slicing piddles becomes so much easier since, first of all, you don't need to make explicit method calls. No $pdl->slice(....); calls, etc. Instead, C introduces two ways in which to slice piddles without too much typing: =over 2 =item * using parentheses directly following a scalar variable name, for example $c = $b(0:-3:4,(0)); =item * using the so called I invocation in which the piddle object is treated as if it were a reference to a subroutine (see also L). Take this example that slices a piddle that is part of a perl list C<@b>: $c = $b[0]->(0:-3:4,(0)); =back The format of the argument list is the same for both types of invocation and will be explained in more detail below. =head2 Parentheses following a scalar variable name An arglist in parentheses following directly after a scalar variable name that is I preceded by C<&> will be resolved as a slicing command, e.g. $a(1:4) .= 2; # only use this syntax on piddles $sum += $a(,(1)); However, if the variable name is immediately preceded by a C<&>, for example &$a(4,5); it will not be interpreted as a slicing expression. Rather, to avoid interfering with the current subref syntax, it will be treated as an invocation of the code reference C<$a> with argumentlist C<(4,5)>. The $a(ARGS) syntax collides in a minor way with the perl syntax. In particular, ``foreach $var(LIST)'' appears like a PDL slicing call. NiceSlice avoids translating the ``for $var(LIST)'' and ``foreach $var(LIST)'' constructs for this reason. Since you can't use just any old lvalue expression in the 'foreach' 'for' constructs -- only a real perl scalar will do -- there's no functionality lost. If later versions of perl accept ``foreach (LIST)'', then you can use the code ref syntax, below, to get what you want. =head2 The I syntax The second syntax that will be recognized is what I called the I syntax. It is the method arrow C<-E> directly followed by an open parenthesis, e.g. $a->xchg(0,1)->(($pos)) .= 0; Note that this conflicts with the use of normal code references, since you can write in plain Perl $sub = sub { print join ',', @_ }; $sub->(1,'a'); NOTE: Once C is in effect (you can always switch it off with a line C anywhere in the script) the source filter will incorrectly replace the above call to C<$sub> with an invocation of the slicing method. This is one of the pitfalls of using a source filter that doesn't know anything about the runtime type of a variable (cf. the Implementation section). This shouldn't be a major problem in practice; a simple workaround is to use the C<&>-way of calling subrefs, e.g.: $sub = sub { print join ',', @_ }; &$sub(1,'a'); =head2 When to use which syntax? Why are there two different ways to invoke slicing? The first syntax C<$a(args)> doesn't work with chained method calls. E.g. $a->xchg(0,1)(0); won't work. It can I be used directly following a valid perl variable name. Instead, use the I syntax in such cases: $a->xchg(0,1)->(0); Similarly, if you have a list of piddles C<@pdls>: $b = $pdls[5]->(0:-1); =head2 The argument list The argument list is a comma separated list. Each argument specifies how the corresponding dimension in the piddle is sliced. In contrast to usage of the L method the arguments should I be quoted. Rather freely mix literals (1,3,etc), perl variables and function invocations, e.g. $a($pos-1:$end,myfunc(1,3)) .= 5; There can even be other slicing commands in the arglist: $a(0:-1:$pdl($step)) *= 2; NOTE: If you use function calls in the arglist make sure that you use parentheses around their argument lists. Otherwise the source filter will get confused since it splits the argument list on commas that are not protected by parentheses. Take the following example: sub myfunc { return 5*$_[0]+$_[1] } $a = sequence 10; $sl = $a(0:myfunc 1, 2); print $sl; PDL barfed: Error in slice:Too many dims in slice Caught at file /usr/local/bin/perldl, line 232, pkg main The simple fix is $sl = $a(0:myfunc(1, 2)); print $sl; [0 1 2 3 4 5 6 7] Note that using prototypes in the definition of myfunc does not help. At this stage the source filter is simply not intelligent enough to make use of this information. So beware of this subtlety. Another pitfall to be aware of: currently, you can't use the conditional operator in slice expressions (i.e., C, since the parser confuses them with ranges). For example, the following will cause an error: $a = sequence 10; $b = rand > 0.5 ? 0 : 1; # this one is ok print $a($b ? 1 : 2); # error ! syntax error at (eval 59) line 3, near "1, For the moment, just try to stay clear of the conditional operator in slice expressions (or provide us with a patch to the parser to resolve this issue ;). =head2 Modifiers Following a suggestion originally put forward by Karl Glazebrook the latest versions of C implement I in slice expressions. Modifiers are convenient shorthands for common variations on PDL slicing. The general syntax is $pdl(;) Four modifiers are currently implemented: =over =item * C<_> : I the piddle before applying the slice expression. Here is an example $b = sequence 3, 3; print $b(0:-2;_); # same as $b->flat->(0:-2) [0 1 2 3 4 5 6 7] which is quite different from the same slice expression without the modifier print $b(0:-2); [ [0 1] [3 4] [6 7] ] =item * C<|> : L the link to the piddle, e.g. $a = sequence 10; $b = $a(0:2;|)++; # same as $a(0:2)->sever++ print $b; [1 2 3] print $a; # check if $a has been modified [0 1 2 3 4 5 6 7 8 9] =item * C : short hand to indicate that this is really a L expression As expressions like $a->where($a>5) are used very often you can write that shorter as $a($a>5;?) With the C-modifier the expression preceding the modifier is I really a slice expression (e.g. ranges are not allowed) but rather an expression as required by the L method. For example, the following code will raise an error: $a = sequence 10; print $a(0:3;?); syntax error at (eval 70) line 3, near "0:" That's about all there is to know about this one. =item * C<-> : I out any singleton dimensions. In less technical terms: reduce the number of dimensions (potentially) by deleting all dims of size 1. It is equivalent to doing a L(-1). That can be very handy if you want to simplify the results of slicing operations: $a = ones 3, 4, 5; $b = $a(1,0;-); # easier to type than $a((1),(0)) print $b->info; PDL: Double D [5] It also provides a unique opportunity to have smileys in your code! Yes, PDL gives new meaning to smileys. =back =head2 Combining modifiers Several modifiers can be used in the same expression, e.g. $c = $a(0;-|); # squeeze and sever Other combinations are just as useful, e.g. C<;_|> to flatten and sever. The sequence in which modifiers are specified is not important. A notable exception is the C modifier (C) which must not be combined with other flags (let me know if you see a good reason to relax this rule). Repeating any modifier will raise an error: $c = $a(-1:1;|-|); # will cause error NiceSlice error: modifier | used twice or more Modifiers are still a new and experimental feature of C. I am not sure how many of you are actively using them. I. I think modifiers are very useful and make life a lot easier. Feedback is welcome as usual. The modifier syntax will likely be further tuned in the future but we will attempt to ensure backwards compatibility whenever possible. =head2 Argument formats In slice expressions you can use ranges and secondly, piddles as 1D index lists (although compare the description of the C-modifier above for an exception). =over 2 =item * ranges You can access ranges using the usual C<:> separated format: $a($start:$stop:$step) *= 4; Note that you can omit the trailing step which then defaults to 1. Double colons (C<::>) are not allowed to avoid clashes with Perl's namespace syntax. So if you want to use steps different from the default you have to also at least specify the stop position. Examples: $a(::2); # this won't work (in the way you probably intended) $a(:-1:2); # this will select every 2nd element in the 1st dim Just as with L negative indices count from the end of the dimension backwards with C<-1> being the last element. If the start index is larger than the stop index the resulting piddle will have the elements in reverse order between these limits: print $a(-2:0:2); [8 6 4 2 0] A single index just selects the given index in the slice print $a(5); [5] Note, however, that the corresponding dimension is not removed from the resulting piddle but rather reduced to size 1: print $a(5)->info PDL: Double D [1] If you want to get completely rid of that dimension enclose the index in parentheses (again similar to the L syntax): print $a((5)); 5 In this particular example a 0D piddle results. Note that this syntax is only allowed with a single index. All these will be errors: print $a((0,4)); # will work but not in the intended way print $a((0:4)); # compile time error An empty argument selects the whole dimension, in this example all of the first dimension: print $a(,(0)); Alternative ways to select a whole dimension are $a = sequence 5, 5; print $a(:,(0)); print $a(0:-1,(0)); print $a(:-1,(0)); print $a(0:,(0)); Arguments for trailing dimensions can be omitted. In that case these dimensions will be fully kept in the sliced piddle: $a = random 3,4,5; print $a->info; PDL: Double D [3,4,5] print $a((0))->info; PDL: Double D [4,5] print $a((0),:,:)->info; # a more explicit way PDL: Double D [4,5] print $a((0),,)->info; # similar PDL: Double D [4,5] =item * dummy dimensions As in L, you can insert a dummy dimension by preceding a single index argument with '*'. A lone '*' inserts a dummy dimension of order 1; a '*' followed by a number inserts a dummy dimension of that order. =item * piddle index lists The second way to select indices from a dimension is via 1D piddles of indices. A simple example: $a = random 10; $idx = long 3,4,7,0; $b = $a($idx); This way of selecting indices was previously only possible using L (C attempts to unify the C and C interfaces). Note that the indexing piddles must be 1D or 0D. Higher dimensional piddles as indices will raise an error: $a = sequence 5, 5; $idx2 = ones 2,2; $sum = $a($idx2)->sum; piddle must be <= 1D at /home/XXXX/.perldlrc line 93 Note that using index piddles is not as efficient as using ranges. If you can represent the indices you want to select using a range use that rather than an equivalent index piddle. In particular, memory requirements are increased with index piddles (and execution time I be longer). That said, if an index piddle is the way to go use it! =back As you might have expected ranges and index piddles can be freely mixed in slicing expressions: $a = random 5, 5; $b = $a(-1:2,pdl(3,0,1)); =head2 piddles as indices in ranges You can use piddles to specify indices in ranges. No need to turn them into proper perl scalars with the new slicing syntax. However, make sure they contain not more than one element! Otherwise a runtime error will be triggered. First a couple of examples that illustrate proper usage: $a = sequence 5, 5; $rg = pdl(1,-1,3); print $a($rg(0):$rg(1):$rg(2),2); [ [11 14] ] print $a($rg+1,:$rg(0)); [ [2 0 4] [7 5 9] ] The next one raises an error print $a($rg+1,:$rg(0:1)); multielement piddle where only one allowed at XXX/Core.pm line 1170. The problem is caused by using the 2-element piddle C<$rg(0:1)> as the stop index in the second argument C<:$rg(0:1)> that is interpreted as a range by C. You I use multielement piddles as index piddles as described above but not in ranges. And C treats any expression with unprotected C<:>'s as a range. I means as usual I<"not occurring between matched parentheses">. =head1 IMPLEMENTATION C exploits the ability of Perl to use source filtering (see also L). A source filter basically filters (or rewrites) your perl code before it is seen by the compiler. C searches through your Perl source code and when it finds the new slicing syntax it rewrites the argument list appropriately and splices a call to the C method using the modified arg list into your perl code. You can see how this works in the L or L shells by switching on reporting (see above how to do that). =head1 BUGS =head2 Conditional operator The conditional operator can't be used in slice expressions (see above). =head2 The C file handle I: To avoid clobbering the C filehandle C switches itself off when encountering the C<__END__> or C<__DATA__> tokens. This should not be a problem for you unless you use C to load PDL code including the new slicing from that section. It is even desirable when working with L, see below. =head2 Possible interaction with L There is currently an undesired interaction between C and the new L module (currently only in PDL CVS). Since PP code generally contains expressions of the type C<$var()> (to access piddles, etc) C recognizes those I as slice expressions and does its substitutions. This is not a problem if you use the C section for your Pdlpp code -- the recommended place for Inline code anyway. In that case C will have switched itself off before encountering any Pdlpp code (see above): # use with Inline modules use PDL; use PDL::NiceSlice; use Inline Pdlpp; $a = sequence(10); print $a(0:5); __END__ __Pdlpp__ ... inline stuff Otherwise switch C explicitly off around the Inline::Pdlpp code: use PDL::NiceSlice; $a = sequence 10; $a(0:3)++; $a->inc; no PDL::NiceSlice; # switch off before Pdlpp code use Inline Pdlpp => "Pdlpp source code"; The cleaner solution is to always stick with the C way of including your C code as in the first example. That way you keep your nice Perl code at the top and all the ugly Pdlpp stuff etc at the bottom. =head2 Bug reports Feedback and bug reports are welcome. Please include an example that demonstrates the problem. Log bug reports in the PDL bug database at http://sourceforge.net/p/pdl/bugs/ or send them to the pdl-devel mailing list Epdl-devel@lists.sourceforge.netE. =head1 COPYRIGHT Copyright (c) 2001, 2002 Christian Soeller. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as PDL itself (see L). =cut 1; PDL-2.018/Basic/Ufunc/0000755060175006010010000000000013110402046012464 5ustar chmNonePDL-2.018/Basic/Ufunc/Makefile.PL0000644060175006010010000000276213036512174014460 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; my @pack = (["ufunc.pd", qw(Ufunc PDL::Ufunc)]); if ($^O eq 'dec_osf') { if ($Config::Config{cc} =~ /^cc/) { my $no_optimize = ($::PDL_OPTIONS{OPTIMIZE} && $::PDL_OPTIONS{OPTIMIZE}) || $Config::Config{optimize} || '-g2'; $no_optimize =~ s/(\s|^)(-O)\d/$1${2}0/; $no_optimize =~ s/(\s|^)(-g)\d/$1${2}2/; print <SUPER::const_cccmd(@_); $defval =~ s/\$\(OPTIMIZE\)/| . $no_optimize . q|/gs; print "$defval\n"; return $defval; }; |; } } my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS}->[0] .= ' -lm'; #suppress warning from "$GENERIC(b) foo = 0.25;", which is intentional. $hash{INC} .= ' -Wno-literal-conversion ' if $Config{cc} =~ /\bclang\b/; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Basic/Ufunc/ufunc.pd0000644060175006010010000011517013036512174014151 0ustar chmNoneuse strict; # be careful pp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::Ufunc - primitive ufunc operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP based on functionality of what are sometimes called I (for example NumPY and Mathematica talk about these). It collects all the functions generally used to C or C along a dimension. These all do their job across the first dimension but by using the slicing functions you can do it on any dimension. The L module provides an alternative interface to many of the functions in this module. =head1 SYNOPSIS use PDL::Ufunc; =cut use PDL::Slices; use Carp; EOD # check for bad value support use PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; # should we use the finite() routine in libm ? # (is the Windows version _finite() ?) # pp_addhdr(<<'EOD'); #define IsNaN(x) (x*0 != 0) EOD # helper functions sub projectdocs { my $name = shift; my $op = shift; my $extras = shift; return < etc. it is possible to use I dimension. =for usage \$b = $op(\$a); =for example \$spectrum = $op \$image->xchg(0,1) $extras =cut EOD } # sub: projectdocs() sub cumuprojectdocs { my $name = shift; my $op = shift; my $extras = shift; return < etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative $name is the first element of the parameter. =for usage \$b = $op(\$a); =for example \$spectrum = $op \$image->xchg(0,1) $extras =cut EOD } # sub: cumuprojectdocs() # it's a bit unclear what to do with the comparison operators, # since the return value could be bad because all elements are bad, # which needs checking for since the bad value could evaluate to # true or false (eg if the user has set it to 0) # # by setting CopyBadStatusCode to '', we stop the output piddle # from automatically being set bad if any of the input piddles are bad. # - we can set the flag within BadCode if necessary # # This may NOT be sensible. Only time, and comments, will tell... # my %over = ( sumover => { name => 'sum', op => '+=', init => 0, }, prodover => { name => 'product', op => '*=', init => 1, }, ); foreach my $func ( sort keys %over ) { # creates $func and cumu$func functions # and d$func and dcumu$func functions, which # perform the calculations in double precision my $name = $over{$func}{name}; my $op = $over{$func}{op}; my $init = $over{$func}{init}; pp_def( $func, HandleBad => 1, Pars => 'a(n); int+ [o]b();', Code => '$GENERIC(b) tmp = ' . $init . '; loop(n) %{ tmp ' . $op . ' $a(); %} $b() = tmp;', BadCode => '$GENERIC(b) tmp = ' . $init . '; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) ) { tmp ' . $op . ' $a(); flag = 1; } %} if ( flag ) { $b() = tmp; } else { $SETBAD(b()); }', Doc => projectdocs( $name, $func, '' ), ); # as above, but in double precision pp_def( "d$func", HandleBad => 1, Pars => 'a(n); double [o]b();', Code => 'double tmp = ' . $init . '; loop(n) %{ tmp ' . $op . ' $a(); %} $b() = tmp;', BadCode => 'double tmp = ' . $init . '; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) ) { tmp ' . $op . ' $a(); flag = 1; } %} if ( flag ) { $b() = tmp; } else { $SETBAD(b()); }', Doc => projectdocs( $name, "d$func", "Unlike L<$func|/$func>, the calculations are performed in double\n" . "precision." ), ); my $cfunc = "cumu${func}"; pp_def( $cfunc, HandleBad => 1, Pars => 'a(n); int+ [o]b(n);', Code => '$GENERIC(b) tmp = ' . $init . '; loop(n) %{ tmp ' . $op . ' $a(); $b() = tmp; %}', BadCode => '$GENERIC(b) tmp = ' . $init . '; loop(n) %{ if ( $ISBAD(a()) ) { $SETBAD(b()); } else { tmp ' . $op . ' $a(); $b() = tmp; } %}', Doc => cumuprojectdocs( $name, $cfunc, '' ), ); # as above but in double precision pp_def( "d$cfunc", HandleBad => 1, Pars => 'a(n); double [o]b(n);', Code => 'double tmp = ' . $init . '; loop(n) %{ tmp ' . $op . ' $a(); $b() = tmp; %}', BadCode => 'double tmp = ' . $init . '; loop(n) %{ if ( $ISBAD(a()) ) { $SETBAD(b()); } else { tmp ' . $op . ' $a(); $b() = tmp; } %}', Doc => cumuprojectdocs( $name, $cfunc, "Unlike L, the calculations are performed in double\n" . "precision." ), ); } # foreach: my $func %over = ( zcover => { def=>'char tmp', txt => '== 0', init => 1, alltypes => 1, otype => 'int+', op => 'tmp &= ($a() == 0);', check => '!tmp' }, andover => { def=>'char tmp', txt => 'and', init => 1, alltypes => 1, otype => 'int+', op => 'tmp &= ($a() != 0);', check => '!tmp' }, bandover => { def=>'$GENERIC() tmp', txt => 'bitwise and', init => '~0', otype => '', op => 'tmp &= $a();', check => '!tmp' }, orover => { def=>'char tmp', txt => 'or', init => 0, alltypes => 1, otype => 'int+', op => 'tmp |= ($a() != 0);', check => 'tmp' }, borover => { def=>'$GENERIC() tmp', txt => 'bitwise or', init => 0, otype => '', op => 'tmp |= $a() ;', check => '!~tmp' }, ); foreach my $func ( sort keys %over ) { my $def = $over{$func}{def}; my $txt = $over{$func}{txt}; my $init = $over{$func}{init}; my $otype = $over{$func}{otype}; my $op = $over{$func}{op}; my $check = $over{$func}{check}; my %extra = {}; unless ( defined $over{$func}{alltypes} and $over{$func}{alltypes} ) { $extra{GenericTypes} = ['B','S','U','L','N']; } pp_def( $func, HandleBad => 1, %extra, Pars => 'a(n); ' . $otype . ' [o]b();', Code => $def . '=' . $init . '; loop(n) %{ ' . $op . ' if (' . $check . ') break; %} $b() = tmp;', BadCode => 'char tmp = ' . $init . '; $GENERIC(b) gtmp = '. $init . '; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) ) { ' . $op . ' flag = 1; if (' . $check . ') break; } %} if ( flag ) { $b() = tmp; } else { $SETBAD(b()); $PDLSTATESETBAD(b); }', CopyBadStatusCode => '', Doc => projectdocs( $txt, $func,''), BadDoc => 'If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values.', ); } # foreach: $func # this would need a lot of work to support bad values # plus it gives me a chance to check out HandleBad => 0 ;) # pp_def( 'intover', HandleBad => 0, Pars => 'a(n); float+ [o]b();', Code => '$GENERIC(b) tmp = 0; PDL_Indx ns = $SIZE(n), nn; /* Integration formulae from Press et al 2nd Ed S 4.1 */ switch (ns) { case 1: threadloop %{ $b() = 0.; /* not a(n=>0); as interval has zero width */ %} break; case 2: threadloop %{ $b() = 0.5*($a(n=>0)+$a(n=>1)); %} break; case 3: threadloop %{ $b() = ($a(n=>0)+4*$a(n=>1)+$a(n=>2))/3.; %} break; case 4: threadloop %{ $b() = ($a(n=>0)+$a(n=>3)+3.*($a(n=>1)+$a(n=>2)))*0.375; %} break; case 5: threadloop %{ $b() = (14.*($a(n=>0)+$a(n=>4)) +64.*($a(n=>1)+$a(n=>3)) +24.*$a(n=>2))/45.; %} break; default: threadloop %{ for (nn=3,tmp=0;nnnn); } tmp += (23./24.)*($a(n=>2)+$a(n=>nn));nn++; tmp += (7./6.) *($a(n=>1)+$a(n=>nn));nn++; tmp += 0.375 *($a(n=>0)+$a(n=>nn)); $b() = tmp; %} } ', Doc => projectdocs('integral','intover', q~Notes: C uses a point spacing of one (i.e., delta-h==1). You will need to scale the result to correct for the true point delta). For C 3>, these are all C (like Simpson's rule), but are integrals between the end points assuming the pdl gives values just at these centres: for such `functions', sumover is correct to C, but is the natural (and correct) choice for binned data, of course. ~) ); # intover pp_def( 'average', HandleBad => 1, Pars => 'a(n); int+ [o]b();', Code => '$GENERIC(b) tmp = 0; if($SIZE(n)) { loop(n) %{ tmp += $a(); %} ; $b() = tmp / ($GENERIC(b)) $SIZE(n); } else { $GENERIC(b) foo = 0.25; if(foo == 0) { /* Cheesy check for floating-pointiness */ $b() = 0; /* Integer - set to 0 */ } else { $b() = sqrt(-1); /* Cheesy NaN -- CED */ } }', BadCode => '$GENERIC(b) tmp = 0; PDL_Indx cnt = 0; loop(n) %{ if ( $ISGOOD(a()) ) { tmp += $a(); cnt++; } %} if ( cnt ) { $b() = tmp / ($GENERIC(b)) cnt; } else { $SETBAD(b()); }', Doc => projectdocs( 'average', 'average', '' ), ); pp_addpm("*PDL::avgover = \\&PDL::average;\n"); pp_addpm("*avgover = \\&PDL::average;\n"); pp_add_exported('PDL::PP avgover'); pp_addpm(<<'EOD'); =head2 avgover =for ref Synonym for average. =cut EOD # do the above calculation, but in double precision pp_def( 'daverage', HandleBad => 1, Pars => 'a(n); double [o]b();', Code => 'double tmp = 0; if($SIZE(n)) { loop(n) %{ tmp += $a(); %} $b() = tmp / $SIZE(n); } else { $b() = 0; }', BadCode => 'double tmp = 0; PDL_Indx cnt = 0; loop(n) %{ if ( $ISGOOD(a()) ) { tmp += $a(); cnt++; } %} if ( cnt ) { $b() = tmp / cnt; } else { $SETBAD(b()); }', Doc => projectdocs( 'average', 'daverage', "Unlike L, the calculation is performed in double\n" . "precision." ), ); pp_addpm("*PDL::davgover = \\&PDL::daverage;\n"); pp_addpm("*davgover = \\&PDL::daverage;\n"); pp_add_exported('PDL::PP davgover'); pp_addpm(<<'EOD'); =head2 davgover =for ref Synonym for daverage. =cut EOD # Internal utility sorting routine for median/qsort/qsortvec routines. # # note: we export them to the PDL Core structure for use in # other modules (eg Image2D) for ( PDL::Types::typesrtkeys() ) { my $ctype = $PDL::Types::typehash{$_}{ctype}; my $ppsym = $PDL::Types::typehash{$_}{ppsym}; pp_add_boot( " PDL->qsort_${ppsym} = pdl_qsort_${ppsym};" . " PDL->qsort_ind_${ppsym} = pdl_qsort_ind_${ppsym};\n" ); pp_addhdr(<<"FOO" void pdl_qsort_$ppsym($ctype* xx, PDL_Indx a, PDL_Indx b) { PDL_Indx i,j; $ctype t, median; i = a; j = b; median = xx[(i+j) / 2]; do { while (xx[i] < median) i++; while (median < xx[j]) j--; if (i <= j) { t = xx[i]; xx[i] = xx[j]; xx[j] = t; i++; j--; } } while (i <= j); if (a < j) pdl_qsort_$ppsym(xx,a,j); if (i < b) pdl_qsort_$ppsym(xx,i,b); } void pdl_qsort_ind_$ppsym($ctype* xx, PDL_Indx* ix, PDL_Indx a, PDL_Indx b) { PDL_Indx i,j; PDL_Indx t; $ctype median; i = a; j = b; median = xx[ix[(i+j) / 2]]; do { while (xx[ix[i]] < median) i++; while (median < xx[ix[j]]) j--; if (i <= j) { t = ix[i]; ix[i] = ix[j]; ix[j] = t; i++; j--; } } while (i <= j); if (a < j) pdl_qsort_ind_$ppsym(xx,ix,a,j); if (i < b) pdl_qsort_ind_$ppsym(xx,ix,i,b); } /******* * qsortvec helper routines * --CED 21-Aug-2003 */ /* Compare a vector in lexicographic order, returning the * equivalent of "<=>". */ signed char pdl_cmpvec_$ppsym($ctype *a, $ctype *b, PDL_Indx n) { PDL_Indx i; for(i=0; i *b ) return 1; } return 0; } void pdl_qsortvec_$ppsym($ctype *xx, PDL_Indx n, PDL_Indx a, PDL_Indx b) { PDL_Indx i,j, median_ind; $ctype t; i = a; j = b; median_ind = (i+j)/2; do { while( pdl_cmpvec_$ppsym( &(xx[n*i]), &(xx[n*median_ind]), n ) < 0 ) i++; while( pdl_cmpvec_$ppsym( &(xx[n*j]), &(xx[n*median_ind]), n ) > 0 ) j--; if(i<=j) { PDL_Indx k; $ctype *aa = &xx[n*i]; $ctype *bb = &xx[n*j]; for( k=0; k 0 ) j--; if(i<=j) { PDL_Indx k; k = ix[i]; ix[i] = ix[j]; ix[j] = k; if (median_ind==i) median_ind=j; else if (median_ind==j) median_ind=i; i++; j--; } } while (i <= j); if (a < j) pdl_qsortvec_ind_$ppsym( xx, ix, n, a, j ); if (i < b) pdl_qsortvec_ind_$ppsym( xx, ix, n, i, b ); } FOO ); } # when copying the data over to the temporary array, # ignore the bad values and then only send the number # of good elements to the sort routines # sub generic_qsort { my $pdl = shift; return '$TBSULNQFD(pdl_qsort_B,pdl_qsort_S,pdl_qsort_U, pdl_qsort_L,pdl_qsort_N,pdl_qsort_Q,pdl_qsort_F,pdl_qsort_D) ($P(' . $pdl . '), 0, nn);'; } sub generic_qsortvec { my $pdl = shift; my $ndim = shift; return '$TBSULNQFD(pdl_qsortvec_B,pdl_qsortvec_S,pdl_qsortvec_U, pdl_qsortvec_L,pdl_qsortvec_N,pdl_qsortvec_Q,pdl_qsortvec_F,pdl_qsortvec_D) ($P(' . $pdl . '), '. $ndim.', 0, nn);'; } # should use threadloop ? # my $copy_to_temp_good = ' PDL_Indx nn, nn1; loop(n) %{ $tmp() = $a(); %} nn = $COMP(__n_size)-1; ' . generic_qsort('tmp'); my $copy_to_temp_bad = ' register PDL_Indx nn = 0; loop(n) %{ if ( $ISGOOD(a()) ) { $tmp(n=>nn) = $a(); nn++; } %} if ( nn == 0 ) { $SETBAD(b()); } else { '; my $find_median_average = ' nn1 = nn/2; nn2 = nn1+1; if (nn%2==0) { $b() = $tmp(n => nn1); } else { $b() = 0.5*( $tmp(n => nn1) + $tmp(n => nn2) ); }'; my $find_median_lower = ' nn1 = nn/2; $b() = $tmp(n => nn1);'; pp_def( 'medover', HandleBad => 1, Pars => 'a(n); [o]b(); [t]tmp(n);', Doc => projectdocs('median','medover',''), Code => "PDL_Indx nn2;\n" . $copy_to_temp_good . $find_median_average, BadCode => $copy_to_temp_bad . ' PDL_Indx nn1, nn2; nn -= 1; ' . generic_qsort('tmp') . $find_median_average . '}', ); # pp_def: medover pp_def( 'oddmedover', HandleBad => 1, Pars => 'a(n); [o]b(); [t]tmp(n);', Doc => projectdocs('oddmedian','oddmedover',' The median is sometimes not a good choice as if the array has an even number of elements it lies half-way between the two middle values - thus it does not always correspond to a data value. The lower-odd median is just the lower of these two values and so it ALWAYS sits on an actual data value which is useful in some circumstances. '), Code => $copy_to_temp_good . $find_median_lower, BadCode => $copy_to_temp_bad . ' PDL_Indx nn1; nn -= 1; '. $find_median_lower . '}', ); # pp_def: oddmedover pp_def('modeover', HandleBad=>undef, Pars => 'data(n); [o]out(); [t]sorted(n);', GenericTypes=>['B','S','U','L','Q','N'], Doc=>projectdocs('mode','modeover',' The mode is the single element most frequently found in a discrete data set. It I makes sense for integer data types, since floating-point types are demoted to integer before the mode is calculated. C treats BAD the same as any other value: if BAD is the most common element, the returned value is also BAD. '), Code => <<'EOCODE', PDL_Indx i = 0; PDL_Indx most = 0; $GENERIC() curmode; $GENERIC() curval; /* Copy input to buffer for sorting, and sort it */ loop(n) %{ $sorted() = $data(); %} PDL->$TBSULNQ(qsort_B,qsort_S,qsort_U,qsort_L,qsort_N,qsort_Q)($P(sorted),0,$SIZE(n)-1); /* Walk through the sorted data and find the most common elemen */ loop(n) %{ if( n==0 || curval != $sorted() ) { curval = $sorted(); i=0; } else { i++; if(i>most){ most=i; curmode = curval; } } %} $out() = curmode; EOCODE ); my $find_pct_interpolate = ' np = nn * $p(); nn1 = np; nn2 = nn1+1; nn1 = (nn1 < 0) ? 0 : nn1; nn2 = (nn2 < 0) ? 0 : nn2; nn1 = (nn1 > nn) ? nn : nn1; nn2 = (nn2 > nn) ? nn : nn2; if (nn == 0) { pp1 = 0; pp2 = 0; } else { pp1 = (double)nn1/(double)(nn); pp2 = (double)nn2/(double)(nn); } if ( np <= 0.0 ) { $b() = $tmp(n => 0); } else if ( np >= nn ) { $b() = $tmp(n => nn); } else if ($tmp(n => nn2) == $tmp(n => nn1)) { $b() = $tmp(n => nn1); } else if ($p() == pp1) { $b() = $tmp(n => nn1); } else if ($p() == pp2) { $b() = $tmp(n => nn2); } else { $b() = (np - nn1)*($tmp(n => nn2) - $tmp(n => nn1)) + $tmp(n => nn1); } '; pp_def('pctover', HandleBad => 1, Pars => 'a(n); p(); [o]b(); [t]tmp(n);', Doc => ' =for ref Project via percentile to N-1 dimensions This function reduces the dimensionality of a piddle by one by finding the specified percentile (p) along the 1st dimension. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. Values outside the allowed range are clipped to 0.0 or 1.0 respectively. The algorithm implemented here is based on the interpolation variant described at L as used by Microsoft Excel and recommended by NIST. By using L etc. it is possible to use I dimension. =for usage $b = pctover($a, $p); =for example $spectrum = pctover $image->xchg(0,1), $p =cut ', Code => ' double np, pp1, pp2; PDL_Indx nn2; ' . $copy_to_temp_good . $find_pct_interpolate, BadCode => $copy_to_temp_bad . ' PDL_Indx nn1, nn2; double np, pp1, pp2; nn -= 1; ' . generic_qsort('tmp') . $find_pct_interpolate . '}', ); pp_def('oddpctover', HandleBad => 1, Pars => 'a(n); p(); [o]b(); [t]tmp(n);', Doc => ' Project via percentile to N-1 dimensions This function reduces the dimensionality of a piddle by one by finding the specified percentile along the 1st dimension. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. The algorithm implemented is from the textbook version described first at L. By using L etc. it is possible to use I dimension. =for usage $b = oddpctover($a, $p); =for example $spectrum = oddpctover $image->xchg(0,1), $p =cut ', Code => ' PDL_Indx np; ' . $copy_to_temp_good . ' np = (nn+1)*$p(); if (np > nn) np = nn; if (np < 0) np = 0; $b() = $tmp(n => np); ', BadCode => 'PDL_Indx np; ' . $copy_to_temp_bad . ' nn -= 1; ' . generic_qsort('tmp') . ' np = (nn+1)*$p(); if (np > nn) np = nn; if (np < 0) np = 0; $b() = $tmp(n => np); }', ); pp_add_exported('', 'pct'); pp_addpm(<<"EOD"); =head2 pct =for ref Return the specified percentile of all elements in a piddle. The specified percentile (p) must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. =for usage \$x = pct(\$data, \$pct); =cut *pct = \\&PDL::pct; sub PDL::pct { my(\$x, \$p) = \@_; my \$tmp; \$x->clump(-1)->pctover(\$p, \$tmp=PDL->nullcreate(\$x)); return \$tmp->at(); } EOD pp_add_exported('', 'oddpct'); pp_addpm(<<"EOD"); =head2 oddpct =for ref Return the specified percentile of all elements in a piddle. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. =for usage \$x = oddpct(\$data, \$pct); =cut *oddpct = \\&PDL::oddpct; sub PDL::oddpct { my(\$x, \$p) = \@_; my \$tmp; \$x->clump(-1)->oddpctover(\$p, \$tmp=PDL->nullcreate(\$x)); return \$tmp->at(); } EOD # Generate small ops functions to do entire array # # How to handle a return value of BAD - ie what # datatype to use? # for my $op ( ['avg','average','average'], ['sum','sumover','sum'], ['prod','prodover','product'], ['davg','daverage','average (in double precision)'], ['dsum','dsumover','sum (in double precision)'], ['dprod','dprodover','product (in double precision)'], ['zcheck','zcover','check for zero'], ['and','andover','logical and'], ['band','bandover','bitwise and'], ['or','orover','logical or'], ['bor','borover','bitwise or'], ['min','minimum','minimum'], ['max','maximum','maximum'], ['median', 'medover', 'median'], ['mode', 'modeover', 'mode'], ['oddmedian','oddmedover','oddmedian']) { my $name = $op->[0]; my $func = $op->[1]; my $text = $op->[2]; pp_add_exported('', $name); pp_addpm(<<"EOD"); =head2 $name =for ref Return the $text of all elements in a piddle. See the documentation for L<$func|/$func> for more information. =for usage \$x = $name(\$data); =cut EOD if ( $bvalflag ) { pp_addpm(<<"EOD"); =for bad This routine handles bad values. =cut EOD } # if: bvalflag pp_addpm(<<"EOD"); *$name = \\&PDL::$name; sub PDL::$name { my(\$x) = \@_; my \$tmp; \$x->clump(-1)->${func}( \$tmp=PDL->nullcreate(\$x) ); return \$tmp->at(); } EOD } # for $op pp_add_exported('','any all'); pp_addpm(<<'EOPM'); =head2 any =for ref Return true if any element in piddle set Useful in conditional expressions: =for example if (any $a>15) { print "some values are greater than 15\n" } =cut EOPM if ( $bvalflag ) { pp_addpm(<<'EOPM'); =for bad See L for comments on what happens when all elements in the check are bad. =cut EOPM } # if: bvalflag pp_addpm(<<'EOPM'); *any = \∨ *PDL::any = \&PDL::or; =head2 all =for ref Return true if all elements in piddle set Useful in conditional expressions: =for example if (all $a>15) { print "all values are greater than 15\n" } =cut EOPM if ( $bvalflag ) { pp_addpm(<<'EOPM'); =for bad See L for comments on what happens when all elements in the check are bad. =cut EOPM } # IF: BVALFLAG pp_addpm(<<'EOPM'); *all = \∧ *PDL::all = \&PDL::and; EOPM pp_addpm(<<'EOD' =head2 minmax =for ref Returns an array with minimum and maximum values of a piddle. =for usage ($mn, $mx) = minmax($pdl); This routine does I thread over the dimensions of C<$pdl>; it returns the minimum and maximum values of the whole array. See L if this is not what is required. The two values are returned as Perl scalars similar to min/max. =for example pdl> $x = pdl [1,-2,3,5,0] pdl> ($min, $max) = minmax($x); pdl> p "$min $max\n"; -2 5 =cut *minmax = \&PDL::minmax; sub PDL::minmax { my ($x)=@_; my $tmp; my @arr = $x->clump(-1)->minmaximum; return map {$_->sclr} @arr[0,1]; # return as scalars ! } EOD ); pp_add_exported('', 'minmax'); #pp_add_exported('', 'minmax_ind'); # move all bad values to the end of the array # pp_def( 'qsort', HandleBad => 1, Inplace => 1, Pars => 'a(n); [o]b(n);', Code => 'PDL_Indx nn; loop(n) %{ $b() = $a(); %} nn = $COMP(__n_size)-1; if ($PDL(a)->dims[0] != $PDL(b)->dims[0] && $PDL(a)->dims[0]!=0 && $PDL(b)->dims[0]!=1){ PDL->pdl_barf("You likely passed a scalar argument to qsort, when you should have passed a piddle (or nothing at all)"); } ' . generic_qsort('b'), BadCode => 'register PDL_Indx nn = 0, nb = $SIZE(n) - 1; loop(n) %{ if ( $ISGOOD(a()) ) { $b(n=>nn) = $a(); nn++; } else { $SETBAD(b(n=>nb)); nb--; } %} if ($PDL(a)->dims[0] != $PDL(b)->dims[0] && $PDL(b)->dims[0]!=0 && $PDL(b)->dims[0]!=1){ PDL->pdl_barf("You likely passed a scalar argument to qsort, when you should have passed a piddle (or nothing at all)"); } if ( nn != 0 ) { nn -= 1; ' . generic_qsort('b') . ' }', Doc => ' =for ref Quicksort a vector into ascending order. =for example print qsort random(10); =cut ', BadDoc => ' Bad values are moved to the end of the array: pdl> p $b [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p qsort($b) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] ', ); # pp_def qsort sub generic_qsort_ind { return '$TBSULNQFD(pdl_qsort_ind_B,pdl_qsort_ind_S,pdl_qsort_ind_U, pdl_qsort_ind_L,pdl_qsort_ind_N,pdl_qsort_ind_Q,pdl_qsort_ind_F,pdl_qsort_ind_D) ($P(a), $P(indx), 0, nn);'; } pp_def( 'qsorti', HandleBad => 1, Pars => 'a(n); indx [o]indx(n);', Code => 'PDL_Indx nn = $COMP(__n_size)-1; if ($SIZE(n) == 0) return; loop(n) %{ $indx() = n; %} if ($PDL(a)->dims[0] != $PDL(indx)->dims[0] && $PDL(a)->dims[0]!=0 && $PDL(indx)->dims[0]!=1){ PDL->pdl_barf("You likely passed a scalar argument to qsorti, when you should have passed a piddle (or nothing at all)"); } ' . generic_qsort_ind(), BadCode => 'register PDL_Indx nn = 0, nb = $SIZE(n) - 1; if ($SIZE(n) == 0) return; loop(n) %{ if ( $ISGOOD(a()) ) { $indx(n=>nn) = n; nn++; } /* play safe since nn used more than once */ else { $indx(n=>nb) = n; nb--; } %} if ($PDL(a)->dims[0] != $PDL(indx)->dims[0] && $PDL(a)->dims[0]!=0 && $PDL(indx)->dims[0]!=1){ PDL->pdl_barf("You likely passed a scalar argument to qsorti, when you should have passed a piddle (or nothing at all)"); } if ( nn != 0 ) { nn -= 1; ' . generic_qsort_ind() . ' }', BadDoc => 'Bad elements are moved to the end of the array: pdl> p $b [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p $b->index( qsorti($b) ) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] ', Doc => ' =for ref Quicksort a vector and return index of elements in ascending order. =for example $ix = qsorti $a; print $a->index($ix); # Sorted list =cut ' ); # pp_def: qsorti # move all bad values to the end of the array # pp_def( 'qsortvec', HandleBad => 1, Inplace => 1, Pars => 'a(n,m); [o]b(n,m);', Code => 'PDL_Indx nn; PDL_Indx nd; loop(n,m) %{ $b() = $a(); %} nn = ($COMP(__m_size))-1; nd = $COMP(__n_size); if (($PDL(a)->dims[0] != $PDL(b)->dims[0] || $PDL(a)->dims[1] != $PDL(b)->dims[1]) && $PDL(a)->dims[1] !=0 && $PDL(b)->dims[1] != 1){ PDL->pdl_barf("You likely passed a scalar argument to qsortvec, when you should have passed a piddle (or nothing at all)"); } ' . generic_qsortvec('b','nd'), Doc => ' =for ref Sort a list of vectors lexicographically. The 0th dimension of the source piddle is dimension in the vector; the 1st dimension is list order. Higher dimensions are threaded over. =for example print qsortvec pdl([[1,2],[0,500],[2,3],[4,2],[3,4],[3,5]]); [ [ 0 500] [ 1 2] [ 2 3] [ 3 4] [ 3 5] [ 4 2] ] =cut ', BadDoc => ' Vectors with bad components should be moved to the end of the array: ', ); # pp_def qsortvec sub generic_qsortvec_ind { my $pdl = shift; my $ndim = shift; return '$TBSULNQFD(pdl_qsortvec_ind_B,pdl_qsortvec_ind_S,pdl_qsortvec_ind_U,pdl_qsortvec_ind_L,pdl_qsortvec_ind_N,pdl_qsortvec_ind_Q,pdl_qsortvec_ind_F,pdl_qsortvec_ind_D) ($P(' . $pdl . '), $P(indx), '. $ndim.', 0, nn);'; } pp_def( 'qsortveci', HandleBad => 1, Pars => 'a(n,m); indx [o]indx(m);', Code => 'PDL_Indx nd; PDL_Indx nn=$COMP(__m_size)-1; loop(m) %{ $indx()=m; %} nd = $COMP(__n_size); if ($PDL(a)->ndims >1 && $PDL(a)->dims[1] != $PDL(indx)->dims[0] && $PDL(a)->dims[1]!=0 && $PDL(indx)->dims[0]!=1){ PDL->pdl_barf("You likely passed a scalar argument to qsortveci, when you should have passed a piddle (or nothing at all)"); } ' . generic_qsortvec_ind('a','nd'), Doc => ' =for ref Sort a list of vectors lexicographically, returning the indices of the sorted vectors rather than the sorted list itself. As with C, the input PDL should be an NxM array containing M separate N-dimensional vectors. The return value is an integer M-PDL containing the M-indices of original array rows, in sorted order. As with C, the zeroth element of the vectors runs slowest in the sorted list. Additional dimensions are threaded over: each plane is sorted separately, so qsortveci may be thought of as a collapse operator of sorts (groan). =cut ', BadDoc => ' Vectors with bad components should be moved to the end of the array: ', ); for my $which ( ['minimum','<'], ['maximum','>'] ) { my $name = $which->[0]; my $op = $which->[1]; pp_def( $name, HandleBad => 1, Pars => 'a(n); [o]c();', Code => '$GENERIC() cur; int flag = 0; loop(n) %{ if( !flag || ($a() '.$op.' cur ) || IsNaN(cur) ) { cur = $a(); flag = 1;} %} if(flag && !IsNaN(cur)) { $c() = cur; } else { ' . ($bvalflag ? ' $SETBAD(c()); $PDLSTATESETBAD(c); ' : ' $c() = 0.25; if($c()>0) $c() = sqrt(-1); ' ) . ' } ', BadCode => '$GENERIC() cur; int flag = 0; loop(n) %{ if( $ISGOOD(a()) && ($a()*0 == 0) && (!flag || $a() '.$op.' cur)) {cur = $a(); flag = 1;} %} if ( flag ) { $c() = cur; } else { $SETBAD(c()); $PDLSTATESETBAD(c); }', CopyBadStatusCode => '', Doc => projectdocs($name,$name), BadDoc => 'Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output piddle. Note that C are considered to be valid values; see L and L for ways of masking NaNs. ', ); pp_def( "${name}_ind", HandleBad => 1, Pars => 'a(n); indx [o] c();', Code => '$GENERIC() cur; PDL_Indx curind; int flag = 0; loop(n) %{ if(!flag || $a() '.$op.' cur || IsNaN(cur)) {cur = $a(); curind = n;flag=1;} %} if(flag && !IsNaN(cur)) { $c() = curind; } else { ' . ($bvalflag ? ' $SETBAD(c()); $PDLSTATESETBAD(c); ' : ' $c() = 0.25; /* check for floatiness */ if($c() == 0) { $c() = -1; /* put a nonsensical value in */ } else { $c() = sqrt(-1); /* NaN if possible */ } ') . ' } ', BadCode => '$GENERIC() cur; PDL_Indx curind; int flag = 0; /* should set curind to -1 and check for that, then do not need flag */ loop(n) %{ if( $ISGOOD(a()) && (!flag || $a() '.$op.' cur)) {cur = $a(); curind = n; flag = 1;} %} if ( flag && !IsNaN(cur) ) { $c() = curind; } else { $SETBAD(c()); $PDLSTATESETBAD(c); }', CopyBadStatusCode => '', Doc => "Like $name but returns the index rather than the value", BadDoc => 'Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output piddle.', ); pp_def( "${name}_n_ind", HandleBad => 0, # just a marker Pars => 'a(n); indx [o]c(m);', Code => '$GENERIC() cur; PDL_Indx curind; register PDL_Indx ns = $SIZE(n); if($SIZE(m) > $SIZE(n)) $CROAK("n_ind: m_size > n_size"); loop(m) %{ curind = ns; loop(n) %{ PDL_Indx nm; int flag=0; for(nm=0; nmnm) == n) {flag=1; break;} } if(!flag && ((curind == ns) || $a() '.$op.' cur || IsNaN(cur))) {cur = $a(); curind = n;} %} $c() = curind; %}', Doc => "Returns the index of C $name elements", BadDoc => 'Not yet been converted to ignore bad values', ); } # foreach: $which pp_addpm("*PDL::maxover = \\&PDL::maximum;\n"); pp_addpm("*maxover = \\&PDL::maximum;\n"); pp_add_exported('PDL::PP maxover'); pp_addpm(<<'EOD'); =head2 maxover =for ref Synonym for maximum. =cut EOD pp_addpm("*PDL::maxover_ind = \\&PDL::maximum_ind;\n"); pp_addpm("*maxover_ind = \\&PDL::maximum_ind;\n"); pp_add_exported('PDL::PP maxover_ind'); pp_addpm(<<'EOD'); =head2 maxover_ind =for ref Synonym for maximum_ind. =cut EOD pp_addpm("*PDL::maxover_n_ind = \\&PDL::maximum_n_ind;\n"); pp_addpm("*maxover_n_ind = \\&PDL::maximum_n_ind;\n"); pp_add_exported('PDL::PP maxover_n_ind'); pp_addpm(<<'EOD'); =head2 maxover_n_ind =for ref Synonym for maximum_n_ind. =cut EOD pp_addpm("*PDL::minover = \\&PDL::minimum;\n"); pp_addpm("*minover = \\&PDL::minimum;\n"); pp_add_exported('PDL::PP minover'); pp_addpm(<<'EOD'); =head2 minover =for ref Synonym for minimum. =cut EOD pp_addpm("*PDL::minover_ind = \\&PDL::minimum_ind;\n"); pp_addpm("*minover_ind = \\&PDL::minimum_ind;\n"); pp_add_exported('PDL::PP minover_ind'); pp_addpm(<<'EOD'); =head2 minover_ind =for ref Synonym for minimum_ind. =cut EOD pp_addpm("*PDL::minover_n_ind = \\&PDL::minimum_n_ind;\n"); pp_addpm("*minover_n_ind = \\&PDL::minimum_n_ind;\n"); pp_add_exported('PDL::PP minover_n_ind'); pp_addpm(<<'EOD'); =head2 minover_n_ind =for ref Synonym for minimum_n_ind =cut EOD # removed IsNaN handling, even from Code section # I think it was wrong, since it was # # if (!n || ($a() < curmin) || IsNaN(curmin)) {curmin = $a(); curmin_ind = n;}; # if (!n || ($a() > curmax) || IsNaN(curmax)) {curmax = $a(); curmax_ind = n;}; # # surely this succeeds if cur... is a NaN?? # pp_def( 'minmaximum', HandleBad => 1, Pars => 'a(n); [o]cmin(); [o] cmax(); indx [o]cmin_ind(); indx [o]cmax_ind();', Code => '$GENERIC() curmin, curmax; PDL_Indx curmin_ind, curmax_ind; curmin = curmax = 0; /* Handle null piddle --CED */ loop(n) %{ if ( !n ) { curmin = curmax = $a(); curmin_ind = curmax_ind = n; } else { if ( $a() < curmin ) { curmin = $a(); curmin_ind = n; } if ( $a() > curmax ) { curmax = $a(); curmax_ind = n; } } %} $cmin() = curmin; $cmin_ind() = curmin_ind; $cmax() = curmax; $cmax_ind() = curmax_ind;', CopyBadStatusCode => '', BadCode => '$GENERIC() curmin, curmax; PDL_Indx curmin_ind, curmax_ind; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) ) { if ( !flag ) { curmin = curmax = $a(); curmin_ind = curmax_ind = n; flag = 1; } else { if ( $a() < curmin ) { curmin = $a(); curmin_ind = n; } if ( $a() > curmax ) { curmax = $a(); curmax_ind = n; } } } /* ISGOOD */ %} if ( flag ) { /* Handle null piddle */ $cmin() = curmin; $cmin_ind() = curmin_ind; $cmax() = curmax; $cmax_ind() = curmax_ind; } else { $SETBAD(cmin()); $SETBAD(cmin_ind()); $SETBAD(cmax()); $SETBAD(cmax_ind()); $PDLSTATESETBAD(cmin); $PDLSTATESETBAD(cmin_ind); $PDLSTATESETBAD(cmax); $PDLSTATESETBAD(cmax_ind); }', Doc => ' =for ref Find minimum and maximum and their indices for a given piddle; =for usage pdl> $a=pdl [[-2,3,4],[1,0,3]] pdl> ($min, $max, $min_ind, $max_ind)=minmaximum($a) pdl> p $min, $max, $min_ind, $max_ind [-2 0] [4 3] [0 1] [2 2] See also L, which clumps the piddle together. =cut ', BadDoc => 'If C contains only bad data, then the output piddles will be set bad, along with their bad flag. Otherwise they will have their bad flags cleared, since they will not contain any bad values.', ); # pp_def minmaximum pp_addpm("*PDL::minmaxover = \\&PDL::minmaximum;\n"); pp_addpm("*minmaxover = \\&PDL::minmaximum;\n"); pp_add_exported('PDL::PP minmaxover'); pp_addpm(<<'EOD'); =head2 minmaxover =for ref Synonym for minmaximum. =cut EOD pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz) and Karl Glazebrook (kgb@aaoepp.aao.gov.au). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.018/Bugs.pod0000644060175006010010000001101413036512174011777 0ustar chmNonepackage PDL::Bugs; # How to get help diagnosing PDL problems and # how to make and submit a useful bug report __END__ =pod =head1 NAME PDL::Bugs - How to diagnose and report PDL problems =head1 VERSION version 1.0000 =head1 DESCRIPTION This module explains how to get help with a PDL problem and how, when, and where to submit a bug report. In the future it may be extended to provide some sort of automated bug reporting capability. =head1 IF YOU HAVE A PDL PROBLEM The primary resource for support for the Perl Data Language is via the PDL mailing lists. The pdl-general list is for general use and discussions and is the one to use for questions about problems with PDL or PDL use for computation. This I the list to post to for PDL problems. The pdl-devel list is I for PDL development and often contains discussions of a rather technical nature relating to PDL internals. This is I the list for general PDL discussion or questions. http://pdl.perl.org/?page=mailing-lists B: Both pdl-general and pdl-devel are read by the PDL developers so you don't save time or increase the probability of response by posting to pdl-devel or by cross-posting to pdl-devel. Please stick to pdl-general list posts unless you want to talk PDL implementation and development. B: There is also a PDL IRC channel which can be useful for immediate questions if populated. However, it has the big disadvantage of not being easily searched or routinely read by all PDL developers and users. As a result, if you get an answer there, it may be incorrect or incomplete depending on who happens to be chatting at the time. It is definitely not readily searchable. =head1 REPORTING BUGS Please submit bug reports via the sourceforge bug tracker interface at http://sourceforge.net/p/pdl/bugs/ where you can review the previously submitted bug reports. Click on C to generate a bug report. If you do not already have a sourceforge.net account, you will need to get one to submit the report: http://sourceforge.net/account/registration/ Please provide a way for the PDL developers to contact you regarding the problem. Try to include any information you think might help someone isolate, reproduce, and fix your problem. At a I, include the following information: =over =item * PDL version number (e.g. PDL-2.007) =item * Perl version information. Output from C or C (even better!) =item * Your operating System. You can run the C command on many unix systems =item * The full output of C If you are reporting a bug with an already installed PDL. If the PDL has compiled and built but not been installed, you may run C from the top level of the PDL build directory. =item * The bug description and how to reproduce it. Short examples using the PDL shells, C or C, are excellent! Don't forget to include needed input data (as small as possible) so that the code can be run with a cut and paste. =back Other things that are often helpful: =over =item * Details about your operating environment that might be related to the problem =item * Exact cut and pasted error or warning messages =item * The shortest, clearest code you can manage to write which reproduces the bug described. =item * A patch against the latest released version of this distribution which fixes this bug. =back Alternatively, send an e-mail report with the above information (including the output of C) to C. See http://pdl.perl.org/?page=mailing-lists for info on how to subscribe to this list. =head1 BEFORE YOU SEND A REPORT BEFORE you report a bug make sure you got the latest release version of PDL, always available from CPAN, check http://search.cpan.org/search?dist=PDL Also, you can check the FAQ at http://pdl.perl.org/?docs=FAQ&title=PDL::FAQ and the mailing list archives for hints. You can find links to the searchable archives at http://pdl.perl.org/?page=mailing-lists and there is a Google enable search box on the top right of L which usually gives the best results. =head1 PATCHES Patches can be sent to the pdl-devel mailing list (see above) or can be directly submitted to the patch manager http://sourceforge.net/p/pdl/patches/ Patches should be made against the latest released PDL or, ideally, against the current git sources which you can browse and check out at git://git.code.sf.net/p/pdl/code Thanks, The PDL developers. =cut PDL-2.018/Changes0000644060175006010010000026672013110400131011664 0ustar chmNonev2.018 2017-05-21 17:02:03-04:00 General Notes: * This is version 2.018 of the Perl Data Language. Highlights: * SF.net Bugs fixed: 429 Alien::Proj4->load_projection_information parses PJ_sch parameters incorrectly 432 Work around List::MoreUtils bug t/gd_oo_test.t started failing in testers. 433 GSL SF errors kill perl and pdl2/perldl shell 434 Missing indx type in heading list of conversions. * Build improvements: - Add requirements and better test diags for PDL::IO::GD. - Apppy patch so PDL::Lite can be used more than once Thanks to Shawn Laffan for the patch. - Fix build on perl <= 5.14 by adding ExtUtils::ParseXS to CONFIGURE_REQUIRES. - Make coretarget generate parallelisable make deps Make "core" target be generated by separate function - Fixes for coming removal of . from @INC for PDL build. Thanks to Todd Rinaldo for the first patch and raising the issue. * Various updates to the documentation. v2.017_02 2017-05-18 17:33:55-04:00 General Notes: * This is version 2.017_02 of the Perl Data Language, and essentially PDL 2.018 release candidate 1. If it tests ok we expect to release it as PDL 2.018 this weekend. Highlights: * Fix problem where PDL::Lite could not be loaded more than once. (Thanks to Shawn Laffan) * Fix sf.net bug #429 with poor generation of documentation. * Fix sf.net bug #433 where errors in GSL routines caused perl to exit. * Build enhancements for PDL::IO::GD to improve test diagnostic messages and add List::MoreUtils as a dependency for PDL. * Better docs and explanation of indx datatype. This closes sf.net bug #434. * Add some missing modules to DEPENDENCIES (thanks to Luis Mochan). v2.017_01 2017-04-29 11:39:22-04:00 General Notes: * This is version 2.017_01 of the Perl Data Language, * Addresses some problems from changes in the perl infrastructure that are or will break things in PDL. Highlights: * Handle coming removal of '.' from @INC * Fix sf bug #432: Work around List::MoreUtils bug This was causing a lot of PDL test failures. * Fix build problem on perl <= 5.14 v2.017 2016-10-08 13:50:39-04:00 General Notes: * This is version 2.017 of the Perl Data Language, * Bugs fixed: 379 Passing qsort an extra argument causes a segfault 393 Tests may fail if perl is compiled with -Duselongdouble 409 PDL demos with PGPLOT display ignore $ENV{PGPLOT_DEV} 413 PDL::Core::Dev::pdlpp_postamble() cannot handle .pd files in subdirectories 419 t/#pdl_from_string.t fails on long double systems 421 PDL::IO::FITS can't handle 64-bit integers (longlong, indx) 422 PDL misc. compiler warnings. 423 wcols FORMAT option always incorrectly gives error 424 Calling PDL on a list of piddles fails to propogate bad values 425 svd is broken for everything but 2x2 matrices --- Typo in PDL::GSLSF::COUPLING routine gsl_sf_coupling_6j Highlights: * Several patches contributed from the Debian team have been applied that fix documentation spelling errors, make PDL builds more reproducible, and will make packaging PDL easier. * More helpful error message when multi-element PDL is used in a boolean expression (feature request #84) * Improve argument size handling and documentation for rle (feature request #80) * One can now use $pdlc = pdl($pdla,$pdlb) when $pdla and/or $pdlb have BAD values and the BAD values will propagate to $pdlc. Previously this would only work with a copy of a single piddle (e.g., $pdlc = pdl($pdla) ) or with 'cat'. * Many changes have been made to make PDL compile more cleanly and emit fewer compiler warnings. * Quiet printf format warning for sizeof() * Deprecate finite in favor of isfinite. * Many cleanups and additions to the test suite to use Test::More and to add meaningful test descriptions. * Added subtests to primitive.t * Add PDL::Doc::add_module to pdlpp_postamble v2.016_91 2016-10-03 14:03:19-04:00 General Notes: * This is version 2.016_13 of the Perl Data Language, a.k.a. PDL-2.017 release candidate 1. * All but release notes and announcement done... Highlights: * Added subtests to primitive.t * Quiet printf format warning for sizeof() v2.016_03 2016-10-01 17:51:40-04:00 General Notes: * This is version 2.016_03 of the Perl Data Language. Highlights: * Bugs fixed: 413 PDL::Core::Dev::pdlpp_postamble() cannot handle .pd files in subdirectories 419 t/#pdl_from_string.t fails on long double systems * More helpful error message when multi-element PDL is used in a boolean expression (feature request #84) * Improve argument size handling and documentation for rle (feature request #80) v2.016_02 2016-09-21 13:42:15-04:00 General Notes: * This is version 2.016_02 of the Perl Data Language. * Bugs fixed: 379 Passing qsort an extra argument causes a segfault 393 Tests may fail if perl is compiled with -Duselongdouble 409 PDL demos with PGPLOT display ignore $ENV{PGPLOT_DEV} 421 PDL::IO::FITS can't handle 64-bit integers (longlong, indx) 422 PDL misc. compiler warnings. 423 wcols FORMAT option always incorrectly gives error 424 Calling PDL on a list of piddles fails to propogate bad values 425 svd is broken for everything but 2x2 matrices --- Typo in PDL::GSLSF::COUPLING routine gsl_sf_coupling_6j Highlights: * One can now use $pdlc = pdl($pdla,$pdlb) when $pdla and/or $pdlb have BAD values and the BAD values will propagate to $pdlc. Previously this would only work with a copy of a single piddle (e.g., $pdlc = pdl($pdla) ) or with 'cat'. * Many changes have been made to make PDL compile more cleanly and emit fewer compiler warnings. * Many cleanups and additions to the test suite to use Test::More and to add meaningful test descriptions. * Several patches contributed from the Debian team have been applied that fix documentation spelling errors, make PDL builds more reproducible, and will make packaging PDL easier. v2.016_01 2016-06-01 13:01:55-04:00 General Notes: * This is version 2.016_01 of the Perl Data Language. Highlights: * Add PDL::Doc::add_module to pdlpp_postamble * Deprecate finite in favor of isfinite. v2.016 2016-05-30 10:22:04-04:00 General Notes: * This is version 2.016 of the Perl Data Language. * Bugs fixed: 417 Perl 5.22: + GSL 2.1 fails to build 408 PDL::GSL::RNG set_seed minor improvement 407 Build failures with GSL 2.1 416 PDL::PP creates .pm & .xs files before pp_done is called 414 ccNcompt (i.e. cc4compt and cc8compt) breaks with byte data type Highlights: * All collapse operators now have "over" equivalent names. This ends an API wart in which most, but not all, of the collapse operators had a short form that did full collapse and a long form that did 1-D collapse only (e.g. "and" collapses to a point, while "andover" collapses by one dimension). The exceptions are left in for legacy code, but now have regularized "-over" forms as well: average -> avgover daverage -> davgover maximum -> maxover maximum_ind -> maxover_ind maximum_n_ind -> maxover_n_ind minmaximum -> minmaxover minimum -> minover minimum_ind -> minover_ind minimum_n_ind -> minover_n_ind * PDL::Transform image resampling now handles bad values in images. In particular, the `h' and `j' (optimized filter) resampling methods properly skip bad values in the image, marking output pixels bad if more than 1/3 of the weighted values associated with that output pixel are bad. * PDLs with dataflow can now be reshaped. The dataflow connection gets severed by the reshape operation. * PDL::IO::FITS now works better with RICE-compressed FITS images, such as are produced by NASA's SDO project. - The NAXIS* header keywords are now replaced by their ZNAXIS* equivalents, so the NAXIS fields in the header are correct after the image is read in. - The Z*, TFIELDS, TTYPE*, and TFORM* keywords are now deleted from the header object, so that the uncompressed, loaded image does not have leftover compression headers. * The language preprocessor PDL::PP now does not automatically call pp_done for modules that do not call pp_done themselves. This new, stricter behavior requires module authors to call pp_done at the end of their PDL::PP file. This prevents partially-complete .xs and .pm files from being written if there is a module build error. * PDL::GSLSF modules have several fixes/improvements to support building against GSL 2.0: - New calling convention for gsl_sf_ellint_D. - New functions gsl_sf_legendre_array and gsl_sf_legendre_array_index. - Deprecated gsl_sf_legendre_Plm_array and gsl_sf_legendre_sphPlm_array. - New tests for new legendre functions. - Test requires all PDL::GSLSF modules to successfully load. * PDL::GSL::RNG now allows chaining for the set_seed() method: e.g. $rng = PDL::GSL::RNG->new(..)->set_seed(..) * PDL::Image2D's ccNcompt connected-component analysis code now returns types that are >= long, to avoid common overflow errors. * PDL::whichND returns PDLs of Indx type, to avoid overflows. * Empty piddles are handled slightly differently now by PDL::info and `help vars'. Empty piddles are different from null piddles, and now generate different info strings. (null piddles lack data or dimensions; empty piddles have at least one dimension of size 0). * PDL::Fit::LM: - Documentation has been clarified relating to input data uncertainties and weighting of the fit. - A small test suite has been added. * There is now a .gitattributes file so GitHub repo language stats are more accurate. * The PDL SF/GitHub deveolpment workflow is integrated into the DEVELOPMENT docs. v2.015_001 2016-05-27 12:28:39-04:00 General Notes: * A.k.a PDL-2.016 release candidate 1. Highlights: * TBD v2.015 2015-11-22 08:52:22-05:00 General Notes: * PDL-2.015 is a clean and polish release. It fixes some problems discovered with PDL-2.014 and improves the 64bit integer support. Highlights: * Fixes to improve compile and test of F77 modules on OS X (i.e. don't build i386 versions) * Basic/Ops/ops.pd - make compatible with MSVC++ 6.0 * Fix win10 breakage in t/flexraw_fortran.t Apparently, temp files were not being released after use which was preventing the tests to pass. * Fix missing PDL license information * Fix sf.net bug #403: reshape() failed when applied to a piddle with dataflow. Now, changing the shape of a PDL that already has dataflow is prevented and an error message given. * Fix sf.net bug 406 Added missing logic for clump(-N) and minor cleanup of perl wrapper. * force new_pdl_from_string to return a piddle with P=physical flag * Add $PDL::indxformat for PDL_Indx This avoids loss of significance when 64bit PDL_Indx values are printed. Make new_pdl_from_string() avoid converting IV values to NVs This allows pdl(indx, '[ 9007199254740992 ]') to work without rounding due to the 52bit double precision mantissa versus the 63bits + sign for PDL_Indx. * Add type support info to pdl() constructor documentation. pdl() has always supported this usage but examples were missing in the documentation. * improving PDL::GSL::RNG documentation * remove spurious '}' from gnuplot demo v2.014_03 2015-11-19 12:37:00-05:00 General Notes: * This quick release is to verify the fix for the PDL license information. Highlights: * Some updates to Changes and Known_problems as well. v2.014_02 2015-11-17 09:20:23-05:00 General Notes: * This is the 2nd release candidate for PDL-2.015 Highlights: * Same as PDL-2.014_01 but with a couple of F77 build fixes from Karl to support MacOSX builds and, we hope, a SciPDL to go with PDL-2.015! v2.014_01 2015-11-14 14:01:28-05:00 General Notes: * This is PDL-2.014_01, a cleanup and bug fix release. Highlights: * Add $PDL::indxformat for PDL_Indx and Make new_pdl_from_string() avoid converting IV values to NVs PDL_Indx values (type indx) now print with an integer format specification so all digits get printed. In addition pdl(indx, '[ 9007199254740992 ]') works as well going the other direction. * Fix sf.net bug 403: reshape can't handle piddles with -C flag reshape() on a piddle with dataflow isn't meaningful. Now a warning is given. You can $pdl->sever first and then reshape() can be applied. * Fix sf.net bug 406: clump() produces bogus dims * Various build improvments and documentation fixes: - force new_pdl_from_string to return a piddle with P=physical flag - remove spurious '}' from gnuplot demo - Basic/Ops/ops.pd - make compatible with MSVC++ 6.0 - Fix win10 breakage in t/flexraw_fortran.t - improving PDL::GSL::RNG documentation - Add type convert info to POD for the pdl() constructor v2.014 2015-10-12 11:44:10-04:00 General Notes: * This is PDL-2.014 introducing full support for 64bit indexing operations using 64bit PDL_Indx data type. * PDL can now create and use piddles having more than 2**32 elements. Of particular use is that you can now use PDL::IO::FlexRaw to memory map piddles from files on disk which can allow for simplified processing and IO on extremely large data. * Due to the new PDL_Anyval type changes, existing PDL::PP modules may need to be updated to support the new PDL Core version 12 API. Authors, please see PDL::API for macros to ease the porting. Users, be aware that some modules may not work until they are updated by their maintainers. Highlights: * Implement PDL_Anyval data type as union to support 64bit indexing This adds a union data type to add 64bit integer support to the original PDL-2.x types which assumed that double was capable of holding all the "lesser" types. With the PDL_Anyval type, we can correctly handle 64bit integer data types and avoid errors and loss of precision due to conversions to or from PDL_Double. Special thanks to kmx and zowie for their help to complete and debug this implementation. * Many fixes to the build process to make PDL more robust to build, test, and install. This takes advantage of new automated CI testing via Travis CI on the github site. Thanks much to Ed and Zakariyya for their work to get this started and maintained. This CI testing makes this the best tested and best testing PDL release ever! * Various documentation clean-ups and work to improve on-line viewing at http://metacpan.org and others. (Thanks kmx and Derek!) * A new ipow() method haw been added with 64bit integer support. ipow() calculates the integer exponentiation of a value by successive multiplications. This allows one to avoid loss of significance in integer exponents. pow() converts the value to double and will always have <52bits precision. * nbadover and ngoodover now return indx type (PDL_Indx) * PDL now detects when your perl installation has been built with floating point longer than 8 bytes and gives a one time warning that precision will be lost converting from perl NV to PDL_Doubles. This warning is given on "use PDL;" * "use PDL" now includes "use PDL::IO::Storable" This avoids a hard to diagnose crash that can occur when a user tries using Storable without the necessary "use PDL::IO::Storable". * MANY sf.net bugs fixed: 400 dataflow slice crash around 2**31 boundary 399 Small doc fixes 398 $pdl->hdr items are lost after $pdl->reshape 396 online docs for modules only work first time in PDL shells 395 ipow (integer exponentiation) support for 64bit index support 394 demo cartography fails 383 gcc/#gfortran 4.9.2 needs -lquadmath 378 where on dice of pdl bad results 376 PDL Segmentation fault working with Storable restored PDL 347 t/#pdl_from_string.t has a failure if BADVAL_NAN=1 346 ExtUtils::F77 dependency causing problems for CPAN install 343 longlong constructor and display lose digits due to... 340 orover of byte data returns long type v2.013_06 2015-10-10 16:04:14-04:00 General Notes: * This is PDL-2.013_06 which is RC 2 for PDL-2.014 and likely the final one before the official release. Please report any final issues and doc patches ASAP. Highlights: * Mark some failing tests in t/primitive.t as TODO to avoid CPAN Testers failures. * Add IPC::Cmd to TEST_REQUIRES v2.013_05 2015-10-08 07:14:19-04:00 General Notes: * This is PDL-2.013_05 (a.k.a. PDL-2.014 rc 1) which is the fifth CPAN developers release for PDL with newly completed support for 64bit indexing. * Needs testing for piddles with more than 2**32 elements but all checks pass so far. Highlights: * Fix problem with broken t/opengl.t for testers v2.013_04 TBD General Notes: * This is PDL-2.013_04 which is the fourth CPAN developers release for PDL with newly completed support for 64bit indexing. * Needs testing for piddles with more than 2**32 elements but all checks pass so far. Highlights: * t/opengl.t is skipped the dynamic GL window creation tests if $AUTOMATED_TESTING is true. * A new ipow() routine for integer exponentiation * Corrected return types of intover, borover, bandover, nbadover, and ngoodover. * Fixed compile problem in clang from using finite() on an integer datatype. v2.013_03 2015-10-04 12:21:30-04:00 General Notes: * This is PDL-2.013_03 which is the third CPAN developers release for PDL with newly completed support for 64bit indexing. * Needs testing for piddles with more than 2**32 elements but all checks pass so far. Highlights: * More clean-up to handle perls with long double NVs Loss of precision will be warned on "use PDL;" * Skipping t/bigmem.t to avoid OOM CPAN Testers fails. * Minor fixes to C code to meet stricter compiler and C99 requirements. v2.013_02 2015-10-03 08:40:08-04:00 General Notes: * This is PDL-2.013_02 which is the second CPAN developers release for PDL with newly completed support for 64bit indexing. * Needs testing for piddles with more than 2**32 elements but all checks pass so far. Highlights: * Clean up to handle perls with long double NVs * Various bugs closed * PDL::IO::Storable is now loaded with "use PDL;" v2.013_01 2015-09-26 17:39:41-04:00 General Notes: * This is PDL-2.013_01 which is the first CPAN developers release for PDL with newly completed support for 64bit indexing. * Needs testing for piddles with more than 2**32 elements but all checks pass so far. Highlights: * TBD v2.013 2015-08-14 08:37:15-04:00 General Notes: * This is PDL-2.013. It is PDL-2.012 with some fixes for badvalue problems and Solaris make issues. * See PDL 2.012 notes below. Highlights: * Fix for sf.net bug #390: scalar PDL with badvalue always compares BAD with perl scalars. Now a warning is given if the badvalue could conflict with the results of a logical or comparision operation. * Fixed a makefile construct which was ambiguous and caused build failures on Solaris using their make. Gnu make was not affected even on Solaris. v2.012_01 2015-08-01 15:47401-0400 General Notes: * This is PDL-2.012_01. It is PDL-2.012 with some fixes for badvalue problems when the badvalue was 0 or 1. * See PDL 2.012 notes below. Highlights: * Candidate fix for sf.net bug #390: scalar PDL with badvalue always compares BAD with perl scalars v2.012 2015-06-14 08:27:01-0400 General Notes: * This is PDL-2.012 it is essentially PDL-2.011 with some fixes for some minor issues that only came to light with a new official release. * See PDL 2.011 notes below. Highlights: * Add package statements so PDL::Lite and PDL::LiteF are indexed correctly * Give PDL::NiceSlice a non-developer release for indexing * Fix build regression that broke ActiveState perl builds for many perl versions and OS platforms. v2.011 2015-06-02 17:01:22-0400 General Notes: * This is PDL-2.011 it is essentially PDL-2.008 with some fixes for some minor issues. * perl 5.10.x is now the minimum version of perl supported by PDL-2.008 and later. * PDL::FFTW is no longer part of the PDL Core. Please use PDL::FFTW3 from CPAN (Dima Kogan) with Alien::FFTW3 support (Craig DeForest) * PDL::Graphics::PLplot is no longer included in the PDL core distribution. Please install from CPAN directly. * 50 sf.net bug tickets closed/fixed since PDL-2.007! * Partial 64bit indexing support with some fixes to remaining issues. Full 64bit support for perl modulus operater ('%') is in progress. * Major clean up and rework of the core PDL computation code, the build process, test suites, and updating to reflect more of the best practices for perl module development. * The PDL development has moved to github and now has added continuous commit testing via the Travis-CI framework. The git workflow is now inline with current practices and it is expected that this will allow more contributions and "eyes on the code". Highlights: * See PDL 2.008 Highlights below. v2.010 2015-06-02 14:40:15-0400 General Notes: * Another indexing regression. Sigh. v2.009_01 2015-05-29 17:47:57-0400 General Notes: Highlights: * Removal of PDL::Graphics::PLplot since exists as separate CPAN distro v2.009 2015-05-29 12:26:25-0400 General Notes: * This is PDL-2.009. It has tweaks to fix PAUSE/CPAN indexing problems in 2.008. * Known_problems updated to reflect a seldom seen pdldoc installation problem for certain custom perl configurations on cygwin. A workaround is known. Please contact the PDL mailing list if you have this problem. See the sf.net bug report at http://sourceforge.net/p/pdl/bugs/384/ for more information. * See Release Notes for PDL 2.008 below for more. v2.008 2015-05-24 18:42:22-0400 General Notes: * This is PDL-2.008! Yay! * perl 5.10.x is now the minimum version of perl supported by PDL-2.008 and later. * 50 sf.net bug tickets closed/fixed since PDL-2.007! * Partial 64bit indexing support with some fixes to remaining issues. Full 64bit support for perl modulus operater ('%') is in progress. * Major clean up and rework of the core PDL computation code, the build process, test suites, and updating to reflect more of the best practices for perl module development. * The PDL development has moved to github and now has added continuous commit testing via the Travis-CI framework. The git workflow is now inline with current practices and it is expected that this will allow more contributions and "eyes on the code". Highlights: * PDL::FFTW is no longer part of the PDL Core. Please use PDL::FFTW3 from CPAN (Dima Kogan) with Alien::FFTW3 support (Craig DeForest) * New improved vsearch functionality, interfaces, and documentation (Diab Jerius) * PDL::IO::Storable now robust against version, platform endianness, and supports the new 64bit PDL_Indx data type (Dima Kogan) * Clean up of PDL/Basic/Core code to remove cruft and to simplify the evolution to a coming improvements (Craig DeForest) * Major clean up, de-crufting, and streamlining of the entire PDL ExtUtils::MakeMaker build process (Ed J) * Standardizing and updating the entire PDL test suite to a common basis (use Test::More) and coding to more consistent best practices. E.g., use strict This is a huge (ongoing) effort but a comprehensive test suite is needed for regression tests to validate compatibility of coming PDL3 architecture changes. (Zakariyya Mughal) * You can now call the PDL::Graphics2D twiddle() routine with an argument of 0 or 1 (i.e., false or true) to set whether the twiddle loop is run. * Library dependency detection improvements including PROJ4 and GD. A number of improvements in this for strawberry perl on windows (kmx) * The PDL distribution process now generated the documentation for the modules using the automated code generation process. This makes all the PDL docs available on http://search.cpan.org and on http://metacpan.org for your web browser. (kmx) * Improved support to build XS/C extensions: (Ed J) - You can now: "use Inline with => 'PDL';", see PDL::API - You can, in your module's Makefile.PL: "$p = new ExtUtils::Depends 'MyMod', 'PDL'" * MANY sf.net tickets closed: 377 PDL::Transform::Proj4 not building under latest dev EUMM 375 Storable files incorrectly processed from older versions. 374 CONFIGURE_REQUIRES => Devel::CheckLib 373 2.007_11 MANIFEST 372 2.007_11 fails on MS Windows 64bit 371 PDL-2.4.11 medover failure in perl 5.20.1 370 PDL-2.007 can fail to build Basic/#Core files 369 slice fails with subclass index 368 PDL::Slatec::polyfit ignores incorrect length of weight piddle... 367 BAD value parsing breakage 365 CPAN PDL install broken due to breakage in Module::Compile 0.34 363 PP "OtherPars" namespace is not clean 362 rcols COLIDS need chomp-ing 361 vsearch bug w/# reversed list 360 subtle & rare bug in vsearch 359 Improved documentation for vsearch 358 one2nd() has unexpected behaviour when given a Perl scalar rather than a piddle 357 Android support 356 overload::Method() does not return coderef for stringification 355 dog creates 0 dim piddle which squeezes to 1 dim. 353 imag2d not 'use warnings' safe and no way to disable twiddle 352 reorder() not an lvalue sub 351 PDL_BOOT has wrong XS code 350 Modules using PDL::Slatec will get installed even if Slatec is disabled 349 PDL needs integrated support for PDL::PP and CPAN indexer 348 PDL->null->slice('')->nelem results in error 345 documentation of WITH_PLPLOT in perldl.conf incorrect 344 Current version numbering is broken 342 BUGS file not indexable or discoverable 337 rangeb() broken for 64bit index support on 32bit perl 332 "isn't numeric in null operation" warning could be more helpful 331 uniq does not always return proper object 329 t/#picrgb.t fails in PDL build 321 Several core modules do not have man pages 319 PDL::Index does not render on websites 316 plplot.t failure when building 2.4.11 314 conv1d bad value broken 313 clip() edge case not handled right 312 Wrong results in corner empty-set cases 283 PDL::IO::FITS::wfits corrupting FITS image 272 indexND of Empty pdls can segfault 268 PLplot still unusable with X 261 max() fails on nan 256 Threadable version of PDL::MatrixOps::inv 232 perl -d chokes on lvalue functions 227 PGPLOT module doesn't work in PDL 224 Ctrl-C kills perldl in win32 console 207 Name "PDL::SHARE" used only once. 63 Unable to get the 3d demos 51 justify option fails in imag (PDL2.3.4) v2.007_17 2015-05-06 13:35:57-0400 General Notes: * This is PDL-2.008_rc4! Highlights: * Clean up of large number modulo tests and make TODO for the PDL-2.008 release. * Fix build/configure problems from CPAN Testers reports. * Quiet excessive warnings in perldl and pdl2doc v2.007_16 2015-04-22 10:23:46-0400 General Notes: * This is PDL-2.008_rc3! Highlights: * Various clean up and doc fixes * Add more of the PDL prerequisites explicitly to handle missing core functionality for CPAN Testers. v2.007_15 2015-04-19 17:08:55-0400 General Notes: * This is PDL-2.008_rc2! Highlights: * Build issues with PROJ4 detection and link with cygwin platforms has been worked around. * Failing tests in t/ops.t for new 64bit modulus support have been marked TODO. v2.007_14 2015-04-11 14:28:07-0400 General Notes: * This is PDL-2.008_rc1! Highlights: * More cleanup and a couple of build issues fixed with PROJ4. * Various test suite improvements. v2.007_13 2015-03-22 16:00:03-0400 General Notes: * Counting down to a PDL-2.008 release this April 2015 Highlights: * Travis on Github now routinely tests on dev ExtUtils::MakeMaker, clang: https://travis-ci.org/PDLPorters/pdl * Coveralls on Github now lists test coverage: https://coveralls.io/r/PDLPorters/pdl * Many tests updated to use Test::More, Test::Deep, Test::Exception * PDL::FFTW is now removed from the PDL core. Use PDL::FFTW3 instead. * Prototype use of Alien::Proj4 to encapsulate install/build info * Fix warnings compiling under clang * Addition of "core" and "coretest" targets for quicker build and dev cycle * Make Filter::Util::Call the default engine for PDL::NiceSlice * Make PDL_Anyval type, for 64-bit purposes * Clean up and better-comment pdl*.h * Make "isn't numeric in null operation" warning more helpful v2.007_12 2015-03-06 09:18:04-05:00 General Notes: * Counting down to a PDL-2.008 release this February 2015 * This release marks the completion of almost all the priority issues needed for PDL-2.008. Expect feature freeze, final shakedown, and release to come! Highlights: * Fixed sf.net bug #373 2.007_11 MANIFEST * Implemented 'core' and 'coretest' targets for quick testing. * Fix quote/whitespace build problems * Fix threading problem discovered in PDL::MatrixOps::inv() * Build improvements and support for automated commit testing via the travis-ci infrastructure * Fixed sf.net bug #368 PDL::Slatec::polyfit ignores incorrect length of weight piddle * Fixed sf.net bug #374 CONFIGURE_REQUIRES => Devel::CheckLib * Tests and fixes for modulus operator for 64bit integer operands. Tests on 32bit systems welcome. * Lots of tweaks and cleanup... v2.007_11 2015-02-24 16:08:36-05:00 General Notes: * Counting down to a PDL-2.008 release this February 2015 Highlights: * The new Filter::Simple engine for PDL::NiceSlice is now the default. This fixes problems where PDL::NiceSlice was applying the sourcefilter to the content of comments and strings. Still to do: implement for command line use in perldl/pdl2 shells. * Added ability to call PDL::Graphics2D twiddle() routine with an argument of 0 or 1 (technically false or true) to set whether the twiddle loop is run. Also fixed a minor warning generated with 'use warnings'. This closes bug #353. * Lots of clean up and build process improvements. v2.007_10 2015-02-02 10:59:22-05:00 General Notes: * Counting down to a PDL-2.008 release this February 2015 Highlights: * More clean up to build process. v2.007_09 2015-01-29 11:01:24-05:00 General Notes: * Counting down to a PDL-2.008 release this February 2015 Highlights: * perl 5.10.x is now the minimum version of perl supported for this release. Please test. * Much clean up of the EU::MM build process by Ed.:w v2.007_08 2015-01-20 18:24:01-05:00 General Notes: * Counting down to a PDL-2.008 release this January 2015 Highlights: * Some ExtUtils::MakeMaker fixes and clean up for the PDL build process. * Fix non-portable usage bug in t/vsearch.t which prevented the test from passing on perls 5.12 and earlier v2.007_07 2015-01-06 17:44:08+11:00 General Notes: * Counting down to a PDL-2.008 release this January 2015 Highlights: * This release includes the new pre-generated pm/pod to clean up the docs available on-line on metacpan.org and search.cpan.org. * Bug fix in t/vsearch.t to support perl 5.12 and earlier. PDL currently supports perl 5.8.x and later. v2.007_06 2015-01-05 13:31:13-05:00 General Notes: * Counting down to a PDL-2.008 release this January 2015 Highlights: * Fixed a number of bugs on the sf.net tracker * Fix for EU-MM-7.0 and later problem with dmake * Include generated pod in the distribution so that metacpan.org and search.cpan.org have better/working online docs. v2.007_05 2014-12-24 09:24:04-05:00 General Notes: Highlights: * You can now: "use Inline with => 'PDL';" - see PDL::API * You can, in your module's Makefile.PL: "$p = new ExtUtils::Depends 'MyMod', 'PDL'" * Various bugs fixed * New vsearch() implementations with features and flexibility v2.007_04 2014-09-09 00:44:29+01:00 General Notes: Highlights: * You can now: "use Inline with => 'PDL';" - see PDL::API * You can, in your module's Makefile.PL: "$p = new ExtUtils::Depends 'MyMod', 'PDL'" v2.007_03 2014-07-01 16:54:59-04:00 General Notes: Highlights: * Fix documentation builds for installs into vendor directory. * Fixes for library detection on MS Windows * Fix incompatibility of PDL::IO::Storable with perl versions < 5.10.x v2.007_02 2013-11-25 14:10:22-05:00 General Notes: Highlights: * This release should be a working PDL::IO::Storable that is compatable with the new 64bit index support. * PDL::IO::Storable now requires perl 5.10.x or greater although the overall distribution requirements are not planned to update to 5.10.x until the completion of fixes for the longlong hidden double precision conversion slash truncation bug. v2.007_01 2013-11-17 16:31:17-05:00 General Notes: Highlights: * Added FAQ entry on PDL version numbering change and how to specify required PDL versions. * Corrected perldl.conf docs for WITH_PLPLOT in the comments * Update PDL::IO::Storable to work with the new PDL_Indx data type. Also made the code backwards compatible to read files written by older PDL releases. * Fixed NaN handling for min/max and cleaned up handling of empty sets. * Various enhancements to PDL::Transform v2.007 2013-10-12 12:56:52-04:00 General Notes: * PDL computations now use 64bit indexing/addressing if your platform supports it (i.e., your perl configuration has $Config{ivsize} == 8). - You can process with pdls with more then 2**32 elements. - Memory mapped file IO supports up to 8TB files which allows much simpler processing of large data files. (See mapflex in PDL::IO::FlexRaw for details) * PDL-2.007 has a new, unified slicing engine and syntax that consolidates the multiple slicing variants into a backward compatible but now 64bit aware slice. See the PDL::Slices for the new syntax that is enabled. * PDL::FFTW has moved to its own distribution on CPAN and is no longer in the PDL core distribution. Look for PDL::FFTW3 coming to CPAN soon. * Some required dependencies have been update to more recent versions: - ExtUtils::MakeMaker now requires version 6.56 or higher, the minimum version with CONFIGURE_REQUIRES support. - Perl OpenGL 0.6702 is now required for PDL::Graphics::TriD to build. This fixes a number of critical bugs and should be a seamless upgrade. - File::Map version 0.57 is required. This fixes map_anonymous support for the >2**32 sizes needed for 64bit support. Legacy mmap support for unix platforms is no longer supported. The distribution requires File::Map so you should not notice the change. * Incompatible Changes: - PDL::FFT now uses the same sign convention as FFTW and the rest of the world, -1/+1 for forward and reverse FFT respectively. - C/XS API of PDL-2.007 is incompatible with previous PDL releases. If you upgrade to PDL-2.007, you *will* need to re-install or upgrade *all* dependent XS or PP based modules. - PDL now auto-promotes array refs in many places that previously required a piddle (so you can say, e.g., "$a->index([2,3])" instead of "$a->index(pdl(2,3))"). - String syntax for slice() specifications now ignore white space. * The clean up of the PDL core distribution continues and PDL-2.007 is no exception. Many bug fixes, documentation updates, code and implementation improvements make this the best testing PDL release to date. Highlights: * FITS IO improvements and fixes: - Added 'afh" option to rfits to allow explicit use of legacy hash parser for performance reasons. - New multiple extension writing support for wfits. * Added pp_deprecate_module() to PDL::PP * New mode/modeover functions in PDL::Ufunc * Made exception handling in slices more robust. * PDL::CLONE_SKIP added for improved ithread support. * Updated graticule() in PDL::Transform::Cartography to support NaN-delimited output. * Bugs fixes: - Fix %hash randomization bugs in PDL tests - Fix OpenBSD pthread build problem for non-threaded perls - Fix PDL::shape to return vector for 1-D piddles - Fix badvalue-on-truncate support for map and for interpND - Fix for MSVC++ 6.0 to build on 32bit systems. MSVC++ 6.0 cannot be used to build 64bit index support. - Fix polyfit() handling of BAD values and various edge cases. - Fix rare "Bizarre copy of HASH in scalar assignment" - Fix rcols with colsep and $PDL::undefval - Fix sf.net bug #331 "uniq does not always return proper object" - Fix sf.net bug #338 PDL::FFT uses backwards sign convention from FFTW - Make PDL::NiceSlice preserve line numbering (sf.net feature #75) - PDL::IO::GD->new() is now less picky about it args, and no longer crashes - Two bug fixes to transform.pd, and an augmentation v2.006 2013-03-23 10:02:31-04:00 General Notes: * Change to the version number scheme used for PDL from the dotted-integers format back to plain old decimal numbers. Unfortunately, PDL has used both alternatives before and in an inconsistent, out-of-order way. With this release, the current version will also be the most recent version with respect to both numbering schemes. For more details see David Goldens blob post on the topic and the pdl-porters list discussion: http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/ http://mailman.jach.hawaii.edu/pipermail//pdl-porters/2013-February/005343.html * PDL-2.006 also showcases the demos of two new PDL graphics modules in the perldl/pdl2 shells: - PDL::Graphics::Gnuplot http://search.cpan.org/~zowie/PDL-Graphics-Gnuplot-1.4/ - PDL::Graphics::Prima http://search.cpan.org/~dcmertens/PDL-Graphics-Prima-0.13/ Both modules install on all supported PDL platforms. A recent addition is PDL::Graphics::Simple which provides a uniform presentation to the variety off available PDL plot/view/print options. - PDL::Graphics::Simple http://search.cpan.org/~zowie/PDL-Graphics-Simple-1.004/README.pod Let us know how they work for you. As they are relatively "young" contributions your feedback and questions are always welcome. * PDL Distribution related updates: - Fixes a build issue for PDL at ASPerl - Many fixes for debian distributions. - PDL::IO::NDF has been moved to its own distribution on CPAN. This could affect upgrades from older PDL installs. Highlights: * New support for reading IDL format files via PDL::IO::IDL. * Added an unpdl method which is (roughly) the inverse operation of pdl (Joel Berger). * Updated polyfill and polyfillv routines to the algorithm from pnpoly: more accurate on edge pixels and faster due to its PP implementation (Tim Haines). * Added Boundary=>'Replicate' option to conv2d and med2d (chm). * Support for new additional random number generators to PDL::GSL (John Lapeyre). * Add lgamma support for MinGW-built perls with tests to match (sisyphus). * Many improvments to docs and their generation from PDL sources. Specific new functionality support: - Newly refactored docs engine using core perl modules rather than PDL-only ones (Joel Berger) - New FullDoc key added to PDL::PP makes writing CPAN friendly .pd files much, much easier (David Mertens). - New PDL::Doc::add_module() routine to add an external module's POD (with PDL::Doc conventions) to the PDL docs on-line database (Craig DeForest). * Many bugs fixed, some even before a ticket could be opened! - Sf.net bug #3607936: Fixed a bug causing crashes due to using inplace with a duplicate argument. - Sf.net bug #3603249: AutoLoader leaks $_ into local context, reported and fixed by Craig. - Sf.net bug #3588182: Fixed hist() handling of the case of fractional steps in integral input data types. - Sf.net bug #3563903: Fixed bug in PNG format detection on win32 platforms. - Sf.net bug #3544682: Fixed error report bug in perldl that resulted from a change in the way perl handles eval exception reporting. - Sf.net bug #3539760: qsort[vec] are now inplace aware. - Sf.net bug #3518190: Potential fix for t/gd_oo_tests.t test crashes. - Sf.net bug #3515759: Work around for PDL::GIS::Proj build failures with proj-4.8.0. - Sf.net bug #3479009: Fixed dummy() to generate a valid syntax for the underlying call to slice(). - Sf.net bug #3475075: Fixed 16-bit PNM raw format handling. - Added warning if conv1d is used on a piddle with the badflag set. - Fix NaN sign issues as reported (and fixed!) by Matthew McGillis with contributions by Sisyphus. - Fix rim() 3-arg form. Added tests to support and verify the development. - Fixed a problem with multiple windows and imag2d and imag2d_update. * The PDL shells keep getting better: - New feature in perldl and pdl2 where a pattern matching the PDL shell prompt (in $PERLDL::PREFIX_RE) will get stripped off of input lines before eval. This makes it easier to cut-and-paste example text from PDL shell sessions or from the PDL Book into an active session. - Added a demo for PDL::Graphics::Prima to the PDL shells. - Added a demo for gnuplot to the PDL shells. - The p shortcut to display output in the PDL shells has been reverted to its previous 2.4.10 behavior. If you wish it to be an exact alias for print just override in your .perldlrc or local.perldlrc file. v2.4.11 2012-05-20 13:32:17-04:00 General Notes: * This is a point release of PDL to support the coming perl 5.16.0 release. Highlights: * A new implementation mapflex and mapfraw routines provides memory-mapped IO for all platforms including win32 systems. * The new memory mapped IO support is implemented using File::Map so version 0.47 has been added as a required dependency to force automated testing so an automated build will need this dependency installed. NOTE: For systems having POSIX mmap, a manual build of PDL will automatically use the legacy implementation. * Various cleanup to existing code to fix warnings generated by perl versions 5.15.x and higher. Remove deprecation warning in PGPLOT/Window/Window.pm complex.pd - fix attempts to overload '<=>=' and '=>' * Sf.net bugs fixed: 3518253 Make PDL::flat work under perl 5.16 (thanks sprout!) 3516600 pdl_from_string.t fails w/ BADVAL_USENAN=1 3487569 PDL::IO::Misc : rcols problem (thanks bperret!) 3476648 PDL build of HTML docs fails on recent bleed Perl * Other bugs fixed: Fix check for glutRunning logic for imag2d Fixed a bug in cat's error reporting. Added lvalue awareness to whereND * New and improved tests have been added to the test suite. Tests t/gd_oo_tests.t and t/inline-comment-test.t are skipped for BSD platforms (see sf.net bugs #3518190 and #3524081 to track their issues). * New support for multi-line comments in PP code. See docs for PDL::PP for details (e.g., pdldoc PP). * Various enhancements to barf/croak output and messages to make error reports and stack traces more useful and readable. * There is a new changes (or Changes) target for the PDL Makefile which is a convenience target that allows one to regenerate the Changes file from git. v2.4.10 2012-02-03 18:44:47-05:00 General Notes: New Stuff: * PDL::Constants module provides E, PI, I (or J) and more. * PDL::NiceSlice has a new engine based on Filter::Simple which is more selective about where the PDL::NiceSlice sourcefilter is applied. * pdl() constructor now accepts a string argument which can include MATLAB-style [ ; ] syntax, bad values, inf values, and nan values. This makes it much easier to specify pdl values in programs and scripts. * PDL now supports pthreads on all platforms as well as a new, auto-parallelization capability for PDL threadloops across multiple processors using the PDL::ParallelCPU module. * Many(!) bug fixes. Incompatible Changes: * List output from whichND is now deprecated. * The default.perldlrc uses PDL::Constants to provide E and PI. * perldl.conf has new fields so be sure to update any local versions you use with the new fields. * rcols and wcols always use dim0 for the data dimension and dim1 for the column dimension. This only matters if you use the support for reading multiple columns into a 2D pdl. * Makefile.PL now requires at least version 6.31 of ExtUtils::MakeMaker to support the new standard INSTALL_BASE option matching Module::Build usage. * Prerequisite Text::Balanced minimum version is now 1.89 although this is not expected to be an issue because it is provided in the perl core since 5.8.0. Highlights: * General cleanup of code, including restructuring for clarity. * List output from whichND() is now deprecated. whichND() now returns a piddle of coordinates in all cases with a warning when a list context is detected. See the docs for work-arounds to your code. * PDL::IO::Misc now has better support for handles that are not files (e.g., pipes or standard input) for rgrep(), rcols(),... * Added bad value support to pctover() and oddpctover(). This was sf.net feature #3328001. * New whereND() routine provides the same functionality as where but with support for multi-dimensional masks and implicit threading over higher dimensions. This was sf.net feature request #3390043. * Many bugs fixed. 3059083 Problems with FITS header handling 3080505 PLplot segfaults on plshades call on OS X 3285520 status message from gslmroot_fsolver 3294808 sever on Empty piddle causes segfault 3295544 NiceSlice parsing bug 3299611 FITS I/O obscure bug 3300467 NiceSlice asterisk parsing issue 3307121 wmpeg sometimes kills perldl if file already exists 3307613 indexND of Empty pdls can segfault 3368883 t/opengl.t fails if display type not available 3375837 _read_flexhdr state machine fails 3388862 tiny bug in PDL-2.4.3. May apply to 2.4.9 3391645 bad printf formats in pdlapi.c and others 3394327 PDL::IO::FITS::wfits corrupting FITS image 3396738 PDL::Core::convert default return type 3410905 t/pgplot.t hangs test harness for PDL 3415115 whereND fails to handle all zero mask case 3428356 PDL::Transform::map output FITS header is slightly wrong 3434842 Error in definition of gsl_sf_laguerre_n function * PDL::Constants now provides: E, PI, I and J and is loaded by the default.perldlrc. It is not yet part of 'use PDL' so you'll need to 'use PDL::Constants ...' by hand for now. * default.perldlrc sets $PDL::IO::FlexRaw::writeflexhdr=1 by default so that writeflex() to a filename automatically writes the header file. This is different from the previous behavior but it seems to "do what you mean". Feedback welcome! * PDL::NiceSlice now has a new engine based on Filter::Simple which is smarter about only applying the slicing source filter to syntax occurring outside of POD, comments, and quotelike strings. The new implementation is available for *files* by setting the PDL_NICESLICE_ENGINE environment variable to 'Filter::Simple'. Work is underway to port the new niceslice filter implementation to perldl/pdl2. Once this task is completed, the new engine will become the default source filter and the PDL_NICESLICE_ENGINE environment variable will be removed. * There is experimental support for PDL::NiceSlice syntax in the perl debugger (i.e., perl -d). Just set the PERL5DB environment variable to 'BEGIN { require "PDLdb.pl" }' to use niceslice from the debugger command line. If PERL5DB is already set, you'll need to adjust the above recipe accordingly. * Better handling of build configuration options from perldl.conf as well as improvements in the detection of external dependencies. * perldl.conf has some new fields added: - POSIX_THREADS_INC and POSIX_THREADS_LIBS to specify locations of your pthread header file and library - PDL_CONFIG_VERSION to track the perldl.conf VERSION - PDLDOC_IGNORE_AUTOLOADER to control pdldoc behavior - PDL_BUILD_DIR provides the build directory path - PDL_BUILD_VERSION provides the PDL build version (to help with ambiguity from multiple PDL installs) NOTE: If you are using a private or customized perldl.conf file, please be sure to update with these additional fields as the perl Makefile.PL doesn't yet detect version skew automatically. * PDL::IO::Browser now builds in many cases (but not all). If you try it, please let us know how it goes. Just edit the value of WITH_IO_BROWSER in your perldl.conf before configuring the build (i.e., perl Makefile.PL). * PDL::PP has seen some significant improvements including code cleanup, improved documentation, and code refactoring for comprehension. There is a new PDL::PP::pp_line_numbers() routine which enables line # traceback for errors and warnings from PP code. * Improved error output from the pdl2 shell via the new CleanErrors plugin which filters out the non-PDL part of the error output leading to *much* more concise and helpful reports. * The pdl() constructor now accepts a string argument which allows for writing pdls using a matlab/octave style syntax as well as cutting and pasting from interactive session output to create pdls initializations for scripts and program files. The new constructor also allows for inf, nan, and bad to generate the appropriate values (case insensitive), e.g., $bad = pdl q[1 2 3 bad 5 6]; # Set fourth element to the bad value $bad = pdl q[1 2 3 BAD 5 6]; # ditto $bad = pdl q[1 2 inf bad 5]; # now third element is IEEE infinite value $bad = pdl q[nan 2 inf -inf]; # first value is IEEE nan value This is new functionality so feedback and problem reports are welcome. * PDL::Image2D has new routines: pnpoly() to determine the points in a polygon from the sequence of vertex coordinates, and cc4compt() for 4-component labeling of a binary image. * PDL now supports pdls larger than 2GiB. The element count is still an int type internally so the total number of elements per-piddle must be less than 2**31. * POSIX threads (pthreads) are supported for win32 and cygwin platforms. Pthreads are now available for all PDL platforms. * New PDL::ParallelCPU module provides automatic distribution of implicit thread loops across a number of processors. Now you can watch your PDL computations maximize the load on *all* your processors. See the docs for how to configure this feature and how to adjust your calculations to best take advantage of this feature. * PDL::Graphics::PLplot now works with the latest release of the PLplot library and has improved configuration and build handling. Feedback welcome. * rcols() and wcols() now use the same convention for multi-column input and output: dim0 is *always* the data dimension and dim1 corresponds to the columns in the file. This adjustment makes them their inverse operations. * The ADEV calculation in statsover has been corrected along with the documentation. * PDL::Graphics::TriD changes: - PDL::Graphics::TriD now builds using the perl OpenGL module (POGL) when configured on cygwin with the interface=W32API option. By default, POGL used interface=GLX on cygwin which does software rendering via Mesa/X11 (slower!). If you reinstall POGL with the W32API setting, you will need to rebuild PDL and PDL::Graphics::TriD to pick up the new configuration. - A new 4-line graphics demo contributed by Mark Baker has been added to 'demo 3dgal'. Take a look. * Various enhancements to FITS handling, including: - add map() fix for nonlinear FITS headers - Enable hdrpcy() in rfits() for Rice-compressed images * Test suite improvements to provide better diagnostics from failures and to make tests more correct avoiding "false fails" in the test reports. Various tests have been migrated to use File::Temp::tempdir and File::Temp::tempfile to improve the robustness for temporary files and directories naming and creation during tests. * Update ExtUtils::MakeMaker required version to 6.31 to support the new standard of INSTALL_BASE to configure for a local perl/PDL module installation. * Update Text::Balanced required version to 1.89. This is the version present in perl 5.8.0 (the minimum required for PDL) so this change in requirement is not expected to affect any PDL users. * pdldoc now searches your PDLLIB path for PDL::AutoLoader docs in addition to the pre-extracted documentation database. This makes pdldoc give the same output as the help command in the PDL shells. * Many updates and additions to the PDL documentation. * Devel::CheckLib is being used in more places during the PDL configuration stage. We plan to make this the standard baseline for dependency library detection going forwards. The included copy of Devel::CheckLib has been updated to 0.95. * A new unified implementation of barf()/warn() for PDL removes code duplication. barf() is now defined in both PDL::Core and the PDL packages. PDL::cluck is added as an analog of Carp::cluck (as PDL::barf is an analog of Carp::confess). barf() now generates its stack trace by hooking into Carp::confess on both the Perl and C sides. * Various fixes for PDL::Transform - fix inverse in perspective() - fix t_cubic() parameter parsing - fix handling of multiple PCi_j systems in the piddle header * Added SIGPIPE handlers to cases where PDL uses pipes to/from external processes (such as ffmpeg or some NetPBM image converter programs). This should make PDL "SIGPIPE safe" by not exiting when a PDL piped IO output process quits (e.g., as when called from within the perldl/pdl2 shell). v2.4.9 2011-04-09 10:05:43-04:00 General Notes: * Fixes a couple of surprise bugs that were discovered immediately with the PDL-2.4.8 release. * See Also: the Release Notes for PDL-2.4.8 below Highlights: * Fix sf.net bug #3267408 "t/slice.t crashes in tests 68-70 for BSD" * Fix sf.net bug #3190227 "PDL build fails with parallel GNU make -j3 -j3" * Fixed various tempfile name generation problems by switching to File::Temp instead of hand rolled solutions. This is the recommended approach going forward. * Force Convert::UU usage for BSD to work around a t/dumper.t failure on MirBSD. v2.4.8 2011-03-29 17:12:41-04:00 General Notes: * The deprecated Karma imaging library support code has been removed from the PDL distribution. * Perl OpenGL (POGL) is now the only build option for 3-D graphics support in PDL. The POGL build has proven to be portable and reliable. This prepares TriD graphics development for the next stage of re-factoring for support and new features. * Many improvements to the PDL configuration, build and test process make this the most robust PDL yet. * PDL::IO::FlexRaw now supports automatic header file creation when writeflex() is given a filename argument for writing. readflex/writeflex/mapflex now support reading and writing piddles with bad values in them. * New PDL::Constants module provides PI and E. * PDL::Complex now supports in-place operations. * Added $PDL::toolongtoprint to set the maximum piddle size allowed to print as a string. This was added to the default.perldlrc to make it easier to discover by users. * wmpeg() from PDL::IO::Pic uses the new ffmpeg back-end and can create many additional file formats beyond MPEG alone, including MP4 and animated GIF. See the documentation for details. * Lots of improvements to the documentation, overall usability and many bugs fixed! Highlights: Build and Test Enhancements: * Karma support code has been *removed* from the PDL distribution The last stable PDL distribution with Karma code was be PDL-2.4.7. * You must use the Perl OpenGL module to build the PDL 3-D graphics module, PDL::Graphics::TriD. OPENGL_LIBS, OPENGL_INC and OPENGL_DEFINE are no longer used by perldl.conf for the configuration process. * Added a check for mis-installed PROJ4 libraries. If the library does not initialize (even if present) then PDL will not build the PROJ4 modules. This is sf.net feature #3045456. * GD, HDF, PROJ4, OpenGL, and GSL tests will not be run unless the corresponding module was configured to be built. This addresses the possibly mysterious test failures caused by previous PDL installations in the perl path at build time. * Use of the Test::More TODO {} blocks allows tests for known bugs to be added to the test suite without causing the suite to fail. This replaces the previous SKIP_KNOWN_PROBLEMS option and should better enable test first development and debugging. * utils/perldlpp.pl is a new script for off-line source filtering to pre-filter PDL source files with NiceSlice constructs. This allows PDL to use NiceSlice constructs in the core functionality while still allowing PDL to work in environments where source filters are not supported. * The 'perl Makefile.PL' response to detecting another PDL in the build path has changed. If such a pre-existing PDL installation is detected, the user is warned *but* configuration and build will proceed nonetheless. * Clean-up and fixes to demos and tests for reliability and portability. Documentation: * Added INTERNATIONALIZATION file with i18n notes. PDL does yet not have internationalization support beyond that provided by perl itself. * Cleared up the documentation on when to use lu_decomp and versus lu_decomp2. Now that lu_decomp is threaded, it is the preferred implementation. * wmpeg() with the ffmpeg converter supports generation of many different output video file formats including MPEG, MP4, and animated GIF. Documentation on these uses were added. * New example code refresh.pdl in Example/PLplot to provide for PLplot, some of the same functionality as in PDL::Graphics::PGPLOT. * Other documentation updates for clarity and correctness. New Features or Functionality: * New PDL::Constants module providing PI and E (so far) * Inplace support added for PDL::Complex operations * pdldoc and the pdl2/perldl help commands now print all matches by default when multiple matches are found. * A do_print command was added to the pdl2 shell which toggles the input mode between printing and not printing the return value of each command. * readflex/writeflex/mapflex now support reading and writing piddles with bad values in them. This was sf.net feature request #3028127, "add badvalue support to FlexRaw". * writeflex now supports automatically calling the writeflexhdr() routine if you have set the variable $PDL::FlexRaw::writeflexhdr to a true value and are writing to a file given by filename as argument. * Updated the error handling for GSL::INTERP to match other GSL module usages. * Applied sf.net patch #3209075 IO::HDF square sds * New binary blob support in PDL::IO::GD::OO Bugs Fixed: * Applied Christian Soeller's patch for FFTW on 64-bit systems. This resolves bug #3203480 "t/fftw.t fails on 64-bit systems". * Fixed sf.net bug #3172882 re broken threading in inv(). inv() and lu_backsub() now handle threading. Updated documentation for lu_decomp, lu_deomp2, and lu_backsub. * Fixed sf.net bug #3171702 "missing podselect command breaks PDL build" * Fixed sf.net bug #3185864 (bad adev in statsover) * Fixed sf.net bug #3139697: fixed imag2d() to work better with Mac OS X GLUT and not just FreeGLUT. * Fixed uniqind bug #3076570 * Fixed SF bug #3057542: wmpeg doesn't error on missing ffmpeg program. Now wmpeg returns 1 on success and undef on error. If ffmpeg is not in PATH, it just fails immediately.... * Fixed SF bug #3056142: pdl2 fallback to perldl broken on win32 * Fixed SF bug #3042201: t/dumper.t fails mysteriously * Fixed SF bug #3031068: PDL::IO::FlexRaw mapflex memory mapping fails * Fixed SF bug #3011879, "pdl() constructor crashes perl for mixed ref/piddle args" and #3080505, and #3139088. This fix also includes a larger and more complete set of tests. * Fixed segfault in plplot.t with a work-around. * Fixed bug in readenvi.pdl header list value processing and added support for embedded file headers. * Fixed bug in FlexRaw.pm support for headers with Type passed as string. * Fixed imag2d() in PDL::Graphics2D. It no longer calls exit on ESC if run within the pdl2/perldl shell. Also did some clean up of key controls and module mechanics. * Fixed upstream bug in Devel::REPL for MultiLine continuation. Now incomplete q[] and qq[] constructs continue reading until properly closed. See the Known_problems file for details. v2.4.7 2010-08-18 20:55:52-04:00 General Notes: * New requirements: - perl version 5.8.x and higher - Convert::UU * PDL::Graphics::TriD now requires OpenGL-0.63 * New 2-D image display routine: imag2d() * pdl() constructor, a.k.a. PDL->new(), now takes string arguments with either MATLAB type concatenation syntax or PDL print output (for easier cut-and-paste from PDL shell sessions). * Improved text and comma separated value file input via rcols(): faster and more flexible. * A new PDL shell based on Devel::REPL (i.e., Moose technology). The new shell supports more perl syntax (lexical variables and packages), is more extensible (via a system of plugins), and supports many forms of file and variable completion. Install Devel::REPL and give it a try! User feedback welcome. * More portability (builds on more platforms with more features than ever). * Many bugs fixed... Highlights: * General OpenGL-0.63 is required for PDL::Graphics::TriD. Convert::UU is required for PDL. Karma is DEPRECATED and NOT SUPPORTED. Set USE_KARMA=>1 in perldl.conf to force a build. * New 2D Image Display Feature: imag2d() See PDL::Graphics2D for documentation. Add image pixel value display on mouse click in imag2d window Add keyboard command shortcuts for imag2d (with placeholders) Fix a number of imag2d() usabiilty bugs * pdl() Constructor Can Take String Input Allows use of MATLAB-style [ ; ] syntax Allows cut-and-paste of printed pdl values as input args for pdl() * rcols/wcols Improvements Much faster read times Multiple columns can read into a single pdl varible Symmetric handling of perl and pdl column data Improved format support for CSV file input * Enhanced PDL Shell (Version 2) Based on Devel::REPL which must be installed along with either Term::ReadLine::Perl or Term::ReadLine::Gnu to use the pdl2 features. Supports Term::ReadLine::Perl and Term::ReadLine::Gnu. Upward compatable with the original PDL shell, perldl. Adds completion and command line editing support across all PDL platforms. Adds support for current package and lexical variables. Toggle default print output via the do_print attribute. Default prompt for perldl and pdl2 is now 'pdl> ' help vars now shows results alphabetically pdl2 now runs (falls back to) perldl if Devel::REPL is not installed or if Term::ReadLine::(Perl|Gnu) is not installed. * Other Features Fix wmpeg() to use ffmpeg to generate the video (sf.net feature request #3010984). Added tiled compressed image handling to rfits Faster matrix multiply Preliminary support for ENVI file format data in PDL/IO/ENVI/readenvi.pdl * Build Improvements: PDL build process now detects multiple PDL installs and warns of possible conflicts. 'use PDL' now loads PDL::Config by default. PDL "as built" configuration is now saved to %PDL::Config Changes file is automatically updated each release Add SKIP_KNOWN_PROBLEMS support for build Add checks to prevent warnings from access to $HOME when it is not defined. * Portability Fixes Multiple build improvements for debian platforms Improved portability across perl and compiler versions Reduced number of fortran dependencies Improved support for win32 platforms - PDL::GIS::Proj builds for win32 - PDL::Transform::Proj4 builds for win32 - PDL::Graphics::PLplot builds for win32 - PDL::IO::Dumper builds for win32 * 3-D Graphics Improved PDL::Graphics::TriD demos and examples Fixed problems with VRML support for many platforms. Better dependency searches for OpenGL during PDL build Removed warnings "noise" when used with perl -w New spheres3d routine added to PDL::Graphics::TriD * Bugs Fixed Fix PDL::AutoLoader to handle win32 PDLLIB path syntax with ; as separator. Fix PDL::Complex::string and sum and sumover (sf.net bug #1176614) Fix PDL::Config does not match actual build configuration (sf.net bug #3030998). Fix dimension numbering in PDL::Transform::t_fits Fix jpegtopnm problem in proj_transform.t Fix rt.cpan.org bug #53815 in IO/HDF/SD/SD.pd Fix rt.cpan.org bug #59126 in isempty pod Fix sf.net bug #2901170 re overly verbose warnings when running TriD with perl -w Fix sf.net bug #3011143 re whitespace in perl path Fix sf.net bug #3021578 re missing xtra dummy dims Fix threading with lu_decomp and lu_backsub (sf.net bug #3021567) Fix uniq and uniqind NaN and BAD value handling (sf.net bug #3011659) Fix uniqvec bug where it did not return a 2-D result (sf.net bug #2978576) Fix uuencode/uudecode detection logic in PDL::IO::Dumper to include Convert::UU check Make PDL prompt/warn if space in build path (sf.net bug #2924854). Fix up code to not crash on non-lazy linking systems. Work arounds for perl-d lvalue temp bug introduced in recent perls. t/lvalue.t is skipped if run under the debugger. Fix format string attack errors in GSL, PGPLOT, and Transform. * Many Documentation Improvements Completely reworked PDL web site - Clearer and more helpful to new PDL users. - See http://pdl.perl.org for the latest! New documentation: - Migration guide for MATLAB users. - Migration guide for Scilab users. - Threading tutorial. Major reorganization of documentation to better help new users - A guide to PDL's tutorial documentation. - A guide to PDL's module reference documentation. - A study course through all of PDL's documentation. - Removed PDL::Intro POD cleanup across many PDL modules and functions. Update to copyright statements throughout PDL to clarify licenses. Improved on-line help and apropos features in the PDL shell Updated FAQ Improved POD to HTML translation DEPENDENCIES for PDL updated and checked for applicability. INSTALL guides improved in the distribution and on the web site. v2.4.6 2009-12-31 23:06:11-05:00 General Notes: * Mainly a bug fix and polishing release Highlights: * Improved 3D graphics and OpenGL functionality * imag2d() routine for multi-image (photo) display * Many fixes for Debian package release * Several little bugs fixed since PDL-2.4.5 * Fixed some issues with PDL convolution routines * Improved documentation and release notes and files * Padre and enhanced perldl shell integration begun Summary of Changes: * Improved 3D graphics and OpenGL functionality Perl OpenGL 0.62 is the minimum required version for PDL::Graphics::TriD to build. TriD now builds correctly for Mac OS X systems without X11 installed. Autoprobe for build of 3D graphics and the use of the Perl OpenGL library has been implemented. The default perldl.conf setting is to check. Improved multi-window support for PDL::Graphics::TriD display windows: the GLUT window ID is now part of the default window title for convenience, and redraws with multiple open TriD windows are handled correctly. * imag2d() routine for multi-image (photo) display REQUIRES: The Perl OpenGL TriD interface and FreeGLUT. IMPORTANT: Legacy X11 TriD is *not* supported! It is implemented in the imag2d.pdl file for autoloading via PDL::AutoLoader. To use, copy the imag2d.pdl file to somewhere in your PDLLIB path or add the location to your PDLLIB environment variable. It works with multiple, simultaneous, image windows and appears to work side-by-side with TriD graphics windows. After you have imag2d.pdl in your @PDLLIB list, you can use 'help imag2d' to get usage instructions and documentation. This implements the basic functionality planned regarding an improved imagrgb() routine. * Many fixes for Debian package release This should allow PDL-2.4.6 to be more readily released as a Debian packages. The general clean up involved improves PDL portability and robustness generally. * Several little bugs fixed since PDL-2.4.5 The number of history lines when you use Term::ReadLine::Perl with perldl are now set correctly to $PERLDL::HISTFILESIZE. The default value is 500. A number of minor internal fixes for portability and implementation improvements: - Add comment re fix for defined(%hash) usage - Fix annoying PGPLOT::HANDLE warning message - Replace GIMME by GIMME_V in Core.xs - Update to v3.14 of ppport.h portability Fixed MINUIT build problem where non-standard code was being generated which caused problems with rigorous compiler settings. This was SF bug #2524068. * Fixed a number of issues with PDL convolution routines conv1d() algorithm adjusted to match conv2D() and convolutionND(). Documentation on the exact computation being performed in conv1d() was added. Fixes bug #2630369 with fftconvolve(). It now gives the same results as conv1d(), conv2d(),.., except perhaps with respect to the boundary condition handling. * Improved documentation and release notes and files Updated PDL::FAQ. Lots of little changes to bring documentation in line with current PDL functionality. Volunteer editors and contributors always welcome! * Padre and enhanced perldl shell integration begun There is a new PDL-2.4.6/Padre/ subdirectory in the PDL source tree which contains work towards Padre integration and a 2nd generation, enhanced perldl shell for PDL. E.g. an *experimental* plug-in giving PDL::NiceSlice support to the Devel::REPL shell is included. See the Padre/README file for instructions to get you started. v2.4.5 2009-10-24 11:56:23-04:00 Highlights: * 3D graphics modules now run on win32 and Mac OS X systems without requiring X11 be installed. The only prerequisites are OpenGL and FreeGLUT/GLUT. * Release documentation and FAQ have been updated to be more useful (and more accurate). * PDL build, test, and run time diagnostic messages have been make clearer and more helpful. * Many bugs have been fixed since PDL-2.4.4 so this is the most reliable PDL ever. * PDL now requires perl 5.6.2 or greater and has updated DEPENDENCIES information and code. This should improve the buildability of PDL General Notes: This is the first PDL release supporting the new build strategy for the PDL::Graphics::TriD modules. The result is it now builds on more platforms than ever. You'll need to install the OpenGL module and have FreeGLUT or GLUT (for Mac OS X) on your system. If you have problems with the new TriD build (that you did not have before), edit perldl.conf and set USE_POGL to 0. That should enable you to build the legacy TriD code but you *will* want to submit a bug report, see the next point.... IMPORTANT: Given the increased portability and generality of the new TriD interface approach, it is expected that the legacy TriD build interface (based on X11) will be deprecated soon (almost immediately) and removed after that. (N.B. It has been effectively unsupported for some time) If you are new to PDL, we recommend joining the perldl mailing list for discussion and questions. See http://pdl.perl.org/?page=mailing-lists for how to sign up and links and searches of the list archive discussions. Summary of Changes: New perldl.conf configuration parameters controlling build of TriD with perl OpenGL (a.k.a. POGL) with the follow default values: USE_POGL: 1 -- build using POGL 0 -- build using legacy build process undef -- build with POGL if possible POGL_VERSION: 0.60 -- minimum required version of OpenGL POGL_WINDOW_TYPE: 'glut' -- use a GLUT GUI for window creation 'x11' -- use GLX and X11 for the GUI (this is a "compatibility mode" to support PDL::Graphics::TriD::Tk widgets) NOTE: Set WITH_3D => 0 in perldl.conf to disable the TriD build completely. Just setting USE_POGL => 0 is not enough. The OpenGL tests in t/opengl.t now respects the interactive setting from the PDL_INT environment variable. Two TriD check programs, 3dtest.pl and line3d.pl, are added to the main PDL build directory. They can be run as quick checks of the new functionality and are short enough run under the perl debugger if needed. e.g. perl -Mblib 3dtest.pl OR perl -Mblib line3d.pl OpenGL (a.k.a. GL) is the default TriD output device on all platforms. VRML does not work at the moment. GLpic is not tested but may work. Closed SF bug #1476324 by adding FAQ entry on clean installs Fix qsorti(null()) crash bug from SF bug #2110074. Make qsorti() return quietly when given a null() piddle input Fix broken PP typemap finding code, thanks to CS for the final code and many testers! Fix t/autoload.t tilde expansion bugs and test failures. tilde expansion seems to work consistently with bash now Partial fix implemented for PDL::IO::Browser. The code has only been tested with cygwin but it should work on systems with ncurses in the "right place". This is **not tested** but set WITH_IO_BROWSER => 1 if you wish to try. If the perldl shell is unable to load PDL for some reason and defaults to basic perl support, the prompt now changes to perl> reflecting that fact. readflex() now works with File::LinearRaid. Many win32 fixes to tests and build process which make things work more smoothly on win32 platforms. See the Changes file or run 'git log --stat' for the detailed list of changes. v2.4.4 2008-11-12 19:16:53-10:00 General Notes: - Bad value support is now enabled by default for PDL builds. This feature allows simpler handling of missing or invalid data during processing. For example, missing pixels could be interpolated across. Calculations could be skipped for missing data points... Edit the perldl.conf file to turn off bad value support before compiling if needed. - This release includes significant improvments in portability, enhancements in functionality, and *many* bugs fixed. - PDL::Graphics::TriD modules for 3-D and image visualization are being refactored for improved portability and performance. Preliminary hooks are in PDL-2.4.4 to support the new functionality. Announcements to the perldl mailing list will be made when the PDL::Graphics::OpenGL::Perl and Term::ReadLine::FreeGLUT suport is on CPAN. - Builds out-of-the-box on cygwin and win32 - perl 5.6.x is explicitly required to configure and will go away in future versions. 5.8.x and above are the recommended versions Summary of Changes: - Improve uuencode support in Dumper for additional OSes such as *BSD varieties that may need additional options to prevent stripping of the leading slash in pathnames including: darwin, netbsd, openbsd, freebsd, and dragonfly. - Updated more PDL tests to use the recommended Test::More - Updated PDL::Graphics::PLplot build support for more 5.9.0 specific features - AutoLoader ~ expansion has been updated to conform more closely to the ~ expansion in the bash shell - Better checks for a valid PROJ4 build environment are now performed before attempting to compile PDL modules using it - PDL now builds and runs on perl-5.10.x - The perldl shell has added support for using FreeGLUT for display in analogy with the existing Tk event loop support. This enables refactoring of the TriD modules to use the Perl OpenGL module (a.k.a. POGL) instead of the internal, and deprecated, PDL::Graphics::OpenGL et. al. - The perldl acquire/filter/execute loop is now $_-safe by using $lines instead of $_ for all the central modifications. Avoids problems with some AUTOLOAD functions that leaked $_. - Removed ExtUtils::F77 from the required prerequisites for PDL to improve the buildability on platforms without an available fortran compiler. If you have a fortran compiler and EU::F77 installed, PDL::Slatec will be built. - zeros function added as an alias for the zeroes function - Many warning messages that were not actually problems have been quieted, especially many pointer to int conversion messages - Added $PERLDL::HISTFILESIZE to allow configuration of the number of lines of history to be saved by the interactive PDL shell. - Fixed implementation of the pctover() function to address bug #2019651 on sf.net. Added explicit documentation in the code on the algorithm being used. - Various updates to the PDL FAQ - Implemented a PDL interface to the Minuit minimization library from CERN - Removed circular dependency in PDL Makefile.PL Makefile generation process which caused builds with some versions of make to fail - Multiple fixes to enhance configuration and build for win32 - Added basic table-inversion to t_lookup for PDL::Transform - Fixed problem in uniqvec() where it failed to generate a correct result if all the input vectors were the same, fixed bug #1869760 - Add improved 16-bit image support for IO with rpic() and wpic() provided you have a recent version of the NetPBM library that supports 16-bit images - Enabled building of GSL on Win32. v2.4.3 2006-08-20 06:07:30-10:00 General Notes: - again, mainly a bugfix and polishing release. - builds out-of-the-box on cygwin and win32 build environment has been significantly improved - perl 5.6.x is now deprecated; 5.8.x is recommended. Support for 5.6.x may go away in future versions. Summary of Changes: - PDL now builds under cygwin on windows PC including TriD(OpenGL) 3D graphics and PGPLOT and PLplot 2D graphics support. See PDL/cygwin/ and files README and INSTALL for details and how to build/install external dependencies. - The win32 build has been improved. See PDL/win32/INSTALL for details. - Many fixes from the Debian build patches have been incorporated. See PDL/debian for specifics. - 64bit platform build has been improved. - New functionality, functions and modules: * Bad value support has been extended to per-PDL bad values as an experimental feature. To use, configure WITH_BADVAL => 1 and BADVAL_PER_PDL => 1 in perldl.conf before building. * PDL::GSL::INTEG now supports the calculation of nested integrals * New function tcircle (threaded circle) added to PDL::Graphics::PGPLOT This draws multiple circles in one go (see also tpoints and tline) * Added set operation routines for pdls treated as sets (help setops). * PDL::IO::GD module interface to the GD runtime image libaray (http://www.boutell.com/gd/) has been integrated. * The PDL::GIS::Proj and PDL::Transform::Proj4 modules to interface to the PROJ4 Cartographic Projections Library (http://proj.maptools.org/) have been added. * PDL::IO::HDF provides an interface to the HDF4 library (http://hdf.ncsa.uiuc.edu/). - The PDL test suite (i.e. tests in in PDL/t) has been enhanced. Coverage has improved and output diagnostic messages are more useful. Test::More is becoming the preferred test module. The vanilla Test and Test::Simple may be deprecated in the future. - PDL core code has been fixed to address valgrind-detected errors and to enable better bad value support including the new experimental per-PDL bad values. These changes will require a re-build/install of any external modules using the C interface of PDL. See perldl.conf to configure the new bad value support. - Several TriD graphics build problems have been resolved. The TriD rotation bug has been fixed. - Many other bug fixes too numerous to mention. See the PDL/Changes file for details. - Multiple fixes and additions to PDL documentation as well as the PDL::FAQ. v2.4.2 2004-12-28 09:19:30-10:00 General Notes: - again, mainly a bugfix and polishing release. - perl 5.6.x is now deprecated; 5.8.x is recommended. Support for 5.6.x may go away in future versions. - a little too late for Christmas; but happy new year 2005! Summary of Changes: - Overhaul of FITS I/O. FITS binary tables are now supported, for both reading and writing. - Many improvements to PLplot handling - New Graphics::Limits package determines display range for multiple concurrent data sets - Better PDL::reduce function - Improvements to PDL::Transform - pdl() constructor is more permissive -- you can feed it PDLs and it does the Right Thing most of the time. - Cleaner handling of config files - Improvements to multi-line parsing in the perldl shell - New 'pdl' command-line entry to perldl shell allows #!-style scripting (so you can re-use your journal files verbatim) - Several fixes for Microsoft Windows operation - PDL::undefval works properly, also has warning tripwires - statsover finally seems to produce meaningful, consistent RMS values - Several 64-bit compatibility issues (this work is probably not yet complete). - Many small bug-fixes too numerous to list (see the Changes file). v2.4.1 2004-01-05 12:27:18-10:00 General Notes: - mainly a bugfix and polishing release Summary of Changes: - Fixed warnings with perl 5.8.2 - Replace original m51.fits with freely distributable image - Upgrade PLplot interface for plplot-5.2.1 and perl 5.8.2 - Improvement to documentation of autoloaded routines - Added more universal `whatis' function to perldl - Numerous small fixes/additions to docs/functions - Improved handling of empty piddles - Fixed most reported bugs v2.4.0 2003-05-22 12:09:26-10:00 General Notes: - Perl 5.6.0 or later is now required, along with the modules Filter and Text::Balanced. - After installing PDL 2.4.0 external PDL modules will need to re-built. (any such modules will refuse to load until they have been re-built) - New demos of the PDL::Transform and PDL::Transform::Cartography modules have been added to perldl. Type 'demo transform' or 'demo cartography' in the perldl shell. ( Note that PGPLOT is required to run ) Summary of Changes: - The NiceSlice syntax comes of age (Nice slicing has been around a while, but really needs to be acknowledged as the main way of slicing PDLs...) - New GSL functionality: greatly improved access to the Gnu Scientific Library, including interpolation, finite-difference, random variable, and other routines. - New, very powerful indexing and slicing operators allow boundary conditions (range, indexND) - N-dimensional indexing (indexND) and selection (whichND) methods - Powerful syntax for coordinate transformation and arbitrary image resampling and coordinate transformations -- including high powered spatially-variable filtering (PDL::Transform module) - Support for major cartographic transformations (PDL::Transform::Cartography module) - New PLPlot graphics interface ( cleaner and faster than PGPLOT ) - Many improvements to the PGPlot interface: * Strong FITS support (easy display of images, vectors, & contours in science coordinates) * Better vector graphic support [including improvements to line() and a new routine, lines()] * Much cleanup of errors and bugs * Spinlocks prevent interrupt-related PGPLOT crashes (requires Perl 5.8) * RGB output to truecolor devices (requires PGPLOT-5.3devel) - Improvements to the perldl shell: * Many bug fixes * Multi-line inputs to the perldl shell for easier cut-n-paste * ^D blocking on demand (controlled by perl variable or command-line switch) * Autoloading detects error conditions on compile * New demos - Header copying is now explicit rather than by reference -- so that, e.g., FITS file manipulation is more intuitive and natural. - Improved support for Astro::FITS::Header - Bad value support is improved - Several new utility routines, including glue(), zcheck(), and ndcoords(). - Better matrix operation support: matrix operations are now in PDL::MatrixOps, and are all threadable. Singular value decomposition, determinant, linear equation solving, matrix inversion, eigenvalue decomposition, and LU-decomposition. v2.3.4 2002-09-23 15:50:06-10:00 - Now should compile using perl 5.8.0 - Improved speed for generating PDL's from a perl array ref - Added PDL::IO::Storable, which enables PDL storage/retrieval using the Storable package. - Added PDL::GSL::SF (Gnu Scientific Library, Special Functions) hierarchy - New % operator follows (mathematically correct) perl % operator behavior - Numerous Bug Fixes See the Changes file for a detailed list of changes. v2.3.3 2002-05-22 03:16:29-10:00 Mainly a bugfix release with some nice little additions: - PDL::IO::Dumper: Cleanly save and restore complex data structures including PDLs. - Support for the new Astro::FITS::Header module (availiable on CPAN). See the Changes file for a detailed list of changes. v2.3.2 2001-12-18 22:20:31-10:00 - A pure bugfix release to fix compilation problems with gimp-perl (part of the gimp distribution). The following notes from 2.3 and 2.3.1 still apply: v2.3.1 2001-11-21 14:38:32-10:00 - A bugfix release to fix some compilation problems seen with 2.3. The following notes from 2.3 still apply: v2.3 2001-11-16 05:12:41-10:00 Summary of Changes - A nicer slicing syntax for PDL added via the new PDL::NiceSlice module. - Inline::Pdlpp module added, which enables in-line PDL::PP definitions. (i.e. no Makefiles, building hassles for creating PP code) - A Multitude of bug fixes, doc updates, and other changes. Note:Support for perl version 5.005 and previous is limited in this release. Perl 5.6.0 or greater is recommended for full PDL functionality. See the Changes file for a detailed list of changes. v2.2.1 2001-04-25 03:05:46-10:00 Summary of Changes Bugs Fixed: - 'pow' function fixed in math.pd - Misc memory leaks fixed. - PGPLOT 'undefined window size' bug fixed. - Test failures with opengl.t fixed. - Error in output of 'minimum_n_ind' function fixed. Misc Changes: - Documentation updates. - Updates to work with perl5.6.1 See the Changes file for a detailed list of changes. v2.2 2000-12-21 03:25:36-10:00 Major Changes: - 'Bad' Value Support added. With this option compiled-in, certain values in a PDL can be designated as 'Bad' (i.e. missing, empty, etc). With this designation, most PDL functions will properly ignore the 'Bad' values. See PDL::BadValues for details. - PGPLOT interface rewritten. New Features: - Interactive cursors (cursor) - Text on plots (text) - Legends (legend) - Circles, Rectangles, Ellipses - Multiple plot windows, one can jump from panel to panel when the window is divided in several. - More control over options - see PDL::Graphics::PGPLOTOptions for details. - New Examples in Example/PGPLOT. - Major updates to the Tri-D Code. Now requires perl 5.6 for TriD. - 'Reduce' function added. This provides a consistent interface to the projection routines (sumover, average, etc). See PDL::Reduce. - Improved OpenGL detection during 'perl Makefile.PL - pdldoc command added. This allows you to look up PDL documentation similar to the perldoc command. - Perl 5.6 is now recommended for PDL 2.2. It will still work with perl 5.005, but some of the extra libs won't be compiled ( like Graphics/TriD). Many other changes. See the Changes file for a detailed list of changes. v2.1 2000-06-07 22:23:47+00:00 Major Changes: - Speed Increase. Most PDL functions are now done totally in C-code, without any perl wrapper functions as was done with previous versions. The speedup will be most noticeable for operations on many small PDL arrays. - Mem Leaks Fixed. - Added a consistent, Object-Oriented interface to the various interpolate functions in PDL. (PDL::Func, See Lib/Func.pm). See the Changes file for a detailed list of changes. v2.005 2000-04-05 22:30:35+00:00 Major Changes: - A bugfix release to fix 2.004 problems with PGPLOT changes and perl 5.6.0. - The following notes from 2.004 still apply: - *IMPORTANT NOTE*: Due to changes to the PGPLOT module, 'use PDL::Graphics::PGPLOT' has been removed from PDL.pm (i.e. in scripts and within perldl you now need to explicitly say 'use PDL::Graphics::PGPLOT'). Additionally, it needs Karl's new 2.16 release of the PGPLOT module (available from CPAN). - Notable additions are a module for operations on complex piddles (PDL::Complex), a subtype of PDL which allows manipulation of byte type PDLs as N dimensional arrays of fixed length strings (PDL::Char) and a Levenberg-Marquardt fitting module (PDL::Fit::LM). - Bug reports and patches to the relevant places on sourceforge, please. PDL-2.018/Changes_CVS0000644060175006010010000052011012562522364012410 0ustar chmNoneCHM 29-Apr-2009 Fixed bug number 2784016 in t/pic_16bit.t reported via rt.cpan.org. I note that the Changes file might be replaced by the log list from git commits at some point. CHM 23-Apr-2009 Fixed test 17 in t/plplot.t to use a magnitude difference test rather than equality for the floating point quanitities. CHM 22-Apr-2009 Applied fix to t/autoload.t per the bug report sf bug #2339726 by zowie. CHM 22-Apr-2009 Fixed bug #2753869 in the interpolation part of the pctover() routine in ufunc.pd. The computation of pctover() and oddpctover() were corrected to improve consistency and agreement with other apps (e.g. MS Excel). and fixed the calculations of the pctover() and oddpctover() CED 11-3-2009 mkhtmldoc.pl: suddenly stopped making docs, preventing me from executing "Make install". Traced the problem down to a nonexistent directory in the POD scan path (".../HtmlDocs/pdl/PDL"), which for some reason is now crashing the POD builder stuff that came with my MacOS-standard Perl. Since .../pdl/PDL seems like a silly place to look (the docs are build into just .../pdl), I dked out the "PDL" from the pod path, fixing the problem. CED 10-3-2009 Fix problem with reorder() - formerly required that all dimensions be set; now allows specification of a leading subset of dims in the target. Additional dims are threaded over (i.e. ignored). SIS 25-2-2009 Amend Basic/Math/math.pd so that Math.xs contains a prototype for the (distro version of) the rint function when (and only when) a Microsoft Compiler is being used. (Rev 1.17 of math.pd) This ifxes sourceforge bug 2630402. CHM 13-Nov-2008 PDL/Basic/PDL.pm: updated VERSION to 2.4.4cvs for post release development. CHM 13-Nov-2008 PDL/Basic/PDL.pm: updated VERSION to 2.4.4 for release Known_Problems: updated for release This is PDL-2.4.4 as released to CPAN CHM 06-Nov-2008 Basic/PDL.pm: changed version to 2.4.3_06 for quick check release of final Makefile.PL mods. DAL 05-Nov-2008 In top-level Makefile.PL: removed debugging print statement; moved @podpms back to 'pm' so tht the perldl and pdldoc script manuals appear in PDL::Index. DCH 03-Nov-2008 Added code to XS for PDL::Graphics::PLplot::plParseOpts to avoid a segfault when it is called with no options. Also added test case to plplot.t. DCH 03-Nov-2008 Took out MY::test subroutine in top-level Makefile.PL. This should restore the complete 'make test' functionality which now works properly after Craig Deforest's fix of 28-Oct-2008. CHM 01-Nov-2008 perldl.conf: changed default build options to enable bad value support and updated the Release_Notes to advertise the new capability. Basic/PDL.pm: updated VERSION to 2.4.3_05 which will be the official 2.4.4 release once the final updates are complete. Changes updated to reflect these changes. CHM 01-Nov-2008 Updated Known_Problems and Release_Notes for PDL-2.4.4 release to come. CHM 01-Nov-2008 Graphics/IIS/iis.pd: fixes from patch #1908629 to quiet some gcc udefined operations warnings. CHM 01-Nov-2008 t/ufunc.t: fixed typo in conversion from is() to ok() CHM 01-Nov-2008 Basic/Core/pdlcore.c.PL: added case to support creation of longlong piddles with pdl_from_array from patch #2107905 on the SF PDL site. Thanks to Pete Ratzlaff. CHM 01-Nov-2008 Added dragonfly OS to list of BSD flavors requiring the -s flag to uudecode in IO/Dumper.pm. CHM 31-Oct-2008 Modified t/ufunc.t to use ok() and approximate numerical equality rather than string eq via is() for the tests. DAL 29-Oct-2008 Graphics/PLplot: changed Makefile.PL and plplot.pd so new 5.9.0 (devel release) funcs aren't linked if older PLplot is installed. SIS 29-Oct-2008 Added a "sub MY::postamble{return ''}" to IO/Dicom/Makefile.PL to prevent the writing of a postamble section which was sometimes happening (with dmake only). CED 28-Oct-2008 Removed "Gen/pm_to_blib" dependence in Dev.pm - this should fix the Makefile repeated-compile woes. Added some explanatory notes in other Makefile.PL's. CED 27-Oct-2008 Update Autoload.pm to match bash's (advertised) ~ expansion: - "~+" now expands to current working directory; - "~" now expands to $ENV{HOME} if present, *then* system-advertised home directory; - "~name" expands to system home dir for user "name" (previous behavior). No support for "~-", since Perl doesn't keep an $OLDPWD around. SIS 27-Oct-2008 Small fix to autoload.t so that it passes on Win32. (Only 2 tests were planned for Win32, but 3 were being run.) CHM 26-Oct-2008 Modified t/bad.t test to use like() with a regexp rather than is() for some tests where the value returned had -0 and the test was checking with 0. Basic/PDL.pm: updated VERSION to 2.4.3_04 CHM 25-Oct-2008 Basic/PDL.pm: update VERSION for PDL-2.4.4 pre-release 3 CHM 25-Oct-2008 Makefile.PL: enabled bad value options when built within an automated testing framework such as used by CPAN Testers. This should improve the test coverage and allow us to better evaluate whether BADVAL can be enabled by default. CHM 25-Oct-2008 Lib/GIS/Proj/Makefile.PL: added trylink to verify PROJ4 version is recent enough, skip build otherwise. Makefile.PL: explicitly require 5.6.x or above perl version now. CHM 25-Oct-2008 t/autoloader.t, t/dumper.t: switched code from Test to Test::More and added better diagnostic messages in the hopes of tracking down the problems on darwin and freebsd. CHM 22-Oct-2008 t/inlinepdlpp.t: use non-standard Inline working directory for testing and force builds to fix problem with out-of-synch Inline cache and config CHM 22-Oct-2008 IO/Dumper.pm: the fix to use 'uudecode -s' with *bsd coming from bug #1573217 does not apply to NetBSD as that uudecode does not strip leading slashes. Removed the "fix" code for the case of netbsd DCH 22-Oct-2008 Made change to MY::test to only run toplevel tests for 'make test' Do not attempt to build all of PDL, or attempt to look for and run subdirs tests. Also commented out some debug print statements in t/storable.t which caused warnings during 'make test'. CHM 19-Oct-2008 Basic/PDL.pm: change VERSION to 2.4.3_02 to indicate mods beyond the PDL-2.4.3_01 developers release just posted to CPAN CHM 19-Oct-2008 Basic/PDL.pm: change VERSION to 2.4.3_01 for developers release CHM 19-Oct-2008 TODO: this file is out-of-date and is so noted for PDL-2.4.4 README: added pointers for bug reporting via sf.net for PDL-2.4.4 Known_Problems: updated for PDL-2.4.4 release INSTALL: updated general install notes and added bug report info DEVELOPMENT: fixed reference to mailing lists locations DEPENDENCIES: updated list of dependencies for PDL-2.4.4. BUGS: updated the bug reporting information. CHM 19-Oct-2008 PDL/Graphics/TriD{TriD.pm,TriD/{ButtonControl.pm,Control3D.pm,GL.pm,Object.pm}} Removed explicit return calls in TriD constructors fixed to use fields::new() construction. This was the original coding style and may be required for Lvalue subroutine support. Tests still passed but in returning to the original usage without a return just in case for 2.4.4. SIS 19-Oct-2008 Switch off 3D in perldl.conf for Win32 (rev 1.49). Otherwise, the latest changes to Graphics/Makefile.PL break the build process for some versions of File::Find. CHM 19-Oct-2008 t/proj_transform.t: added test skip if PDL not configured with bad value support since the test appears to require bad value processing to succeed. This addresses sourceforge bug #2022265. CHM 18-Oct-2008 PDL::Graphics::Makefile.PL: folded in patch from rt.cpan.org PDL bug #30276 reporter which improves the logic for finding the xdpyinfo command for TriD configuration. The sourceforge bug corresponding is #1994614. CHM 18-Oct-2008 EDT PDL/Graphics/TriD{TriD.pm,TriD/{ButtonControl.pm,Control3D.pm,GL.pm,Object.pm}} Replaced direct FIELDS access in field based constructors with fields::new() to fix problem with 5.10 where the pseudohash implementation has been eliminated. SIS 19-Oct-2008 In Basic/Core/pdlthread.c, replace the few remaining malloc calls with Newx. (Rev 1.8) DCH 17-Oct-2008 Updated PLplot: Added several new low-level functions, added the 'stripplots' high level function. Also enhanced the Makefile.PL to make the stand-alone version of PDL::Graphics::PLplot work better for CPAN installs. Finally, applied a patch to Basic/Primitive/Makefile.PL to allow proper srand behavior, permitting the primitive.t tests to work. CHM 14-Oct-2008 perldl: Added FreeGLUT event loop support to perldl in analogy with the existing Tk event loop support. SIS 12-Oct-2008 Addition of link to bufferoverflowu.lib in CallExt.pm's callext_cc() for Windows x64 builds only (rev 1.9). SIS 11-Oct-2008 In top level Makefile.PL remove EU::F77 from PREREQ_PM, and fix $PDL::Config{TEMPDIR}, which I broke for non-Windows systems with the changes made on 8 Oct.(This latest change is rev 1.68 ) Also a Windows-only change to Basic/Core/Dev.pm (rev 1.33) as part of the change to $PDL::Config{TEMPDIR}. SIS 09-Oct-2008 Amend Lib/Slatec/Makefile.PL (rev 1.17) so that '*make realclean' doesn't clobber libg2c.a and libgcc.a when a Microsoft compiler is in use. Amend Lib/Minuit/Makefile.PL (rev 1.5), Basic/Core/pdl.h.PL (rev 1.13) and Basic/Gen/PP.pm (rev 1.49) to enable Minuit to build with Microsoft compilers. (All of these changes should be invisible to other compilers.) SIS 08-Oct-2008 Amend top-level Makefile.PL so that File::Temp->tmpdir() is assigned to Config.pm's $PDL::Config{TEMPDIR}. (This is so that Windows PPM packages will function correctly). Rev 1.67 CHM 07-Oct-2008 Basic/Core/Core.pm.PL: fixed alias creation to avoid compile warnings CHM 07-Oct-2008 Basic/Core/Core.pm.PL: Added zeros convenience aliases for zeroes. This is matches common American English and Matlab usages and is one letter shorter to type. SIS 06-Oct-2008 ExtUtils::F77->runtime not providing the required format for MSVC compilers. A minor fix put in place in Lib/Slatec/Makefile.PL to correct this. Rev 1.16 CHM 18-Sep-2008 Lib/GSL/INTEG/FUNC.c, Lib/GSL/INTERP/gsl_interp.pd, Lib/GSL/MROOT/FUNC.c Quieted pointer cast compiler warnings by replacing with calls to the INT2PTR() macro of the Perl API. This fixes sf.net tracker bug #1356282. CHM 17-Sep-2008 Lib/GSL/RNG/gsl_random.pd, Lib/GSL/RNG/typemap - added INT2PTR() macros to prevent typecast warnings (sourceforge bug tracker #1356282) CHM 14-Sep-2008 perldl.PL - added $PERLDL::HISTFILESIZE to control the number of lines history saved. Updated docs and incremented VERSION to 1.34. CHM 10-Sep-2008 t/pic_16bit.t - Added test for pnmtopng with corresponding skips to prevent PDL test failure due to NetPBM not being installed with a diagnostic to point out the possible problem. CHM 27-Jul-2008 t/matrixops.t - Added tests for SF bug #2023711 as an active placeholder for the problem. It was threading that allowed two piddles such as: [5,2] and [[5,2],[5,2]] to test as equal with a check such as abs($a - $b) since the result was [[0,0],[0,0]] with all elements suitably small... CHM 20-Jul-2008 IO/GD/GD.pd - Fixed warning messages about 'cast to pointer from integer of different size' by use of INT2PTR() and PTR2IV() Perl API macros rather that a raw typecast. No warnings now and all tests still pass on cygwin. CHM 19-Jul-2008 Basic/Ufunc/ufunc.pd - Fixed bug #2019651 in the pctover() routine, some minor changes to the index calculations and some bounds checks to avoid out-of-range indexing problems. Added a doc ref to the algorithm used. t/ufunc.t - added new test to verify the reported bug CHM 19-Jul-2008 Fixed Basic/Pod/FAQ.pod: updated version to 0.8 and added an entry on installing PDL into non-standard locations. Yes, it is just a standard perl module in that respect but this should make it easier for first time perl users to configure. CHM 19-Jul-2008 Fixed VERSION in Basic/PDL.pm to indicate cvs CHM 18-Jul-2008 Proj.pd, Lib/GIS/Proj/Proj.pd, fix undefined reference to _pj_list. SIS 18-Jul-2008 Minuit Makefile.PL (for Microsoft compilers only) now uses LDFROM instead of OBJECT. (rev 1.4) DAL 09-Jul-2008 pdl.PL - manually create blib/bin directory. Old EU::MM's don't make it. pdlcore.h.PL - update prototypes for pdl_setav_$type. CED 09-Jul-2008 Makefile.PL, Basic/Gen/Makefile.PL - fix bug #1994598 - circular dependency problems. CED 09-Jul-2008 Basic.pm - update documentation for xvals, yvals, zvals, allaxisvals. Merge allaxisvals and ndcoords. Fixes bug 1968382. CED 08-Jul-2008 update pdlcore.c.PL - fix the pdl_setav_$type and pdl_kludge_copy routines to fix bug 1540548. Add appropriate tests. CED 07-Jul-2008 update matrixops.pd - simple switcher to semi-broken SSL eigens function in non-symmetric case, together with a warning message. DAL 03-Jul-2008 Lib/Minuit/minuit.pd - fix call to mn_cierra (close) which prevented the log file from being closed. DAL 02-Jul-2008 t/minuit.t - fix to get around win32 logfile unlinking problem. DAL 27-Jun-2008 Lib/Func.pm - fixed small typo in documentation Basic/Ops/ops.pd - re-fixed spaceship operator docs. Also added BU_MOD macro for byte, ushorts to squash compile warnings (bug 1998037). pdl.PL - use $Config{cc} to compile, output now goes to blib/bin Makefile.PL - modified @exe_files and $cleanup to account for new pdl binary executable build location (bug 1747307) DAL 17-Jun-2008 Lib/Slatec/slatec.pd - avoided namespace collision with PDL::FFT. Basic/Matrix.pm - commented out buggy vcrossp & crossp functions. Built-in crossp works fine for PDL::Matrix objects. Basic/Core/Basic.pm, Basic/Pod/Impatient.pod - finally removed docs error which said '~' overloaded transpose. Basic/Ops/ops.pd - fixed documentation for spaceship operator t/minuit.t - output goes to temp (deleted) file instead of log.out Lib/Gaussian.pm - Added note to Bugs section calling the module unusable. MANIFEST, MANIFEST.SKIP - removed, added Lib/Gaussian.pm CED 15-Jun-2008 Lib/Gaussian.pm - updated sumover calling (bug 166107) CED 15-Jun-2008 Graphics/Makefile.PL - hacked openGL search path for (net|open|free)bsd, following Chris Marshall's path in bug 1573215. CED 15-Jun-2008 IO/Dumper.pm: fixed uudecode flags for (net|open|free)bsd, following 1573217. CED 15-Jun-2008 Graphics/Makefile.PL; Lib/Transform/Proj4/Makefile.PL; Lib/GIS/Proj/Makefile.PL: added references to lib64 directories... (bug 1465414) CED 15-Jun-2008 pdlcore.c.PL: fix comment style (fix bug 1339530) CED 10-Jun-2008 Minor fix to boundary conditions in transform.pd; stand by for more fixes to a bug Derek just discovered. DAL 12-Jun-2008 Prevent PDL::IO::Storable from clobbering %PDL::Config. DAL 09-Jun-2008 Incorporated Doug Hunt's 02-Apr-2008 Perldl.pm patch (bug 1552208). SIS 09-Jun-2008 Some minor win32-specific changes to t/pic_16bit.t (rev 1.2) DAL 08-Jun-2008 Incorporated Hazen Babcock's 18-May-2007 PLplot patch for drawing several windows simultaneously. CED 19-Apr-2008 Added basic table-inversion to t_lookup. It's craptacularly slow but it works. SIS 10-Apr-2008 In Basic/Core/Core.xs.PL, create $PDL::SHARE multiply defined. Changed: sv_setiv(Perl_get_sv("PDL::SHARE",TRUE), PTR2IV(&PDL)); to: sv_setiv(get_sv("PDL::SHARE",TRUE|GV_ADDMULTI), PTR2IV(&PDL)); (rev 1.32) DAL 07-Apr-2008 IO/FITS/FITS.pm: Fixed rfits so if NAXIS3!=0 && NAXIS==2 it doesn't create an empty dim. Fixed wfits so if writing a slice of a pdl it doesn't create header fields for the extra dims. t/fits.t: added test numbers to help in debugging DAL 05-Apr-2008 Lib/FFT/fft.pd: fixed overflow error for integer input data. t/fft.t: Uncommented a test that was a victim of this problem. Added Lib/Minuit/.cvsignore CED 3-Apr-2008 Basic.pm: transpose() is nicer now (fixed bug 1750912) complex.pd: fixed several dependency issues to other modules (3 bugs). DAL 08-Feb-2008 Small fix to lines in Graphics/PGPLOT/Window/Window.pm if the run-length-encoded pen piddle was as long as the piddle itself. DAL 13-Jan-2008 Fixed bug in Basic/Primitive/primitive.pd that caused uniqvec to fail if all the input vectors were the same. Fixes bug #1869760, which duplicated bug #1544352, which was resolved by CHM patch #1548824. Added test case to t/primitive.t to test for this bug. SIS 17-Dec-2007 In Lib/Minuit/Makefile.PL remove the MYEXTLIB assignment (for win32 only) - rev 1.3 CHM 14-Dec-2007 Fixed IO/Pnm/pnm.pd to support 16-bit image format IO with rpic() and wpic(). Added basic t/pic_16bit.t to test the functionality with PNM and PNG grayscale images. DAL 11-Dec-2007 Removed print statement in Lib/FFT/fft.pd that crept in during debugging. SIS 10-Dec-2007 Some versions of EU::MM want to write a postamble in Lib/Makefile that kills dmake. Add a sub MY::postamble to Lib/Makefile.PL that takes care of the issue. (rev 1.9) AJ 30-Nov-2007 syntax update in minuit.t CED & DAL 29-Nov-2007 Lib/FFT - fixed problem with floating-point ffts AJ 27-Nov-2007 Fixes to PDL::Minuit DAL 12-Nov-2007 Inserted logic to suppress warnings from PDL::Transform during 'make test'. Updated the FAQ with new mailing list info. CED 6-Nov-2007 PDL::AutoLoader - changed goto to a pass-through sub call, to avoid problems with autoload files that leave stuff on the stack (e.g. subs with Inline or XS definitions). By not goto'ing, we avoid scrozzling the stack in such cases. PDL::NiceSlice - add some (masked-out) debug prints in perldlpp() perldl - make the acquire/filter/execute loop $_-safe by using $lines instead of $_ for all the central modifications. Avoids problems with some AUTOLOAD functions that leaked $_. CED 5-Nov-2007 PDL::NiceSlice - fixed use/no problems, both in eval and non-eval cases (I think). HG 16-Oct-2007 Lib/GSL/Makefile.PL: fix the gsl version check for minor versions bigger than 10 Lib/Fit/Gaussian/gaussian.pd: include "use PDL;" in synopsis DAL 30-Aug-2007 slices.pd: Fixed bug in range's negative size handling for ND piddles. CED 23-July-2007 slices.pd: Fixed negative-range problem (bug 1758614): disallow negative sizes in ranges. transform.pd: fixed bug in t_lookup table declaration CED 13-Jun-2007 Fixed sign error in t_fits (transform.pd) CROTA interpretation AJ 21-Jun-2007 Added PDL::Minuit Modified recovery mechanism in PDL::GSL::INTEG DAL 13-Apr-2007 Fixed subtraction error (previously introduced by me) in t/primitive.t. CED 12-Apr-2007 Add qsortveci to ufunc.pd, to round out the complement of qsort methods. DJB 18-Mar-2007 Internal clean up of Basic/Core/pdlthread.c; v1.6 used its own copy of strndup to copy arrays whereas we now (v1.7) use the Perl C API (Newx/CopyD/Safefree). This should be invisible to the user. + changed dates below from 2006 to 2007:-) DAL 14-Mar-2007 Fixed previous (09-Mar) fix; t_identity was not the right solution. DAL 09-Mar-2007 PDL::Transform::t_fits now returns t_identity if there is no good xform. DAL 06-Mar-2007 Fixed bug in setops (Basic/Primitive/primitive.pd) which broke 'OR'. Added support for sets with non-unique elements, which broke all set operations. Added tests in t/primitive.t for setops. Fixed t/pgplot.t interactive tests. Fixed typo in cat docs (Basic/Core/Core.pm.PL). SIS 30-Dec-2006 Skip the second test in autoload.t on Microsoft Windows (autoload.t rev 1.4) DAL 28-Nov-2006 Fixed AutoLoader tilde expansion bug, added test to t/autoload.t DAL 21-Nov-2006 Fixed window-closing bug in the regular PGPLOT demo. Small documentation fix for convolveND in Lib/ImageND/imagend.pd. CED 24-Oct-2006 fix inverted logic bug in t_perspective inplace access (Transform/Cartography) DAL 23-Oct-2006 Fixed annoying operator precedence warning in Cartography.pm CED 13-Oct-2006 Fix Transform off-by-1/2 bug with pixel addressing; add transform.t Fix uniqvec bug in primitive.pd DAL 11-Oct-2006 Minor PGPLOT/PGPLOT.pm and PGPLOT/Window/Window.pm documentation fixes. SIS 24-Sep-2006 Minor re-arrangement to the code in Lib/GSL/MROOT.c required for Microsoft compilers (rev 1.2). SIS 17-Sep-2006 Enable 'BUILD_NOISY' in Pdlpp.pm on Win32 (rev 1.10). Small cleanup of the code that sets the temp directory in the top level Makefile.PL (rev 1.64). HG 15-Sep-2006 Extend the 64bit-architecture test in t/flexraw.t and include ia64 in the blacklist SIS 11-Sep-2006 Enable building of GSL on Win32. Changes to Lib/GSL/DIFF/Makefile.PL (rev 1.3), Lib/GSL/INTEG/Makefile.PL (rev 1.3), Lib/GSL/INTERP/Makefile.PL (rev 1.3), Lib/GSL/RNG/Makefile.PL (rev 1.5), Lib/GSL/SF/Makefile.PL (rev 1.5), Lib/GSL/MROOT/Makefile.PL rev 1.2. Also needed a slight tweak to Basic/Core/Dev.pm's pdlpp_stdargs_int (rev 1.32). DJB 07-Sep-2006 Continued work on Basic/Gen/PP.pm (revision 1.48). This deals with the old subst_makecomp routine moving to PDL::PP::Rule::MakeComp. Added an explicit test of assgn to t/bad.t Converted t/gsl_interp.t to use Test::More. DJB 06-Sep-2006 Converted t/gsl_mroot.t to use Test::More and fixed a bug that caused it to fail when PDL::GSL::MROOT is not installed. DJB 02-Sep-2006 Continued work on Basic/Gen/PP.pm (revision 1.47) AJ 01-Sep-2006 Added PDL::GSL::MROOT SIS 1-Sep-2006 Remove dmake clause from pdlpp_postamble() in Basic/Core/Dev.pm. Revision 1.31. DJB 31-Aug-2006 Re-worked Basic/Gen/PP.pm to use objects for the $PDL::PP::deftbl array rather than array references, since using objects just has to make things easier to read :-) There should be purely an internal change. This is revision 1.46. Basic/Gen/PP/PDLCode.pm has also seen a few minor changes (again purely internal). This is revision 1.7 CHM 24-Aug-2006 Fix qsortvec function resolving bug #1544590 on sourceforge. Really need to add tests corresponding to bugs with the fixes. TBD. SIS 25-Aug-2006 Remove the 'goto' in Graphics/IIS/Makefile.PL - was causing a problem on some builds of Win32 perl. (Revision 1.2) DJB 24-Aug-2006 Changed Basic/Gen/PP.pm so that it is now all run under ;use strict'. There should only be an internal change (this is revision 1.45) DAL 22-Aug-2006 Fixed a minor typo in FAQ.pod and a small doc change to Fit::Gaussian. DJB 22-Aug-2006 Cleaned up t/slice.t to use Test::More. This was in an attempt to help track down the message reported during 'make test': "(in cleanup) index out-of-bounds in range during global destruction." However, the conversion seems to have removed this message... CHM 20-Aug-2006 Merged 2.4.3 development fixes into main CVS trunk. CHM 17-Aug-2006 Updated rel_2_4_3pre_branch with debian fixes by HG and added the decided upon fix for HDF/Makefile.PL for the PM location. CHM 16-Aug-2006 perldl.conf, IO/FITS/FITS.pm - fixes for $PDL::Config{FITS_LEGACY} to turn off all the zillion Astro::FITS::Header warning messages Graphics/Makefile.PL - fix GLX test not to ignore user forced WITH_3D=>1 cygwin/INSTALL, cygwin/README - update some of the cygwin/ install notes based on recent testing and module fixes will be tagging these fixes as rel_2_4_3pre2 CHM 14-Aug-2006 Touch up top level documentation files and add some config files to PDL/cygwin/. Files changed: BUGS, COPYING, DEPENDENCIES, DEVELOPMENT, INSTALL, Known_problems, README, Release_Notes, cygwin/INSTALL, cygwin/README. CED 13-Aug-2006 Fixed typo with CI_J matrix declaration in t_fits code (transform.pd); allows use of CI_J matrices in FITS headers as per the newer WCS standard) CED 13-Aug-2006 - Minor fixes to Transform -- t_fits CI_J header notation; also: dims copied between params and main object in t_spherical and t_projective. CHM 11-Aug-2006 - Added Astro::FITS::Header as a PREREQ_PM in main Makefile.PL - Added to DEPENDENCY file list - Put preliminary notes on how to migrate an externally developed PDL module into the source tree for distribution with PDL CHM 11-Aug-2006 Fix Graphics/Makefile.PL be more conservative in deciding to build OpenGL and TriD when WITH_3D => undef. Now choose not to build if the xdpyinfo command does not indicate available GLX extensions for the current X server display. This should prevent test failures due to some OpenGL X config problems. DCH 10-Aug-2006 Changed slatec.t test from: ## Test: chia $x = float( sequence(11) - 0.3 ); to ## Test: chia $x = double( sequence(11) - 0.3 ); This allows this test to work on a 64 bit machine (AMD x86_64) Also, skip the flexraw.t tests for x86_64 (these tests only apply to 32 bit machines) DCH 10-Aug-2006 Changed from $ENV{HOSTTYPE} to $Config{archname} for x86_64 check in order to set -fPIC compiler flag. CHM 09-Aug-2006 Updated Known_problems and minor doc fix. CHM 08-Aug-2006 Fixed t/proj_transform.t to skip_all if WITH_BADVAL not set so with Judd Taylor fixes from earlier today all PROJ4 modules now build and test on PDLrc1. Thanks all for testing a fixes! DAL 01-Aug-2006 Fixed typo in t_spherical of transform.pd (closes bug 1530666). CHM 30-Jul-2006 Updated release notes in preparation for 2.4.3 release. Known_Problems will follow. CHM 27-Jul-2006 Created cygwin/ directory with first drafts of README and INSTALL files for Cygwin users. CHM 26-Jul-2006 Minor wording changes to skip_all messages for test output to improve readability. DJB 24-Jul-2006 Fix for valgrind-detected error when WITH_BADVAL option selected. There was an invalid read due to $PRIV(bvalflag) being checked after $PRIV() was invalidated (by a call to PDL->make_trans_mutual). The code changes (e.g. see copybadstatus in PP.pm) indicate there is some future code cleanup/optimisations that could be made, but leave for post 2.4.3 work. Stop the "re-defining PERL_UNUSED_DECL" warnings from perl 5.8.8 by updating the ppport.h from the latest Devel::PPPort (v3.09). Removed ppport.h copy in Graphics/PGPLOT/Window/. DJB 22-Jul-2006 Fix to pdlcore.h.PL to avoid valgrind warning: rev1.26 put the setting of the debug_flag inside an ifdef but the variable is used to decide whether to print out a warning about pdl_setav_ converting undef's to $PDL::undefval. Easiest solution is to remove the ifdef (could have removed the use of debug_flag in the if statement instead). CED 18-Jul-2006 - PDL.pm: added help cross-reference to pdl() - t/core.t: add three constructor tests - pdlcore.c.PL: Fix a more obscure problem with constructor - pdlcore.c.PL: Fix problem with constructor (pdl( zeroes(100), ones(10)) case) DJB 10-Jul-2006 Fix up compile warnings in Core/ seen on Solaris - moved pdl_freedata from pdlhash.c to Core.xs.PL - added pdl__print_magic to pdlmagic.h (for pdlapi.c) - include sys/mman.h for pdlmagic.c (if USE_MMAP defined) Minor pod fixes to primitive.pd CHM 09-Jul-2006 Fix skip_all output for t/fftw.t and plplot.t. CHM 08-Jul-2006 Update flexraw.t, gd_oo_tests.t, gd_tests.t, gis_proj.t, hdf_sd.t, hdf_vdata.t, hdf_vgroup.t, inlinepdlpp.t, ndf.t, pgplot.t, and proj_transform.t test scripts to use Test:More and skip_all to report when a test is completely skipped due to major functionality missing or not available. The original skip method was to reduce the number of planned tests to 1 and then to skip that *single* test (subtest, actually). It was not possible to tell from the "make test" harness output that the functionality being tested was not available at all or even installed! These changes set the plan output for these missing functionality tests being skipped to "1..0" which is reported as "...skipped" followed by "all skipped: " The output from "make test" now indicates if something is missing from the build/install. DJB 29-Jun-2006 Updated $pdl_core_version in pdlcore.h.PL to 6 since the code for the experimental BADVAL_PER_PDL feature added fields to the Core struct (see 'pdldoc Internals' for info on why the variable needs to be updated). *** Warning: this means that - once this change is built and installed - any external module that uses the C interface of PDL will have to be re-built/installed (they'll complain and refuse to run until you do so). DAL (24-Jun-2006) Added FAQ question (#6.22) showing how to get PGPLOT to write PNG files. Also updated the CVS commands in the FAQ. HG (22-Jun-2006) Fix the TriD::OpenGL build issue with newer X installations by importing Bill Coffman's patch for Graphics/TriD/OpenGL/opengl.pd (closes bug #1505132) DJB 20-Jun-2006 Attempt to clean up building of Basic/MatrixOps: - fix a nan issue on Solaris (use atof("NaN") ratehr than nan("")) - moved source code from ssl/ sub-directory into parent so that we do not have to try and write our own Makefile for these files (with attendant OS/system complexities) but let Perl worry about it all DJB 19-Jun-2006 The experimental BADVAL_PER_PDL feature can not (currently) be combined with BADVAL_USENAN. The build now detects this conflict and turns off BADVAL_USENAN. The docs need updating to discuss this option! CED (16-Jun-2006) Work around -0 problem on macOS 10.4 PPC: some numbers (notably constructions of the form "pdl( 5 ) % 5") yield a value of "-0" rather than "0" under that OS. Fix is in the pdl_at routine in core/pdlsections.g: forces 'c'-false values to be truly 0 during export to perl. The hack is accomplished via -DMACOS_MZERO_BRAINDAMAGE, so the (infinitesimal) CPU cost doesn't affect other platforms. CHM (12-Jun-2006) Fix to GD portion [only] re sourceforge bug #1493056: - Replace pdlpp_postamble() call in PDL/IO/GD/Makefile.PL with the same call to pdlpp_postamble_int(). Don't know the details but this puts the right blib path includes for PDL::IO::GD to build on clean perl (no previous PDL install). - Removed "use PDL;" from GD.pd which broke the GD build process without a pre-existing PDL install. - Removed cygwin workaround for WITH_GD setting in perldl.conf. CED (6-Jun-2006) (finally) fix TriD rotation bug. What an evil crock that module is! CED (4-Jun-2006) Fix Makefile.PL for Proj -- now doesn't attempt to build proj modules when proj is not present on the system. CHM (30-May-2006) Fix t/flexraw.t to use eval to prevent a missing IO::String module from preventing the test to run. IO::String is required for perls before 5.8.0. The perlio for 5.8.0 and later perls supports the same functionality with the native open call. CHM (29-May-2006) Fix perl Makefile.PL build process to allow TriD (OpenGL) to build on cygwin. - Graphics/Makefile.PL -- set OPENGL_LIBS, OPENGL_DEFINE, OPENGL_INC - Graphics/TriD/Makefile.PL -- add *.dll.a to @patterns to test Cygwin now builds out of the box with base modules and TriD(OpenGL) and PLplot (need to have plplot bin directory in PATH for tests to pass). CHM (28-May-2006) Fix Graphics/PLplot/Makefile.PL to allow plplot to build on cygwin. Chris Marshall-a.k.a. CHM or marshallch (28-May-2006) Updated Changes file to reflect CVS submissions on 22-May-2006 to incorporate accumulated patches to allow PDL to build on cygwin unix environment. The patches close bug 1093510 and affect the following files: - Makefile.PL (fixed to specify .exe extension for binary file installs) - Lib/GSL/SF/coulomb/gsl_sf_coulomb.pd (fixed typo) - Lib/GSL/SF/poly/gsl_sf_poly.pd (fixed typo) - t/flexraw.t (added line wrap into f77 continuation lines to handle cases where lines longer than 72 chars were being generated; worked around a problem with a subtest using the compress command---on cygwin this is a non-functional "reminder" script---gzip was used instead) - perldl.conf (set cygwin default to skip new GD and Proj modules until a build issue can be investigated, a bug report has been submitted) Base PDL now builds with the default CVS code. Work continues to fix issues with TriD(OpenGL), PLplot, FFTW, and PGPLOT. JT (12-Apr-2006) Added the PDL::IO::GD module, and tests. JT (5-Apr-2006) Added the PDL::GIS::Proj and PDL::Transform::Proj4 modules and matching tests to t/ directory. DAL (5-Apr-2006) FAQ update. Perl/PDL versions, links, etc. No new questions added. Fixes bug 88964. SIS (2-Apr-2006) Fix bug that in Lib/Slatec/Makefile.PL that could prevent the Makefile from being written. Have Basic/Core/Dev.pm's pdlpp_postamble() return nothing for dmake. (A call to pdlpp_postamble() was breaking dmake - but dmake has not yet needed such a postamble anyway.) JT (29-Mar-2006) Added in the PDL::IO::HDF module, version 2.0, which has been extensively reworked (see the Changes doc in that dir for more info on those changes). Added new entries to the perldl.conf file, modified some of the Makefile.PL's to have that build, and added test files to the t/ directory. This also fixes bugs 1432707 and 1432720. JLC (23-Mar-2006) Fixed bug in PDL::Complex::initialize that caused problems when using PDL->cat with PDL::Complex objects. Added to the complex.t test case to check for this condition. SIS (21-Mar-2006) 'use blib;' added to Demos/BAD_demo.pm.PL and Demos/BAD2_demo.pm.PL to work around EU::MM-6.30 bug. SIS (19-Mar-2006) Alteration to Basic/Core/Makefile.PL to enable proper inclusion of badvalues on nmake-built PDL (Win32 only). SIS (18-Mar-2006) Small change to Basic/Core/Core.xs.PL's at_bad_c function so it will compile with Microsoft compilers. CED (17-Mar-2006) Test & Incorporate patch 1093515 - Marshall's fits.t mod Test & Incorporate patch 1095517 - Klein's badval support Test & Incorporate patch 1099405 - Klein's per-PDL badval support. (per-PDL badval support currently breaks the test suite and should be considered experimental only.) Remove debugging lines from 1151418 fix (yesterday) CED (16-Mar-2006) Fix bug 1176634 (zeroes/ones from derived classes, e.g. Complex) Test & Incorporate patch 1176619 (formatting of Complex values) CED (15-Mar-2006) Fix bug 1151418, problems with bad values in matrix multiplication (actually inner). Also: try to debug slatec under 64 bits... CED (14-Mar-2006) IO/Dumper.pm: Fix bug in dumper.t in UU:convert-only case t/slatec.t: instrument Slatec test DAL (14-Mar-2006) In Primitive.pd, the uniq family of functions now behave properly when the input piddle has bad values. CED (10-Mar-2006) 1338982 (obscure bug reading a FITS file) 1220830 (problems with $#$-type scalars in SvPDLV) - take 2 CED (10-Mar-2006) Fixed bugs: 1435138 (problems with compress on Suse 9.3) 1386260 (installation fixes for 64bit linux) 1350149 (fatal typo in Graphic::TriD::Rout) 1350130 (conflicting defines in Graphics/IIS) 1262194 (bad quoting in Core/Dev.pm require statment) 1209924 (range() truncate is not setting values bad when truncating) CED (9-Mar-2006) Finished fixing the TriD code. The problem had to do with the codewalker that harvests function definitions and typedefs from the GL header files. The solution involves passing the header files through the C preprocessor to handle compile-time switching, autogenerating simple typemap declarations from typedefs, and fencing the header files so that function definitions from included files are not detected by the harvester. Blech. Someone really needs to overhaul this stuff. I really hope it's not me. CED (8-Mar-2006) Added -fPIC to Makefile.PL on 64-bit platforms; attempted to make TriD work on 64 bit platforms (not yet successful -- will check in fix later). SIS (14-Feb-2006) Changes to top level Makefile.PL, Core/Basic/Makefile.PL, and Core/Gen/Makefile.PL to override EU::MM's processPL() which is continually being broken on Win32. Also rewrite limits_normalize_dsets.t so that it's not broken by Test::More bug. DAL (12-Jan-2006) Set correct x-y bounds for circle in PGPLOT/Window.pm. Added function tcircle based on tpoints and tline. Fixed convolveND method selection, bug #1323973. Fixed docs (usage and signature) bug in statsover to show correct number and order of returned quantities. SIS (8-SEP-2005) Enter Chris Marshall's patched version of t/limits_keyspecs.t. Fixes one of the #1221742 bugs. CED (1-Aug-2005) update docs for PDL.pm; re-fix recursion error message HG (2-June-2005) Fix PLplot's Makefile.PL to clean up temporary files HG (2-June-2005) add 'clean' and 'realclean' targets to the non-windows version of Basic/MatrixOps/ssl/Makefile HG (2-June-2005) remove the now unneeded debian/patches/10_fix_clean_target.dpatch HG (1-June-2005) Apply most of the 'make clean' from debian/patches/10_fix_clean_target.dpatch HG (1-June-2005) Apply debian/patches/50_relative_paths_in_htmldoc.dpatch, which changes paths in HTML docs to relative instead of absolute ones. HG (1-June-2005) Apply debian/patches/20_dont_overwrite_pdl_1p.dpatch, which prevents pdl.1p (generated from Basic/Pod/Intro.pod) being overwritten by autogenerated pdl.1p from pdl.PL DCH (31-May-2005) Added limited bad value support to gsl_interp.pd. Added badval test case to t/gsl_interp.t CED (19-May-2005) Fixed minor bug in Windows.pm, updated MANIFEST to remove Debian patches (so "make dist" works), smoothed demos a bit. AJ (10-May-2005) Modified gsl_interp.pd and gsl_random.pd to pass pointers as IVs in OtherPars following Judd Taylor's suggestion. JB (9-May 2005) Added set operation routines - setops in primitive.pd as well as intersect which is just an alias. Also updated the docs so that apropos threshold will bring up clip.. JB (6-May-2005) Improved version of typemap handling in OtherPars in PP.pm checked in and documentation for PP updated to include a discussion of typemap handling in OtherPars. I also realised I forgot a few updates earlier: I fixed a problem in the FITS reader which kept you from reading in only the header from files with empty primary arrays. And a few other small bug fixes around. I am awful at Changelogs.... HG (3-May-2005) Apply some of the 'make clean' fixes from debian/patches SIS (2-May-2005) Fix Slatec/Makefile.PL so that it doesn't break for Win32 users building with MS compilers and f2c. HG (1-May-2005) Remove debian-patches which are already in PDL cvs HG (1-May-2005) Fix MANIFEST to include the current debian/* files HG (30-Apr-2005) Apply debian/patches/60_remove_obsolete_upstream_debian_files.dpatch and remove the file CED (19-Apr-2005) Checked in Alexey Tourbin's patch in rout.pd SIS (9-Apr-2005) In perldl.PL, set $HOME more appropriately for Win32. CED (7-Apr-2005) Added warning message to FITS module load, if Astro::FITS::Header is not available. AJ (01-Apr-2005) Modified PDL::GSL::INTEG to enable the calculation of nested integrals DJB 9-Mar-2005 Fixed dumn mistake in wfits docs I made; it is TTYPE and not TFORM that are used to specify the order of columns in FITS tables! CED 9-Mar-2005 pdl.h, pdlapi.c: Added guardrails to the dependency-loop detector. (1) error message is now more explanatory. (2) the detector now resets its counter when tripped, so that you can continue to use PDL once it has been activated. (formerly, every operation following a trip caused another error message). SIS 28-Feb-2005 At last - a fix for the MakeMaker bug affecting dmake (Win32). No longer any need for the ugly hack that enabled PDL to be built with dmake. Deleted one line of code from the top level Makefile.PL. Deleted several lines from Basic/Core/Makefile.PL and added a sub MY::processPL and a sub MY::postamble for dmake. Fix supplied by Steve Hay. DJB 23-Feb-2005 (EST) t/pgplot.t now uses $PGPLOT_DEV to set the output device, falling back to "/xw", rather than forcing "/xw". Cleaned up t/pgplot.t (no new real functionality) other than above. CS 24-Feb-2005 Remove 'use UNIVERSAL' for Core.pm.PL; shouldn't be needed anyway and gave strange import problems when using PDL with Net::SSH::Perl; also needed a change of isa to UNIVERSAL::isa in Dbg.pm SIS 23-FEB-2005 Another small tweak to Basic/Core/Makefie.PL to improve the hack that enables PDL to be built using dmake (Win32). Amend Basic/Core/pdlcore.c.PL to cater for "finite" with Microsoft compilers. This correction pointed out by Vanuxem Gregory - thanks Greg. SIS 14-FEB-2005 Minor alteration Basic/Core/Makefile.PL to address a MakeMaker bug. (Users now don't need to edit MM_Win32.pm.) Minor alterations regarding definition and usage of TESTTYPE() macro with Microsoft compilers in pdlcore.c.PL. Update win32/INSTALL to reflect changes. SIS 12-FEB-2005 Tidy up some things relating to Win32. All alterations of a minor nature. Files affected were Makefile.PL, Basic/Core/Dev.pm, Basic/Core/Makefile.PL, Basic/MatrixOps/ssl/Makefile.PL and win32/INSTALL. SIS 10-FEB-2005 Another change to Basic/Core/Makefile.PL to simplify build procedure on Win32. SIS 6-FEB-2005 Minor changes to Basic/Core/Makefile.PL, Basic/Core/Dev.pm, and the top level Makefile.PL to simplify build requirements/procedures on Win32. SIS 5-FEB-2005 Provide an alternative TESTTYPE() macro (in pdlcore.c.PL)for Microsoft compilers. (Addresses failures in conv.t and matrixops.t tests.) SIS 4-FEB-2005 Enact some minor changes in the following files so that PDL will build on Win32: pdl.PL, Makefile.PL Basic/MatrixOps/matrixops.pd Basic/MatrixOps/ssl/Makefile.PL Lib/CallExt/CallExt.pm Lib/Slatec/Makefile.PL t/callext.t, t/croak.t, t/flexraw.t, t/matrixops.t win32/INSTALL (Rewrite to reflect changes in build procedure) CED 1-Feb-2005 Fixed minor bug in convolveND with kernel threading CED 18-Jan-2005 pdlcore.c.PL: fixed a pointer arithmetic issue that was causing trouble under Windows. Thanks, Sisyphus! CED 18-Jan-2005 - added segfault.t to test suite CED 16-Jan-2005 - pdlcore.c.PL: Following Alexey Tourbin's awesome research, removed a segfault problem when foreign blessed objects are pdlified. Now, SvPDLV croaks if a foreign blessed object is detected (avoiding a segfault); but stay tuned: there might be a better answer in this case. CED 13-Jan-2005 - transform.pd: remove typo introduced in removal of C double types (thanks, Henning!) CED 09-Jan-2005 - Core.pm.PL: Restored original barf behavior: reports error where it occured in user code, not within PDL. - primitive.pd: Matrix multiplication now requires that the second argument's second dim equal the first argument's first dim (as required for matrix multiplication; previous threading case made no sense). - Core.pm.PL: restored barf() to its documented behavior (had been commented out and replaced with Carp::croak()...) - t/matmult.t, t/misc.t: added more matrix multiplication tests; fixed test in misc.t to accept error messages with "PDL:" in front. CED 07-Jan-2005 - Updated PDL version to '2.4.2cvs' - In a fit of insomnia, lifted code for non-symmetric eigenvalue problems from Kenneth Geisshirt. (http://kenneth.geisshirt.dk). Resolves bug 1098245 and gets a long-standing annoyance off my back. DJB 06-Jan-2005 - Fixed norm() to correctly handle bad values. Added test case to bad.t (and changed to use Test::More rather than Test module and PDL::Core::approx). DJB 28-Dec-2004 - Clean up of t/fftw.t (use Test::More and PDL::Core::approx()). Small increase in the tolerance used for checks (1.1e-4 to 1.2e-4) to avoid occasional test failures seen on Solaris. 2.4.2 released 28-Dec-2004 CED 27-Dec-2004 - Window.pm: fixed bug 1091534 (problem with rect()) DJB 23-Dec-2004 - Set the WITH_3D option in perldl.conf to be 0 rather than undef on OS-X since there are still problems with the build. Also added a path to the GL headers to Graphics/Makefile.PL and opengl.pd for OS-X (in case the problem gets fixed). I think the whole build process for the 3D stuff should be re-worked if anyone has enough tuit's. CED 17-Dec-2004 - PDL 5.6 is now deprecated by the Makefile.PL - Fix problems with test suite when Astro::FITS::Heder is not installed. CED 13-Dec-2004 - uninitialized memory patch 1083663 (thanks, Miloslav!) CED 11-Dec-2004 - transform.pd: added projective transforms (t_projective) - slices.pd: added Miloslav's patch (patch #1083663) CED 4-Dec-2004 - DiskCache.pm: Fixed problem with syncing to disk on store (typo in code) - Lib/Opt/Simplex.pm: Fixed bug 1057022 (Opt::Simplex bug; thanks, Marcus) - slatec.pd: Fixed bug 1076817 (matinv doesn't thread). Fixed bug 1075203 (trailing underscores; thanks, Luc). - Makefile.PL: Made bad-@INC problems more apparent when found. ('.' at front of @INC causes trouble for build; this is now detected and the user gets warned.) DJB 28-Oct-04 - removed some header comments which caused problems with (presumably older) versions of Astro::FITS::Header (for PDL::IO::FITS::wfits) DJB 27-Oct-04 - fixed wfits() to write out ushort columns as Int4 (J) format (ideally we should write out as Int4 (I) and use TSCALE/ZERO). Added tests for this and other column types. Removed support for writing out PDL::Complex piddles for this release. - cleaned up the limits* tests so that they are skipped if PDL::Slatec is not installed. DJB 21-Oct-04 - clean up of code to fix remaining validation errors reported by fverify (the Type value passed to Astro::FITS::Header::Item must be in upper case to get correct format for each card). Not 100% convinced caught all cases. DJB 20-Oct-04 - PDL::IO::FITS::wfits updates for table writing: BITPIX must be the second card (or else fverify from FTOOLS throws a wobbly); fixed writing a comment card (caused messages under use strict/-w); the data area is now filled with \0 rather than " " (both tables and images). Note that fverify still complains that the keywords are not written out correctly (the comments do not start in column #32 I think). Removed the use of the FITS file handle from the whole module (now uses IO::File throughout). Added some very basic table tests to t/fits.t. CED 15-Oct-04 - fix a few oddball cases in permissive constructor CS 07-Oct-04 - fix warnings in some test scripts DJB 06-Oct-04 - PDL::Graphics::PLplot doc. updates: include internal and external links; use of head3 elements for options; added blank lines between pod statements (if not included these statements are treated as text); addition of "extra" markup (C<> and F<> items). CED 17-Sep-04 - primitive.pd: stats updated to use statsover for better agreement - statsover modified to promote mean etc. to floating-point. - removed "$temp" magic variable from perldl -- now it's only available in the "PERLDL" package. (assigning to $temp crashed perldl; this fixes that.) CS 15-Sep-04 - complex.pd: applied Vanuxem Grgory's patch and added some tests; should close bug 1010164 CED 15-Sep-04 - primitive.pd: Fix to statsover - Makefile.PL, etc.: Added HTML_DOCS configuration option - Fixed non-portability issue in t/diskcache.t CS 07-Sep-04 - make the reduce function a bit more flexible: reduce over list of dims and allow code references CED 19-Aug-04 - Fixed OpenGL build to work with Mandrake 10 (this will need better fixing later, but should work OK with all current distros). DCH 30-Jul-04 - Cleaned up plplot.t a bit. Made compilation of plplot routines plsvect and plvect dependent upon a recent enough version of plplot. DCH 29-Jul-04 - Cleanup in plplot.d. Fixed documentation bug 959902. Fixed line width specification (LINEWIDTH option). Fixed test bug in limits_ulimits.t (floating point comparison error in array_eq) CED 29-Jul-04 - Fixed Makefile.PL for PLPlot, to pay attention to $PDL::Config hash (was checking $PDL_CONFIG instead). Ditto plplot.t DJB 29-Jul-04 - added tests to t/core.t for $PDL::undefval fix (bug#886263 fixed by Craig) and cleaned up the test to use Test::More (was Test). CED 28-Jul-04 - updated constructor and conversion routines to handle $PDL::undefval properly. Since I don't like action-at-a-distance, I also added tripwires to this activity if $PDL::debug is set -- hopefully that mitigates the horror somewhat. CED 21-Jul-04 - changes to perldl.PL to allow script handling. - introducing "pdl", a byte-compiled trampoline that spawns off a perldl. "pdl"'s advantages: (a) it's two characters shorter to type, and (b) you can use in in a shebang. CED 15-Jul-04 - Modified flexraw.t test to not overrun 80-column card images for reasonably sized file names (it will still break if fed a file name that is unreasonable). CED 07-Jul-04 - Modified Pic.pm to look for alternate JPEG converters where appropriate. This allows use of netpbm instead of pbmplus. DJB 01-Jul-04 - pdlcore.c.PL/pdl_kludge_copy_<>() issues: changed \n to \\n in some error messages (would not compile otherwise) and a switch statement is now auto-generated from %PDL::Types::typehash rather than hard-coded CED 17-Jun-04 - pdlcore.c.PL: av_ndcheck and pdl_setav_$type now support PDLs thrown into the mix. I noticed that PDL::undefval doesn't seem to function (see "help pdl[2]") but left it that way for philosophical reasons. CED 16-Jun-04 - perldl.PL: comment lines are filtered out before passing through Text::Balanced, and quotelike operators (e.g. "s/foo/bar/" or "qq/foo/") are ignored for line parsing. Those constructs rarely cross lines in common usage, and they cause lots of trouble with Text::Balanced. CED 1-Jun-04 - PP.pm: fixed deep header copying -- now neither crashes nor leaks memory. - slices.pd - added a paragraph to the range() documentation - FITS.pm - added a couple of minor notes to the rfits() documentation. CED 28-May-04 - primitive.pd: fixes to glue() DJ 21-May-04 - added Graphics::Limits, which determines display ranges for multiple concurrent data sets - Primitive: fix to which/which_both bad value code to make it work when BADVAL_USENAN = 1 CED 30-Apr-04 - perldl: warns if AutoLoader is not loaded by perldlrc; avoids a suite of installation follies. - FITS.pm: rfits() clears hdrcpy flag by default - pdlapi.c, PP.pm: minor readability cleanup - Core.pm.PL: introducing hcpy, a pass-through hdrcpy clone. Also, minor fixes to deep copying. Deep header copying still leaks memory; it's not (yet) obvious why. [ Removing the refcnt increment in PP.pm causes crashes, so, er, that's not it. ] CED 15-Apr-04 - FITS.pm: minor fix for all-BAD case. CED 08-Apr-04 - NiceSlice.pm, Core.pm.PL: added dummy syntax to NiceSlice. - slices.pd: minor improvements to documentation CED 04-04-04 (heh). - slices.pd: range - Added extra speedbump to avoid common programming error (more than five implicit dims throws a warning) - transform.pd: map - Added some extra dimensionality checks CED 26-Mar-04 - Primitive: which() now ignores bad-value entries (before it always selected the BAD value). - Primitive: uniqvec() now works properly if you feed in a lone vector. - added tests for these cases. CED 17-Mar-04 - Transform: added match() convenience routine - Demos: added a rotating-coordinate-system demo to "demo transform" - Window.pm: fixed up _fits_tr to actually line up right with the FITS coordinate system. - Doc::Perldl.pm: fix for perl 5.8.0 compatibility (string interpolation is a little more agressive in the earlier versions) DJB 17-Mar-04 - Updated PLplot build so that it works on OS-X, and will automatically pick up the library if installed via FINK [currently only in unstable] CS 17-Mar-04 - Basic.pm: add (x|y|z)logvals CED 16-Mar-04 - IO::Pnm::Pic.pm: added wim() and rim() for more uniform RGB handling. - Doc::Perldl.pm: help module now gracefully handles multiple matches, and also ignores SIGPIPE if you quit the pager. - Graphics/PGPLOT/Window/Window.pd: added DirAxis option to initenv(). RL 16-Mar-04 - Graphics/PLplot/plplot.pd: Defined low-level interfaces for plmesh, plmeshc, plot3d and plscmap1l in which the size arguments are deduced from the piddles. Example x11.pl in the PLplot sources is completely ported to PerlDL now. RL 15-Mar-04 - Graphics/PLplot/plplot.pd: Implemented the low-level PLplot API functions pltr0, pltr1, pltr2, and plcont. Added some 'Doc' place holders in the pp_def's. RL 13-Mar-04 - Graphics/PLplot/plplot.pd: Define our own plstyl subroutine, where the first argument of c_plstyl (the length of the mark and space vectors) is deduced from the piddle. RL 11-Mar-04 - Graphics/PLplot/plplot.pd: Use the here-document operator (<<) for multi-line strings. This makes the style of code more close to Doug's original style. RL 8-Mar-04 Graphics/PLplot/plplot.pd: - Implement the #define'd constants in plplot.h as functions in Perl, whose pp_def's are automatically generated by the create_low_level_constants function. - Added interface for the PLplot function plsurf3d. This has been tested with the example x08.pl, recently added to the PLplot CVS sources. RL 5-Mar-04 - Graphics/PLplot/plplot.pd, t/plplot.t: Define our own plfill and plsym subroutines, where the first argument of c_plfill and c_plsym (the length of the data vector) is deduced from the piddle. RL 4-Mar-04 - Graphics/PLplot/plplot.pd, t/plplot.t: Define our own plhist perl subroutine, where the first argument of c_plhist (the length of the data vector) is deduced from the piddle. CED 4-Mar-04 Minor fixes to PDL::Transform - slightly better handling of hanning and gaussian cases; tweaks to documentation. RL (for DH) 2-Mar-04 - New version of Graphics/PLplot/Makefile.PL that allows build of PDL on a totally fresh system. RL 1-Mar-04 - Graphics/PLplot/plplot.pd, t/plplot.t: Define our own plpoin perl subroutine, where the first argument of c_plpoin (the length of the x and y vectors) is deduced from the piddle. CED 1-Mar-04 Minor fixes to PDL::IO::FITS CED 29-Feb-04 PDL::IO::FITS - Some more refinements to rfits (see docs). - wfits now allows write of binary tables. primitive.pd: fix to glue() makes it properly permissive with dims. CED 25-Feb-04 - Further changes to PDL::IO::FITS: * More cleanup of header handling code * Split out image-reading code into its own XTENSION handler [part of transition to more modular FITS handling] * No test cases yet. DJB 24-Feb-04 - 'use strict' fix for PDL::IO::FITS::rfits (when reading a binary table) (needs test cases added to t/fits.t) - FITS checks moved from t/misc.t into t/fits.t (new file) - t/misc.t and t/fits.t now use the Test module CED 12-Feb-04 - FITS.pm: Applied patches 881870 and 880507 from Kaj Wiik -- zero size field fix, and 'A' and 'X' type fixes. CED 5-Feb-04 - Window.pm: fits_imag accepts CROTA if CROTA2 is not defined. - m51.fits: moved CRPIX1 to agree better with the galaxy center CED 4-Feb-04 - Frestore again returns the eval'ed value rather than TRUE CS 28-01-04 - win32 fixes in several testfiles and updated INSTALL instructions for win32 DJB 15-01-04 - Hack to get fits_imag($img) to look like fits_imag($img,{j=>0}) when the RA axis is in descending order [+ internal changes to make the two go through the same code when setting limits]. DJB 14-01-04 - moved FITS-header messages from IO/Misc/Makefile.PL to IO/FITS/Makefile.PL since rfits/wfits are no longer in IO/Misc - added WCS as an option to the fits_imag/fits_rgbi routines in PDL::Graphics::PGPLOT[::Window]. This allows you to use any alternate WCS mappig stored in the FITS header. Only tested using images from the Chandra X-ray satellite, so you can now say fits_imag($img,{j=>1,wcs=>'p'}); to display the 'physical' coordinate system of the image - added docs for fits_cont() [essentially just copied fits_rgbi] - added fits_cont and fits_vect to PDL::Graphics::PGPLOT + internal updates to reduce replicated code. DJB 13-01-04 - t/dumper.t now passes on OS-X (10.3.2); needed to add '-s' option to uudecode call otherwise the directory name was being ignored. CS 13-01-04 - Basic/Makefile.PL: override MakeMaker clean to *not* delete files named 'core' (problem on case insensitive platforms) DJB 12-01-04 [merge of config-variable-cleanup branch] - Clean up the use of config values in the build process. We no longer use %PDL_CONFIG but use %PDL::Config in Makefile.PL's and *.pm's (it unifies the code since we do not need to check for one or the other). The config files (e.g. perldl.conf) still use the PDL_CONFIG variable. - added a TEMPDIR config entry which defines the location of the temporary directory to use during the build and testing phases; updated code to use this where spotted (may be other locations lurking around, particularly in the tests) - Moved configuration of MALLOCDBG-related variables into the top-level Makefile.PL since the same bit of code was seen in several Makefile.PL's 2.4.1 released CS 6-01-04 - PDL.pm: version to 2.4.1 CED 12-31-03 - Cleared out cruft from MatrixOps build process. CED 12-29-03 - PLPlot Makefile.PL prints more informative messages during configure - Added crash test to t/plplot.t - 'yes'/'no' -> 1/0 conversion added to bottom of perldl.conf DJB 12-23-03 - fix small bug in PDL::Graphics::PGPLOT::Window::initenv() revealed by perl 5.8.2 and test 11 of t/pgplot.t (Use of uninitialized value...) CS 12-19-03 - small release notes change - t/primitive.t: test empty piddle handling CED 12-16-03 - ufunc.pd: average() returns 0 when given an integer empty piddle and nan when given a floating-point empty piddle (unless badvals are compiled, in which case you get BAD back). - Fixed broken vector coastline (when did that happen?) - Minor documentation fix to NDF.pm.PL CS 12-16-03 - t/plplot.t: redirect stderr to get rid of silly messages - update Release_Notes CED 12-15-03 - primitive.pd: change statsover to use population standard deviation for rms term -- solves bug #852359 - transform.pd: changed call to nan("") to sqrt(-1) for cross-system compatibility (Slowlaris has no nan() call) - Fixed typo in FITS.pm; shut up precedence complaints from t/func.t and slatec.t - Shut up v-strings warning in NiceSlice.pm - Numerous other warnings from perl 5.8.2 suppressed. CS 12-12-03 - Lvalue.pm: change v-strings to backwards compatible version numbers CED 09-Dec-2003 - m51.fits: Replaced non-free NOAO image with free Hubble Heritage image CS 08-Dec-2003 - Core.pm.PL: fix nslice to handle empty piddles CED 07-Dec-2003 - ufunc.pd: average() and daverage() return 0 when given an empty piddle in a non-bad-value environment. [One might argue that this should be nan; I'm open to changing it...] - ufunc.pd: andover, orover, etc. no longer convert arguments to integer types before performing the operation. bandover and borover work as before, since bitwise and makes no sense on floating-point types. CED 05-Dec-2003 - Clean up axis labeling code in imag(); should eliminate spurious doubled titles. CS 04-Dec-2003 - add code to Makefile.PL that tries to detect broken redhat installations CS 03-Dec-2003 - PGPLOT::Graphics::Window: activate autolog for the 'points' command and add some brief docs about autologging (see docs for AXIS option) CED 25-Nov-2003 - Fixed eigens; eigenvectors are now in the columns of the output eigenvector matrix, rather than in the rows. CED 21-Nov-2003 - Fixed bug 755563 (I hope) in the OpenGL configuration - Fixed bug 793195; some random doc improvements for Image2D and Transform. DH 21-Nov-2003 - Upgraded PLplot interface for plplot-5.2.1 and perl 5.8.2. Improved test suite. Also fixed two small bugs which give warnings during 'make test' under perl 5.8.2: One in primitive.pd and the other in misc.pd. CED 19-Nov-2003 - Several minor fixes and improvements to rfits(). Notably, it now works in array context, pulling all extensions and returning as list. CED 17-Nov-2003 - Split FITS IO into its own module. CS 13-Nov-2003 - GSL version check (>= 1.3) in Lib/GSL/Makefile.PL related to bug 806229 which might be caused by a version mismatch(?) CED 11-Nov-2003 - Added FITS BINTABLE reading to PDL::IO::Misc. CED 04-Nov-2003 - Updated Matrix.pm - Removed null tests from trans code in PP.pm - to enable better handling of null piddles. (fixes bug 779312, I hope) CED 16-Oct-2003 - Added whatis() function to perldl CED 15-Oct-2003 - Added PDL::IO::IDL. CED 15-Sep-2003 - Added easier access to local web documentation ("help www"). - Help searches are case-insensitive. CED 01-Sep-2003 - Moved Transform.pm to PP; wrote C version of map() algorithm. - Revamped Window.pm documentation a bit. - Fixed bg bug in text(). CED 23-Aug-2003 - Added uniqvec() to primitive.pd CED 22-Aug-2003 - Added 'mirror' boundary condition to range() - Added qsortvec() to ufunc -- lexicographically sort a bunch of vectors. CED 8-Aug-2003 - DiskCache now accepts a "bless" option that blesses the tied array into the PDL::DiskCache class for easier access to the "sync" and "purge" methods. - Some fixes to Transform. CED 5-Aug-2003 - Several minor fixes (bugs 777000, 783104, and 772492) CED 27-Jul-2003 - Minor fix to Transform.pm (t_quadratic) CED 26-Jul-2003 - Fixed test for complex.t - Fixed documentation for primitive.t CED 24-Jul-2003 - Online documentation works for autoload files - Fixed regexp bug in searcher (special characters broke searching, as in "? /tmp/foo") JC 22-Jul-2003 - Fixed bug in polar to re-im conversion routine (Cp2r) in PDL::Complex. Added test case in complex.t to check that re-im to polar conversion followed by polar to re-im ends up with the same value we started with. CED 12-Jul-2003 - interpND: added cubic and FFT interpolation schemes. CED 5-Jul-2003 - imagend.pd: convolveND is ready to roll: fixed off-by-1 errors, added tests and documentation. CED 3-Jul-2003 - imagend.pd: add optimized "convolveND". Still needs a bit of offset-by-1 work, but runs 3x faster than convolve() for direct convolution. CED 29-Jun-2003 - slices.pd: clump allows "-n" to mean "keep n dimensions". CED 28-Jun-2003 - Transform.pm: fix autoranging of map() - primitive.pd: fix negative-index case in linear interpolation (floor is required to prevent round *up* for negative indices) CS - fix NiceSlice foreach bug; v to 1.0.0 - fix fftwconv 2.4.0 released CED 22-May-2003 - Better fallbacks for RGB images if PGPLOT-RGB support isn't installed (Window.pm) - pgplot.t test cleans up its own window. CED 21-May-2003 - Revamped tranforms demo - Added cartography demo - Fixed justification logic in Graphics::PGPLOT::Window::fits_foo - Fixed a bunch of documentation - Removed debugging prints from Cartography.pm CED 20-May-2003 - "arbitary" -> "arbitrary" in Window.pm - Fixed-up Transform demo JC 19-May-2003 - Updated Release Notes CED 19-May-2003 - Fixed FlexRaw to use binmode() on file handles. Also fixed flexraw.t to use binmode() in its byte-swapper. CS 170503 - Makefile.PL cleanup + restrict tests when vital modules missing CS 140503 - further Makefile.PL fiddling CED 12-05-2003 - Lib/Transform now doesn't complain with -w (addressing DJB's objection) - wfits now corrects the size of the output header. - Shrunk Cartography sample data CS 080503 - Makefile.PL now absolutely requires Filter::Util::Call & Text::Balanced for PDL::NiceSlice DJB 060503 - Makefile.PL now enforces Perl >= v5.6.0 (+ removal of old code) CS 060503 - set OPTIMIZE via perldl.conf - PDL.pm: version @ 2.4.0 - Inline::Pdlpp: new NOISY flag (show compilation output) CS 030503 - is_inplace: allow testing and unsetting inplace flag in one statement - complex.pd: fiddling with namespaces and other bits - add 'reshape' to lvalue funcs CS 190403 - export pdl_changed, pdl_children_changesoon and pdl_vaffinechanged into PDL::Core struct (for usage in external modules) bumped up pdl_core_version to 5 - use those funcs to fix inplace ffts in PFL::FFTW (fix bug #716449) - pdlapi.c, pdlthread.c, pdl.h.PL: changes to help debugging the PDL Core; all pointers are now dumped in hex in the pdl_dump_XX routines - pdlapi.c: delete one statement in pdl_changed that broke, for example, calling fft with certain kind of slices (see comments) fixes bug #716447 (but note that I wasn't sure what this statement was required for in the first place; so breakages in other places as a result are not inconceivable) - disabled foomethod tests (foo.t) since foomethod broke as a result of removing the statement in pdlapi.c (see above). I assume that the statement in question was only introduced to make the foomethod work CED 15-Apr-2003 - Cleaned up a lot of documentation CED 14-Apr-2003 - By request, headers are now deep-copied recursively. - Removed a debugging printf in PP.pm CED 12-Apr-2003 - Various: Modified header copying to be quasi-deep, rather than by reference only. Changes to PP.pm, Core.pm.PL, and some test files. CED 9-Apr-2003 - slice.pd : Added permissive ranging to, er, range(). Missing source dims are treated as if they dummy dims of order 1. DJB 09-Apr-2003 - Fixed PDL::Graphics::PGPLOT::Window::legend to correctly handle synonyms (confusion between PDL::Option's synonyms()/add_synonym()) CED 8-Apr-2003 - Minor fix to Transform::map: if you supply a destination FITS header it replaces the original FITS header in the remapped output. CS Dev.pm: apply Michael Schwern's fix for ExtUtils::LibList Makefile.PL, Types.pm.PL: fix race where Types.pm.PL tries to use PDL::Config before it is written discovered bug in FFTW inplace code: breaks inplace routines with slices; added TODO test to fftw.t DJB 02-Apr-2003 - moved code from Basic/Bad/bad.pd to Basic/Core/Types.pm.PL: should never really have been adding to the PDL::Type namespace from a different module! (no change to the user) CED 30-Mar-2003 - range now allows using the empty piddle as an index; the resulting range is the empty piddle. DJB 28-Mar-2003 - removed TYPES_LONGLONG hack from perldl.conf CS - changed handling of bad values to accommodate longlong types general infrastructure overhaul to improve type handling CED 27-Mar-2003 - Added XRange,YRange keys to image handling in Graphics::PGPLOT::Window. CED 25-Mar-2003 - Fixed pgplot.t test to not use broken asynchronous I/O in perl5. Switches interactivity on an environment variable instead. CS 25/03/03 - karma.pd: added 'kvis' command to start new kvis app CS 22/03/03 - renamed det in slatec.pd to detsclatec; avoids name clash with PDL::MatrixOps::det; I tried to make the change backwards compatible - PDL::ImageND, PDL::FFT, PDL::FFTW: moved kernctr from PDL::FFT into PDL::ImageND so it can be used by both PDL::FFT and PDL::FFTW; both PDL::FFT and PDL::FFTW export it now by default CED 20-March-2003 - pdlhash.c: if PDL::BIGPDL is true, then ignore the 1-Gb limit on PDLs. - Window.pm: - Fix labeling bug that affected some output devices (titles were doubled in ppm device due to a pgplot buffering bug). - Fix handling of FITS headers in _fits_foo -- let PDL dimensions override NAXIS. - PP.pm: - hdrcpy bit is sticky, so that headers make their way down pipelines of operations. CED 18-March-2003 - Core.pm.PL: fix '.=' closure (closes bug #630793) - pdlapi.c: Check that a dimension is nonzero before dividing by it, in pdl_make_physvaffine. This bug might exist elsewhere too, causing random crashes with Empty and Null piddles. But at least this closes bug #671891. - perldl.PL: Put code to execute inside a trivial block (diverts runaway 'last' and 'next' commands, closes bug #573841) - ufunc.pd: Minmax now returns (0,0) when handed the null piddle, unless bad values are supported in which case it returns (bad,bad). (closes bug #659130) - Window.pm: fix bug #626344 (retain old cursor position) CS 17/03/03 - Core.pm.PL: fix topdl method (closes bug #681015) - gsl_integ.pd: fix for compliance with gcc AJ (17-March-2003) - Added PDL::GSL::INTEG CED (15-March-2003) - perldl: Added multi-line string processing (using Text::Balanced) and EOF protection to the shell. CED (14-March-2003) - Obscure bugfixes and improvements to Lib::Transform - t/pgplot.t Avoid a perl bug (setting an alarm from inside the alarm handler sometimes fails!). - Primitive: uniq now always returns a PDL. AJ (12-March-2003) - Minor changes to PDL::GSL::INTERP Doug Hunt (3-Mar-2003) - Added PLplot interface to PDL/Graphics area. This had been a separate CPAN module (PDL-Graphics-PLplot) CED (25-Feb-2003) - Added 'piddle' constructor synonym :-) CED (24-Feb-2003) - slices.pd: - range(), indexND, & interpND now accept multiple boundary conditions - fixed up indexNDb and indexND documentation - portability fix to whichdatatype_double mod CED (21-Feb-2003) - Modified whichdatatype and whichdatatype_double to represent nan with a double, rather than barfing. - Myriad small fixes to Transforms::Cartography - Perspective works properly - Changes to the documentation of Window.pm: axis() is better documented. CED (5-Feb-2003) - Window.pm: - ctab() selects window focus now (as it should). - lines() doesn't barf on trivial vector - pgwin() is much more forgiving in its syntax. In particular, you can say "pgwin(xs,J=>1)" and it'll know what you mean. - Basic: New ->fhdr method makes a tied FITS header if possible CED (30-Jan-2003) - Modified interpND linear method (30% faster!). - Added PNG interpretation to ::IO::Pic. - Cleaned up RGB support in Transform/Cartography; fixed many bugs. in threaded transforming (mv(,-1) is deprecated!) - Added FITS header support to transformations. - Added automagic RGB recognition to ->imag. AJ (29-Jan-2003) - Added PDL::GSL::INTERP and PDL::GSL::DIFF and corresponding tests t/gsl_interp.t and t/gsl_diff.t CED (28-Jan-2003) - Added fits_vect method to Window - Improved Transform demo (whizzy despiraling demo at end) - Fixed MANIFEST. CED (27-Jan-2003) - Rearranged Lib/Transform to be more like the rest of the source tree. - Several bug fixes in Transform code - Improvements to ->map() method - Added truncation to ->range operator - Switched ->indexND to use ->range (for better data flow) - Added EQUIVCPTRUNC macro to PP, for permissive slicing operators (like ->range) that can extend out-of-bounds. CED (20-Jan-2003) - Added rgbi to Window.pm (requires newer pgplot & PGPLOT). - Added earth_image() to PDL::Transform::Cartography::Earth (this may not be the Right Way to do it) CED (17-Jan-2003) - PDL::IO::Dumper uses more standard uuencode/uudecode than before, and uses external uuencode/uudecode by preference (faster than Convert::UU) CED (16-Jan-2003) - Minor fixes to Transform. - PDL::IO::Pic is auto-used. CED (15-Jan-2003) - fix to Dumper -- uses Convert::UU (instead of uudecode) if available. - Transform::Cartography::Earth -- update dumped info CED (3-Jan-2003) - primitive: added glue() method -- arbitrary-dimension append - Transform: - renamed Projection.pm to Cartography.pm - Added operator overloads to Transform.pm - Added "dual-method" functionality to map() and apply() - Reversed sense of map() and unmap() to make them more intuitive. - Added many map projections and helper routines to Cartography.pm - Added Transform::Cartography::Earth with local earth-map (autoloaded by "earth_coast" helper in Transform::Cartography) - Window: - Several minor fixes to lines CS - NiceSlice parser updates, see Changes in NiceSlice dir - .cvsignore files for the dist (autogenerated so hopefully no screwups, please let me know if you notice any problems) CED (19-Dec-2002) - window.pm: Fixed off-by-one bug in ->lines - Transform.pm: Fixed some stuff in t_linear - Added Lib/Transform/Projection.pm CED (17-Dec-2002) - Minor fixes to Transform.pm - Added "lines" to Window.pm - Added Earth map data file to the top level of the distro. - temporarily added "earth-interp.pl" to the top level of the distro. - Allowed "Methods" as well as "Functions" for func list in Doc.pm CED (11-Dec-2002) - Minor fix to Windows.pm in _FITS_tr. CED (10-Dec-2002) - Minor fixes to Windows.pm - First cut at pgplot.t -- test suite for pgplot windowing stuff. - Fixed up some Transform documentation. CED (09-Dec-2002) Fixes to Windows.pm: - all Pix/Scale/Pitch parsing is now in initenv() (so, e.g., those options work on ->line and ->points). - initenv() knows about self->held for more convenient wrapping (and fixing of the old doesn't-switch-windows-when-held bug) - _fits_foo implements generic fits_ processing for easier addition of fits stuff. - fits transformations are in _fits_tr - image range finding is in _fits_xyvals - justify works in a generalized way. Justify=>1 works like you expect, but Justify=> also sets the pixel aspect ratio, for more juicy flavor. CED (06-Dec-2002) - Minor fix to range documentation - Shut up warnings in Window.pm sig handler and fix fits_imag (bug #649630) - Fixed bugs #633385, #634257 - attempted to regularize justify option (in progress) CED (05-Dec-2002) - Numerous fixes to PDL::Transform - Minor tweak to MatrixOps - Some cosmetic improvements to InterpND (better option control) CED (03-Dec-2002) - Completely rewrote range code -- it's more elegant, faster, and more general now. CED (02-Dec-2002) - added ndcoords (new index piddle constructor) to Basic.pm - indexND now uses range call instead of index call (works faster) - many mods to Transform CED (21-Nov-2002) - PDL::Math loads PDL::MatrixOps by default for backwards compatibility. CED (19-Nov-2002) - PDL::Slices::identity -> s_identity; identity is now exported from MatrixOps and constructs an identity matrix. - Ported MatrixOps to PP; moved to subdir of Basic; split the matrix ops from math.pd and moved into matrixops.pd MatrixOps is now autoloaded by "use PDL;". - Minor mods & cross-refs added to documentation in several modules CED (18-Nov-2002) - Transform: improvements to t_lookup CED (17-Nov-2002) - MatrixOps: improved inv and det can thread using lu_decomp2 - Transform: - use svd to characterize the jacobian in integrative mapping - integrative ('jacobian') mapping works reasonably quickly and is correct. Some changes to options. - Better documentation for svd in math.pd CS - yet another special case for NiceSlice, see NiceSlice Changes CED (15-Nov-2002) - photometric distortion appears to be correct -- but hogs memory like crazy. One more iteration to make it usable! CED (14-Nov-2002) - interpND defaults to 'sample' if its input is an integer type - Math::eigens is quiet about symmetrizing unless PDL::debug is set - photometric distortion (not correct yet but functional) in PDL::Transform - updates to MatrixOps.pm DJB (14-Nov-2002) - Added 'demo transform' to perldl to showcase PDL::Transform CED (14-Nov-2002) - Math::eigens is now threadable. DJB (12-Nov-2002) - Added the TYPES_LONGLONG option to perldl.conf: by default it is set to 1 which means that PDL will try and compile support for a 64 bit type. Set to 0 if make fails (or fix the code to work with PDL_LongLong types!) CS - NiceSlice doc additions - PDL::Core: squeeze as reshape(-1) alias CED (11-Nov-2002) - Transform.pm updates - conformal radial expansion, better documentation, better composition, several minor bug fixes CS - NiceSlice.pm v0.99: fix modifier parsing + allow several modifiers CED (7-Nov-2002) - Several updates to Transform.pm -- wrap() method, rot option to Linear, and improved composition -- but NOT (just yet) jacobian support. - Updated documentation for index() method in slices.pd - Minor tweaks to MatrixOps. CED (6-Nov-2002) - Added MatrixOps.pm version 0.5 - Added t/matrixopt.t CED (30-10-2002) - Added Transform.pm version 0.5 CED (29-10-2002) - m51.fits: hand-edited the file to fix bad NAXIS tag (was 0) CED (25-10-2002) - IO/Misc.pm: removed not-so-spurious warnings from rfits (bug #626342) - PGPLOT/Window.pm: fixed spinlocks for PGPLOT -- now faster, clearer, and actually functional (see bug #615277). - Primitive/primitive.pd: fix to interpND behavior -- it now threads correctly in the bilinear dual-threading case. - Lib/Slatec/slatec.pd: added nonsquare-array check to matinv. Similar checks are probably needed throughout to keep FORTRAN from dying. CS - PDL::IO::FlexRaw now understands all types - uncommented type longlong -- let's see how many installations break ;) - added t/iotypes.t CS ******** merged in type extension stuff - example of extending data types: add longlong type (64bit integer) - that type is disabled by default but you can uncomment the section in Types.pm.PL to try it out *** no modification of IO modules yet *** just the core changes to add the type + other changes to *** make all modules compile *** may serve as a testbed for type extensions *** needs testing with BADVALUE support CS - preparations for type extension: concentrate all type-dependent info in Types.pm.PL CS - cpoly.c: try to fix values.h problem on BSDs etc CS - patch for cygwin by Christopher Marshall (Bugs item #597985) CS - fix box2d threading bug CS (25/9/2002) - 2.3.4 release branch merged into trunk TJ (13-Sep-02) - Basic/Core/Core.xs hdr and gethdr XS functions did not strictly adhere to XS syntax. (5.005_03 xsubpp complains loudly) DJB/CS (11-Sep-02) - 'make clean' now removes _Inline/ as does t/inlinepdlpp.pl when its run (to make sure that we're testing the latest&greatest code) TJ (09-Sep-02) - Fix valgrind warning in pdlapi.c (use of uninitialised variable in dump) - PDL::IO::Storable now uses PTR2IV TJ/CS (09-Sep-02) - Fix memory leak associated with magic CED (30-Aug-02) - Fix to Window.pm documentation -- explains wart about panel() CED (29-Aug-02) - minor fix to fits_imag -- axis labels - Added TightLabels (boolean) and TitleSize (float) standard options to control window labeling. CED (28-Aug-02) - minor fix to rangeb - physicalize index before checking its size CED (27-Aug-02) - range() is now an lvalue, as are indexND and indexNDb. - pdl_malloc call is now via PDL Core structure, avoiding complete failure of the test suite :-) - extra debugging fprintf() calls deleted. - range() is a front-end to rangeb(), allowing omission of optional arguments. - rangeb handles boundary conditions. CED (26-Aug-02) - slices.pd: added range (PP implementation) - Incremented core_version in pdlcore.h.PL - ->range doesn't spew debugging now (commented out) CED (20-Aug-02) - slices.pd: added rangeND (first-cut implementation) ---- 2.3.4 release merged into trunk on 25/9/2002 (see above) 2.3.4 JC (23 Sep 02) - Changes to Release_Notes associated with making release 2.3.4 Frederic Magnard (2002-09-20) - Fix NAXIS in fits writer with Astro::FITS::Header TJ (2002-09-20) - wfits should now write SIMPLE as logical with Astro::FITS::Header TJ - wfits now works correctly with Astro::FITS::Header TJ - Paper over weirdness in PDL::GSL build when Slatec is disabled. TJ - func.t was failing if Slatec was not available. This was because PDL::Func was loaded before PDL::Slatec in t/func.t. Now fixed (and include an additional croak in PDL::Func). TJ - Compatibility fixes for perl 5.005_03 + updated ppport.h from perl 5.8.0 + lvalue problems with slices.pd and primitive.pd + Graphics/PGPLOT/Window/Window.xs now uses ppport.h TJ - Core.xs.PL used invalid XS for hdr and gethdr DJB - Backported "_Inline removal to Makefile.PL & t/inlinepdlpp.t" CS - version to 2.3.4 CS - backported a number of patches from the main branch DB 9/11: Lite.pm typo TJ 9/02: PDL::IO::Storable now uses PTR2IV Fix valgrind warning in pdlapi.c (use of uninitialised variable in dump) Fix memory leak associated with magic ----- branched off 2.3.4 release at this point CED (19-Aug-02) - Window.pm spinlock includes special release_and_barf to unlock signals. (the Right Answer is to fix barf() to throw a __DIE__ signal; but that opens other cans of worms.) - documentation for some of the inplace-flag handlers CED (16-Aug-02) - indexND: runs faster; doesn't check boundaries at all - indexNDb: includes "forbid" boundary condition (which barfs on violation) - interpND: skips trivial cases for bilinear interpolation (factor-of-2 speedup for each dimension that is indexed by an integer) - Window.pm: * ->imag labels axes, if you pass in label fields as options. * isolated initenv() viewport setup, so imag() can use it in pix code CED (15-Aug-02) - PGPLOT::Window fixes: - ticks default to outside for images; inside for everyone else - cleaned up pixel scaling code (used initenv() now) in imag - Image alignment code - you can choose how the image fits within the box if you explicitly set the scaling (or use fits_imag) - fits_imag automagically draws wedges rather than modifying the title. - draw_wedge position defaults to 1.5 rather than 2 (avoids cropping of wedge labels in the default case). CED (12-Aug-02) - Minor speed increase to InterpND (still needs work!) - PGPLOT::Window::(imag1|imag|fits_imag) now does pixel scaling correctly (I hope) -- substituded pgqvp (viewport dims) for pgqvsz (window dims) - Axes now default to having tick marks outside the box instead of inside the box. That prevents scrozzling by images. - pgwin() convenience function is a little more convenient - Fix to spinlocks in Window.pm. - gethdr() can return undef again; new method hdr() is always defined. CED (9-Aug-02) - Signal-deferral mechanism for PDL::Graphics::PGPLOT::Window should avoid many pgplot-related weirdnesses CED (8-Aug-02) - Minor fixes to fits_imag, also in PDL::Graphics::PGPLOT::Window - Minor fix to IndexND, in slice.pd - now fits_imag doesn't attempt to reconcile different CTYPE units. DJB (8-Aug-02) - changed behaviour of TextWidth option in PDL::Graphics::PGPLOT::Window It is now only applied if specified (ie doesn't default to 1 and so clobber the LineWidth/HardLW settings). Added a little documentation but it needs to be improved. CED (7-Aug-02) - Slightly cleaner MOD in ops.pd - added interpND (to primitive.pd) and indexNDb (to slices.pd). CED (6-Aug-02) - New % operator follows (mathematically correct) perl % operator behavior - AutoLoad throws an error if foo.pdl doesn't declare foo(). (used to loop endlessly). - AutoLoad error messages are more informative. CS - hopefully fixed bug with new pdl(arrayref) implementation CED (2-Aug-02) - Add IndexND to slices.pd - Add pdl output for scalar context to WhereND in primitive.pd CED (1-Aug-02) - Incorporate FITS into rpic/wpic interface (allow conversion code to recognize drop-in replacement functions for rpic/wpic) - Minor fix to FITS I/O version checking CS - add PDL::IO::Storable and PDL::GSL::SF hierarchy - fast pdl method! please test heavily - don't do opengl tests unless opengl is actually built! - mute annoying warnings from PP::PDLParObj CS - explicitly load PDL::Core in PP boot section - examples: make modules with Inline::Pdlpp! CED (26-Jun-02) PDL::Graphics::PGPLOT::Window::line() autoranging avoids infinity CED (25-Jun-02) Changes to PDL::Graphics::PGPLOT::Window: - Added pgwin() -- exported constructor (less typing) - Added =>Size option to constructor (less typing) - Added =>Units option to constructor (PGPLOT units only at the moment) - Interactive windows appear at the size you ask for. (less annoyance) DJB - quoted "PDL::Type" in byte/short/.. fns in Core.pm to fix problem seen with using 'use strict' with perl 5.6.0 CS - patch by Ken Williams to improve speed of 'pdl $perl_array_ref' CS - check for Astro::FITS::Version >= 1.12 CED (17-Jun-02) - add fits_imag to PGPLOT interface CS - allow niceslice to use the syntax $pdl($greater_1D_piddle) which indexes into flattened $pdl; result has same shape as $greater_1D_piddle CS - allow PP Code to handle constructs like $arr(n => 3*i+1) if Text::Balanced is installed - fix included Benchmark suite - NiceSlice.pm: make splitprotected interface similar to split's CS - fix PP.pm: bug #564937 (needed a check for sv_isobject(...) ) - make sure pp_done is called automatically if user forgets! CS - applied Diab's patch #559860: improve trylink, Math/Makefile.PL - applied Diab's patch #559885: overload 'eq' - Inline::Pdlpp: fix join-bug, add MakePdlppInstallable to allow installation of modules with Inline Pdlpp calls, update test and INFO method - allow to set trylink 'Hide' behaviour from perldl.conf (suggested by Diab) DJB (04 Jun 02) - minor fixes to the build highlighted by warnings from perl 5.8.0 TJ (31 May 02) - Use INT2PTR/PTR2IV to fix compiler warnings when the IV size does not match the pointer size (eg linux with -Dusermorebits). This will break compatibility with perl 5.005 unless we add some of our own macros - Fix prototype warning in rout.pd with PerlIO_print - Apply CS's patch to CallExt.pm to prevent spurious failure of DynaLoader in perl 5.8.0 2.3.3 JC (22 May 02) - Changes to Release_Notes, PDL.pm associated with making release 2.3.3 CS - bump up NiceSlice version - gsl_random rng destructor! - improve PDL::Exporter doc (I never remember the darn syntax) CS - reshape behaviour like idl when no dim args are given - niceslicing gets a new modifier: $a(;-) drops dims of size 1 CED (16 May 02) - Several minor changes to Dumper and RandVar for compatibility with BSD and perl 5.005 CS - Makefile.PL: warning if mods for NiceSlice missing - IO/Misc: print warning at the end of the make output - Graphics/PGPLOT: small change to the (still undocumented) autolog func CED (15 May 02) - Added Astro::FITS::Header recognition to PDL::IO::Dumper. CED (14 May 02) - Removed NiceSlicing from RandVar and Dumper (they use slice only now) CED (from the distant past) - Added PDL::IO::Dumper, which provides deep data structure storage and retrieval in armored-ASCII format. Requires Data::Dumper (from CPAN), FITSIO (also from CPAN), and uuencode(1). CED (13 May 02) - Modified legacy rfits/wfits support to handle strings more cleanly (more like Astro::FITS::Header) - Moved missing-module message to IO/Misc/Makefile.PL - Added stringification test to t/misc.t CED (10 May 02) - Modified rfits/wfits to support Astro::FITS::Header as an underlying FITS header driver. The fallback (to the more-or-less original KGB code) is probably Wrong as string handling now changes depending on the presence of Astro::FITS::Header; whether Astro::FITS::Header is present; but ultimately everyone just uses Astro::FITS::Header and the problem goes away. CS - folded PDL-2_3-gimp-fix branch into main trunk - typos DJB (09 May 02) - removed *.P files from Lib/Slatec/slatec/ (no longer needed) CS - fix wcols bug #541847 - remove $Config{libs} from callext_cc to make callext work on recent debian systems **** possible source of incompatibility ****** - dumper.t: test only if uuencode/decode present - lmfit example - add diskcache.t to MANIFEST CS - remove remaining call to pdl_family funcs in pdlapi.c - apply perldl patch for -M switch (bug #530441) CS - perldl v1.32: changed preprocess interface -> pipeline - Pic.pm: make option parsing case insensitive - Lvalue.pm : use attributes interface (fixes lvalues with bleadperl) - Core: remove pdlfamily.c dependencies and delete the file pdlapi.c: make_now noop, future_me etc stuff in pdl_destroy - PP: make_now is really a noop with above family changes - removed - doc updates DJB (09 Apr 02) - added 'use PDL::Math' to PDL.pm (but not Lite/LiteF versions) (22 Apr 02) - added Kaj Wiik's patch to use pgtbox in PGPLOT/Window.pm (#538831) -- this needs documentation! JB (07 Apr 02) - Moved $CTAB to become part of the $self object in PGPLOT/Window.pm This fixes the error that caused the second image plotted to hard- copy devices to become blank. DJB (02 Apr 02) - added Ben Gertzfield's patch for bug #538283 (pptemplate.pod location) CS - doc updates - box2d in image2d.pd - some more PGPLOT tline fixes - PGPLOT autolog stuff (as yet undocumented) - perldl -V (version info) - remove 'use PDL::Core' from PdlParObj.pm (static linking) - Makefile.PL: fix PDL::Config formatting, make solaris/usemymalloc/gcc message even more verbose - misc.pd: fix rasc bug (|| vs or) - add BUGS file DJB (27 Feb 02) - added finite fix for HP-UX systems to math.pd (by Albert Chin) CS - slice fix - pdlcore.h.PL: gimp fix - perldl Ctrl-C handling (Ken Williams tip!) - polyfillv: make lvalue sub DJB - PDL::IO::NDF::rndf() now accepts NDF sections (01/08/02) - added fft prototype to slatec.pd (from Jonathan Scott Duff, 01/17/02) CS - INSTALL & DEPENDENCIES update (bug #488867) - FlexRaw: read/write from open file handles (by Dov Grobgeld) - IO::Misc: fix filehandle code for rcols etc. add file handle awareness to rasc - slices.pd: improve 'index' error message CS - remove the defunct t/quat.t - fix PDL::GSL to work with libgsl 1.X CS - fix for #474736 (sym with points), needed that feature - applied symsize patch #474853 CS - fix for Dev.pm: load PDL::Types only once - stop PDL::IO::Pic warning by default 2.3.2 CS - change pdlcore.h.PL so that gimp-perl compiles again - Changes to Release_Notes, PDL.pm associated with making release 2.3.2 2.3.1 John Cerney (11/21/01) - Changes to Release_Notes, PDL.pm associated with making release 2.3.1 DJB - added WITH_IO_BROWSER to perldl.conf (default 0) to control whether PDL::IO::Browser is made. Will now compile on MacOS X 10.1. CS - get rid of Perl_die etc dependencies and other barfisms - make sure t/inlinepdlpp.t has a full search path to PDL::Core - Basic/Pod : podselect only when Pod::Select available CS - fix Makefile/Dev.pm bugs (that break build on PDL-free systems) - bump version to 2.3.1 2.3 John Cerney (11/13/01) - Changes to Release_Notes, PDL.pm, TODO associated with making release 2.3 - |= &= bug fix CS - inline fixes - dim & ndims aliases for getdim & getndims - perldl doc updates - reverting perldl.conf changes introduced in CVS - Makefile.PL: detect buggy solaris+gcc+mymalloc combination CS - fix Dev.pm warnings (triggered by Inline::Pdlpp tests) - Inline::Pdlpp docs CS - fix bug in Dev.pm that I introduced - change misleading topdl docs (fooled me!) - macosx patch CS - Tim's TERM patch - Stefan's Matrix patch - added PDL::API manpage - PDL::Core::Dev helper functions for work with Inline - pictests only for internal PNM format DJB (23/Oct/01) - changes to bad.pd in order to clean up build slightly (for instance we longer need to create pdlapi.c from pdlapi.c.PL) - added Diab Jerius' patch [ #469110 ] for rvals/options - added a test for this [and fixed a bug I'd introduced] DJB (15/Oct/01) - minor fix to ellipse (no longer requires options array) and to imag (will correctly handle transforms for axes with "-ve" pixel size, such as RA in Astronomy) CS - Xrange, Yrange for PGPLOT, fix tline and tpoints CS - niceslice docs, class methods for PDL::Options, perldl: enable niceslicing at startup (if available) Lvalue: add sever method CS - Inline::Pdlpp docs addittions, test script added CS - NiceSlice modifiers + bug fix CS - Inline::Pdlpp !!! DJB (23/Aug/01) - you no longer need to surround options by {} for PDL::Graphics::PGPLOT::Window->new() JB - Added a recording feature to the PGPLOT interface. CS - NiceSlice doc update JB (14/Aug/01) - Added a package wide store for options for env. This allows the next device to reuse the most recent set of env options. CS - minmax: return scalars! - PDL::Options for PDL::Graphics::Karma - disable PDL::PP SIG{__DIE__} overload by default DJB (07/Aug/01) - added VertSpace to ...PGPLOT::Window's legend() CS - make sure perldl works with NiceSlice - add nslice to lvalue funcs - new 'sclr' method - enhanced clump interface - pdlapi: backport pdl_get vaffine - experimental 'autosever' for PDL::NiceSlice - quieter 'mkhtmldocs' - fix OpenGL docs screwing up online help DJB (05/Aug/01) - applied wfits patch from Diab Jerius ([ #443431 ] wfits outputs illegal FITS keywords) - added test for whist to t/hist.t from DIAB Jerius (patch #443438) - added 'demo ooplot' to demonstrate "new" interface to PGPLOT CS - PDLCode.pm: fix bug #441586: PDL::PP cant handle pars with numerals CS - primitive.pd: fix random funcs so that they work with Perl's srand * does it work on pre-5.6 perls? * - update Lvalue documentation CS - slices.pd: fix lags bug #436823 - Fit/Polynomial.pm: normalization wasn't threaded (bug #438335) - PP.pm: make CoreSv linkage static (MacOSX) - Basic.pm: apply whist patch - PDL::SFilter renamed to PDL::NiceSlice CS - fix MANIFEST - fix 'reduce' docs - SFilter improvements - which and which_both now auto-flatten the input piddle to match 'where' behaviour - Core.pm: 'flat' change and added 'nslice' - pdlcore.h : compatibility with C++ compilation **** required renaming 'new' member of struct Core to 'pdlnew' !! **** CS - Makefile.PL: Filter::Simple, Text::Balanced dependencies - bad.pd: fix for win32 - Lib/Slatec/Makefile.PL: win32 fix - t/flexraw.t: remove extraneous 'use ExtUtils::F77' - t/poly.t: win32 needs larger error threshold ?:( - t/sfilter.t: script broke on platforms without prereqs - win32: general update for latest build; add slatec support DJB (20/Jun/01) - make bad.pd compile with PDL::Type changes and fix minor bug CS - fix rvals bug (annoying one!) - syntactical sugar: convenience operators for PDL::Type CS - Basic/SourceFilter (see also L) - generate PP templates with pptemplate - PP: pp_boundscheck (see PP.pm) CS - PP.pm: remove first '$this' arg from pp_add_exported! - LM.pm: fix implementation bug; still not sure if it works properly need more tests! - apply Raul's debian patch DJB (7/Jun/01) - minor fix for rfits() with bad-value support John Cerney (6/4/01) - Doco fix in complex.pd CS - image2d.t skip fix - mslice update - numeric for PDL::Char DJB (24/May/01) - fixed bug in Image2D::centroid2d when (x+box/2) > m (ditto for the y axis). Added bad-value support to centroid2d and max2d_ind DJB (8/May/01) - OpenBSD doesn't seem to have values.h, which causes Basic/Math to fail: see http://testers.cpan.org/search?request=dist&dist=PDL#2.2.1 Now using limits.h in Basic/Math/mconf.h for GNU systems - only tested on solaris and i386-linux. - fixed typo in debian/rules John Cerney (5/3/01) - Simple change to primitive.pd so that interpol sub makes it into the PDL namespace, and not just the PDL::Primitive namespace. Also added a simple test case for this routine. CS - F77CONF variable for debian build (see INSTALL) 2.2.1 John Cerney (4/25/01) - Changes to Release_Notes, PDL.pm, TODO associated with making release 2.2.1 CS - PDL::Lvalue -- PDL lvalue subs (added to loaders) - PDL::Matrix -- added docs - doc tidbits - don't test raster and SGI formats any more (pic(no)*rgb.t) John Cerney (4/11/01) - Modified t/opengl.t to turn-off the PERL_DL_NONLAZY env variable when running this test. Due to some inconsistencies in the opengl headers (gl.h, glu.h) and what functions are actually in the opengl libs, PDL's OpenGL.so sometimes (When using Mesa 3.3 for instance) gets built with interfaces to functions that aren't there. Setting PDL_DL_NONLAZY=0 prevents the test case from failing in these cases. DJB (10/Apr/01) - hacked Core/Dev.pm to work with perl 5.6.1 (ExtUtils::Liblist has changed although its documentation has not) CS - applied Christopher Marshall's minimum_n_ind patch (bug #413184) + test CS - fix mem leak patch so that core struct version croaking works * NOTE: recent patches will require recompilation of any external * modules that use PDL::PP; PDL will tell you when using such * modules * - barf is now really only an alias for croak; this is a test if we can live with the original croak; we should be able to! - update COPYING for the 21st century ;) John Cerney (4/3/01) - Modified Makefile.PL in Graphics to add '-lm' to the libs. This fixes a 'Can't locate auto/PDL/Graphics/OpenGL/glpcOpenWin.al' error in make test during opengl.t for some platforms. Shouldn't hurt otherwise. CS - make_physvaffine is now a member of the core struct - pdl_get is now vaffine aware (must be preceded by call to make_physvaffine) - worke around bug in the core logic (pdl_make_physical et al.) that cause index and others to leak memory; not the perfect solution yet but core logic is just way too confusing to make sense of it!!!!!! for details see comments in pdl_make_physical (pdlapi.c.PL) and pdl_initthreadstruct (pdlthread.c) - slatec: document the 'det' function DJB (26/Mar/01) - PDL::Func now sets bc => 'simple' as the default for Hermite interpolation. DJB (14/Mar/01) - PGPLOT::Window changes: addressed "undefined window size" part of bug #406858; added PosReference option + minor bug fix to transform() - renamed PosReference to RefPos. close() will print a message if a hardcopy device and $PDL::verbose is set, hack to fix bug #408589 (draw_wedge() erasing plot) for simple cases (15/Mar/01) DJB (27/Feb/01) - addressed PDL::Func bugs/doc issues as reported by HalldBBBBBBBBsr Olafsson and Vince McIntyre (bug #233484) CS - fix bug in pow in math.pd (reported on perldl mailing list) CS - fixed bug in writing pnms (bug #127696) - Core.pm: temporary fix to work around core bug (see comments in pdl_make_physical in pdlapi.c) that made convert leak memory (related to bug #116501) CS - fixed diagonal bug that caused apparently random errors (bug #116502) CS - changes for win32 compatibility: pdlcore.c: avoid die_where & co, use Perl_croak instead Math/cpoly.c: win32 doesn't know about values.h Lib/Image2D/resample.h: win32 doesn't know about M_PI t/fastraw.t: skip mmap tests on win32 - slices.pd: possible rotate segfault fixed - fix slight mslice problem (didn't make sure its inputs were converted to int) - new functions 'in' and 'uniq' in primitive.pd -> need tests - image2d: a slightly faster median: med2df - new function approx in Core.pm **** attention: possible name clash; test scripts should ***** **** use tapprox from now on ***** 2.2 John Cerney (20/12/00) - Minor changes to Makefile.PL and Reduce.pm for compatibility with perl 5.005 John Cerney (6/12/00) - Added new curve fitting routine: Linfit. Finds a linear-combination of specified functions that best fits data. (Similar to Polynomial.pm) Marc Lehmann (5/!2/00) - Don't add artificial newlines in PdlParObj.pm, you never know what the surrounding code might look like. Makes PDL compile with perl-5.7 again. John Cerney (5/12/00) - Updated log10 in ops.pd to have consistent copy behavior for subclassed objects as discussed in Objects.pod. - Expanded the tests in t/subclass4.t to test for log10 and other simple functions. CS - added some features to dice Doug Burke - rcols(): do not read an extra line with LINES option (Frank Samuelson) - added draw_wedge() (& DrawWedge option to imag()) to PGPLOT CS - fix call of Perl_croak in pdlthread.c for threading perls (reported by Diab Jerius) Doug Burke (03/11/00) - removed $_ from shorttype method: fixes $_->info() bug - perldl/pdldoc now list other matches to a help query (not wonderful) - fixed 0.5 pixel shift in imag() CS - fix bug in splitdim (didn't check nthdim) that can lead to coredumps - Dev.pm: malloc debugging support - Core.pm.PL: flat as clump(-1) alias bug in mslice: cast indices to int added Jarle Brinchmann (22/10/00) - Further bug fixes to PGPLOT added (courtesy of Kaj Wiik). Also a convenience function to calculate transforms (transform, courtesy of Kaj Wiik). - Examples/tests for the PGPLOT interface added in Example/PGPLOT Jarle Brinchmann (21/10/00) - Considerable re-write of PGPLOT. This now uses PDL::Option to set options. There is also now a OO interface PDL::Graphics::PGPLOT::Window which PDL::Graphics::PGPLOT now uses. - New functionality includes: - Interactive cursors (cursor) - Text on plots (text) - Legends (legend) - Circles, Rectangles, Ellipses - Multiple plot windows, oone can jump from panel to panel when the window is divided in several. - More control over options - see PDL::Graphics::PGPLOTOptions for details. This is not tested under Windows - and possibly not all functions work as they used to.. Doug Burke (18/10/00) - added warp2d (+ supporting fns) to PDL::Image2D. This allows images to be resampled using 2D polynomials as basis functions. - (19/10/00) bug fixes & clean up of documentation for above - rfits() now sets hdrcpy flag of piddle (so that the FITS header is copied to new piddles). Doug Burke - moved PDL::Type object from PDL::Core to PDL::Types. This shouldn't affect most people. CS - split primitive.pd into primitive.pd and ufunc stuff (ufunc.pd) - changed loaders to reflect this split (PDL.pm, Lite.pm, LiteF.pm) - moved 'assgn' to PDL::Ops (since it's primarily used for overloading '.=') - added conv1d to primitive.pd -> this one was dropped from the dist at some stage but it makes sense to have it - Pic.pm: print conversion message only when debugging - fixed a problem with TriD: APIENTRY not defined when processing glu.h (since include files are ignored) - added sever docs - a reduce function for PDL (Reduce.pm) - percentile projections patch applied to primitive.pd - fix some thread_define problems Doug Burke - improved support for bad values in r/wfits and r/wndf - added setbadtonan() to PDL::Bad. - moved log10() entirely over to Basic/Ops/ops.pd (so it's no longer defined in PDL::Core. CS - moved trylink to Dev.pm (L) - modified Graphics/Makefile.PL accordingly Doug Burke - cleaned up endian support. Threw out my check_endian stuff since perl already knows - there's a isbigendian fn in Dev.pm (eg see IO/Misc/misc.pd) - added setvaltobad() and setnantobad() to PDL::Bad, renamed replacebad() to setbadtoval() (perhaps should keep it as an alias?) setnantobad doesn't work (yet) if $PDL::Bad::UseNaN == 1 CS - added Matrix.pm (suggestion by Stephan Heuel) - Core.xs.PL: getdim, at and set now support the 'infinite dim' piddle behaviour discussed on pdl-porters - perldl: $bflag incorrect due to low 'and' precendence - PDL.pm: the version was still far behind ;-( - Basic.pm: PDL->null breaks inheritance - Core.pm.PL: allow <2D piddles as arguments in creating functions (not yet reflected in the docs). Another step on the way to improve the balancing act between scalar and 1D piddles and normal perl scalars - Core.xs.PL, pdlcore.h.PL: PDL.malloc -> PDL.smalloc renamed - Core/Makefile.PL: endian stuff only when WITH_BADVAL (reduce likelihood of build problems); don't assume that '.' is in the PATH (good distributions like DEBIAN avoid that ;) - Doc/Perldl.pm: new (undocumented) aproposover function -- do your own thing with returned matches - karma.pd: PDL->malloc -> PDL->smalloc Doug Burke (09/06/00-09/07/00) - Core and pdl_trans structure are now the same, whatever the choice of WITH_BADVAL and BADVAL_USENAN. The version number of the core has been bumped to 2 (removing the need for Christian's recent patch) since this is binary incompatible with PDL 2.1.1 - clean up of build process - both because of above change and also to stop problems when switching between WITH_BADVAL = 1 and 0. - exported several routines in PDL::Bad Jim Edwards - improved OpenGL detection during 'perl Makefile.PL' Doug Burke (09/05/00) - minor clean-up to the build process. Now creates Basic/Core/badsupport.p in top-level Makefile.PL for when PDL::Config hasn't been created - fixes setting BADVAL options in ~/perldl.conf Doug Burke - Bad value support integrated into the main branch. Set WITH_BADVAL to 1 in perldl.conf to use. See Basic/BadValues.pod for more information and try the two demos (demo bad, bad2). Many of the internals have been tweaked (eg many more files are created at compile time in Basic/Core - including Dev.pm; m51.fits is now installed for the bad2 demo ...) - Basic/Core now contains isbigendian.p - this is created at compile time. IO::Misc::isbigendian uses this. - IO::NDF now saves byte piddles as "_UBYTE", rather than "_BYTE", NDFs - log10 is now in Ops (using C-library version), although a version is left in Core.pm.PL so that log10(2.3) returns a perl scalar, not a 0D piddle - removed 1-argument form of where() since been deprecated long enough Jim Edwards - swcols added to IO::Misc - like wcols but to a string, not a file Jim Edwards (08/25/00) - minor bugfix in TriD contour3d - added Labels to TriD contour3d options Doug Burke (08/12/00-08/13/00; 08/17/00) - minor bugfix to Graphics/Karma/Makefile.PL - made qsort and qsort_ind C routines in primitive.pd available to all modules via the PDL Core structure (pdlcore.h is now created by pdlcore.h.PL) and updated image2d.pd to use this (+ bug fix to patch2d) - added double precision versions of sum, sumover, cumusumover (same for prod) and average (eg dsum, daverage). Added prodover routine Changed stats to use this (+ changed PDL::Tests to avoid name clashes) - revamped Types.pm.PL - made Inplace option for pp_def a bit more sensible - marked several functions in math.pd as inplace (needs documenting) - fixed rndf() so that can use rndf('../bob') Jim Edwards (08/08/00) - Major changes to the TriD code (requires perl 5.6.0) Doug Burke (08/02/00) - 'bool' to 'boolvar' in cpoly.c to get it to compile under Linux - added 'Inplace' rule to PP.pm to flag a routine as inplace (see ops.pd) - minor improvement to PP output if $::PP_VERBOSE is set CS - ops.pd: fix inplace problem (reported by Tim Conrow) Doug Burke (07/27/00) - some minor changes to PP.pm & PDLCode.pm (no longer generates 'THISISxxx' macros in xs code unless they're required. CS - PP: don't use copy method when HASP2Child - Makefile.PL: no .3 manpages CS - Core: pdl.h dependencies - pdlapi.c: comments and debugging - ops.pd: docs fixes - PGPLtw.pd: doc fOT_demo: choose /GW on MSwin32 - mkpdlfuncpod: some experimentation - Karma/Makefile.PL: malloc debugging support - CallExt/Makefile.PL: malloc debugging support - fftw.pd: doc fixes, exports and convolution - slatec: error handler now calls croak (instead of being fatal) - VRML: fix problem with prototype registration Doug Burke (7/02/00 - 7/9/00) - stopped some excess code generation & improve legibility of some code in Basic/Gen/PP.pm and Basic/Gen/PP/PdlParObj.pm - minor doc cleanup in Graphics/TriD/Rout/rout.pd (lack of head3 in pod) - added a test to t/hdrs.t to pick up a bug I'd introduced - replaced Basic/Core/mkpdlconv.p by Basic/Core/pdlconv.c.PL, removed mention of pdlbasicops in Basic/Core/Makefile.PL Tim Jenness (6/30/00) - PDL::CallExt now works on WinNT with VC++ Doug Burke (6/29/00) - added methods to PDL::Type - enum, symbol, ctype, ppsym, realctype and shortctype - which provide access to information in PDL::Types eg print byte->ctype prints "PDL_Byte". Changed info in Core and rcols in IO/Misc to use these methods. Currently un-documented. Tim Jenness (6/28/00) - miscellaneous patches for Win32 support Make Callext.pm and callext.t more generic Lib/Image2D check for presence of rint() Add ABSTRACT and AUTHOR to top level Makefile.PL - conv.t now uses the Test module Doug Burke (6/21/00; 6/22/00) - mkhtmldoc.pl should now handle links to scripts in Index.pod for perl < 5.6.0. Removed link hacking for perl >= 5.6.0. 2.1.1 CS - fix Perl_croak problem with 'usethreading' Doug Burke (6/15/00) - hand-rolled podselect (podsel) created if perl version earlier than 5.6.0 Doug Burke (6/9/00) - added Christian's changes to online documentation to support scripts (eg see Index.pod or Index.html) Jim Edwards (5/19/2000) TriD (cvs brance trid_experimental) (merged 6/7/00) - several changes in TriD including a new Tk widget, see the file PDL/Graphics/TriD/README - added TkTriD demo to perldl.PL 2.1 Marc Lehmann (6/7/00) - enable sincos optimization only for glibc >= 2.1 CS - warn if 5.004 that next version will require 5.005 - PL_na issue in PGPLOT.xs - disable sincos optimization in complex.pd until glibc issues sorted John Cerney (6/2/00) - Updated FAQ to match the Jarle's version at http://www-astro.physics.ox.ac.uk/~jarle/PDLfaq/pdlfaq_new.html Doug Burke (5/31/00) - more minor doc patches John Cerney (5/26/00) - Applied patch to fix reflect options in conv2d (image2D function) not being symmetric. Ref sourceforge Patches 100287, 100359, and Bug 104614. Doug Burke (5/25/00) - added 'pdldoc' shell command to provide access to PDL documentation without having to start up perldl - cosmetic changes to output of usage + minor doc change to PDL::Basic John Cerney (5/25/00) - Modified PP.pm to call $arg1->copy for subclassed objects in some simple cases, otherwise call $class->initialize. See Basic/Pod/Objects.pod for a detailed discussion. Doug Burke (5/23/00,5/24/00) - corrected faulty t/interp.t and t/interp_slatec.t scripts - minor doc changes to Indexing.pod, image2d.pd, fft.pd & NDF.pm - added FRAME option to iis (Graphics::IIS) CS - hopefully the PDL::Filter modules will work now a proper test should be added Doug Burke (5/22/00) - Graphics::IIS - now works with new PP code + minor doc changes - Func - changed gradient() to work as described + added PDL::Func:: to method names in the documentation so they do not get picked up by perldl's help (eg 'help set') - \s to \\s in getfuncdocs() to avoid warning in Doc/Doc.pm John Cerney (5/21/00) - Minor Changes to Basic/Gen/PP.pm to fix error reporting, and to get rid of some warning messages when run with the -w switch Doug Burke (5/19/00) - Amalgated Interpolate & Interpolate::Slatec into PDL::Func (found in Lib/). I've left the old files in the distribution, although they're no longer made/installed, in case anyone wants to do a better job. - minor doc changes to Image2D zowie - Changed PGPLOT::im to PGPLOT::imag1 (1:1 aspect ratio shortcut). Avoids conflict with the imaginary-component sub by the same name. CS - fix for sever mem-leak -> ultimate source seems to be a problem in destroytransform on un-physvaffined piddle -- needs proper tracking down!!!! - more types for Otherpars (PP.pm) Doug Burke - added PDL::Interpolate and PDL::Interpolate::Slatec which provide a (hopefully) simple, OO interface to interpolation methods CS - correct PDL::Ops docs - fix problem in pdl_croak_param (pdlthread.c) due to changes in Perl_mess in perl 5.6 - update TODO zowie - Autoloader update (handles '+' for entire dir trees) - Graphics::PGPLOT::imag update (includes options for image scaling) - perldl update (minor fix to avoid null code ref bug in PDL::myeval) CS - debian stuff - image rotation (rot2d) - karma kimagergb renamed to krgb krgb -> can send 3d RGB piddles now (i.e. [3,x,y,z] piddles) CS - quick (and semi-dirty) inplace fix for ops.pd - slices.pd: fix xchg,mv not catching negative dims, treat neg dim indices like neg perl array indices Doug Burke (4/29/00) - fixed interpol failing to recognise extrapolation at 'high' x + added interpolate with slightly different error handling - commented out 'use PDL::Lib::LLSQRout' in PDL/Lib/Gaussian.pm Tim Jenness (4/26/00) - Patch mconf.h so that it works on Alphas running Linux Doug Burke - fixed apropos command to work with perl 5.6.0 - t/poly.t failed on solaris 2.7 with new PP code. Changed check from < 200 to < 210. - added PDL:getdim to Core.pm documentation Doug Hunt (4/26/2000) - Merged fast-xswrapper branch back to main PDL tree. - Left Ops thus: All ops are are overloaded to call XS as directly as possible, but the direct call of ops such as : $a->plus($b, 0) requires the '0' argument which tells the XS routine 'plus' not to swap the arguments. CS - slight ops.pd changes - match prototypes with original ones in complex.pd - some more work on PP.pm (yet unfinished) Doug Hunt (4/19/2000) - Cleaned up Ops to take advantage of new fast XS wrappers Doug Burke - changes to pod to HTML conversion. Links between modules - eg L - should now work. See Doc/mkhtmldoc.pl and Doc/scantree.pl - minor doc changes to a number of files - Improved output from apropos (aka ??) in the perldl shell: 1) ref string is now cleaned of any pod directives (eg C<$a> -> '$a') 2) the formatting has been improved, so that it fills the screen, word-wraps, and indents the ref string if printed on new lines 3) better handling of long names As an example, try 'perldl> ?? str' before and after. However, it's a *horrible* hack - using undocumented parts of Pod::Text to do 1 and 2, and calculation of screen width is poor. Needs testing on perl 5.6.0 for a start! CS - applied vaffine leak fix to main branch - new polyfill function (image2d.pd) - some (unfinished) preparations for easier leak debugging, see perldl.conf Doug Burke - Added PCHIP routines tp PDL::Slatec (interpolation, differentiation, and integration of functions). Also moved creation of SlatecProtos.h from Makefile.PL to slatec.pd - stop wfits() from complaining when reading in the header of FITS files from the DSS server at STScI - minor clean up of write_dummy_make() Basic/Core/Dev.pm - minor doc updates for PDL::Primitive and PDL::Basic - converted FFTW and GSL to use write_dummy_make() in Makefile.PL Tim Jenness - Update PDL::IO::NDF to v1.02, enhance reading of axis errors plus some bug fixes. - Add test for PDL::IO::NDF - Added polynomial fitting routines to PDL::Slatec (polfit, pvalue and pcoef) John Cerney - Added (psuedo)-support for variable-size strings in PDL::Char 2.005 CS - version to 2.005 - finally try to fix 5.6.0 problem correctly Doug Burke (4/4/00) - Changed to Basic/Makefile.PL to install man pages for PDL, PDL::Lite, PDL::LiteF, and PDL::Options. - Changed Makefile.PL to allow installation of documentation if INSTALLDIRS=perl (rather than site) is used CS - applied Karl's 5.6 patch to pdlcore.c - typo in Doug's error message fixed Doug Hunt (3/23/00) - Improved error messages in PDL::Graphics::PGPLOT for the case when the correct version of PGPLOT (v2.16 or later) is not installed. 2.004 John Cerney (3/16/00) - Added -lm to the Lib/Image2D/Makefile.PL suggested by Doug Burke to fix a compile problem on Solaris 2.7. John Cerney (3/15/00) - Added Christian Pellegrin's bilinear and image scaling patch. with cleaned up docs and test cases. - Update Version to 2.004 Doug Hunt (3/8/00) - Added 'use PDL::Graphics::PGPLOT' to Demos/PGPLOT_demo.pm. Now it works. This bug was introduced in my 3/2 and 3/3/00 changes. John Cerney (3/5/00) - Modified Basic/Complex/Complex.pd to not generate warning messages when re-defining the PDL overloaded operator subs. Doug Burke - IO::Misc - default type for DEFTYPE (rcols option) is now definable using the $PDL::IO::Misc::deftype variable. Doug Hunt (3/3/00) - Removed PDL::Graphics::PGPLOT from PDL.pm. This had been causing troubles due to the previous change which took away autoloading in PGPLOT. Doug Hunt (3/2/00) - Updated Graphics/IO/PGPLOT, adding a typemap and a PGPLOT.xs file. This change added capability to PDL::Graphics::PGPLOT::line, allowing one to use the 'MISSING' option. When this option is specified, 'line' will draw many disconnected polylines (delimited by the value specified as 'MISSING') instead of just one. This is useful in drawing maps with line. Marc Lehmann - Patch to Basic/Core/Dev.pm fix Parallel build bug. (Ref PDL-Porters Messages dated 1/8/00 and 1/5/00.) - Small Patch to Graphics/Karma/karma.pd. Change 'na' to 'PL_na'; (PDL-P msg 1/15/00) Robin Williams: - Patch to Graphics/TriD/OpenGL/generate.p to get OpenGL working on OSF (it crunched because perlxs interprets the #ifs as comments if they're indented). Karl Glazebrook: - Patch to Perldl.PL to improve readlines handling: - tells you which module it is using - correctly informs whether editing is available or not John Cerney - Documentation fix for FlexRaw.pm (Based on change submitted by Francois Primeau.) - Updated Makefile in FFTW to correct a build problem that occurs when both single and double FFTW libs are present. (suggested by Diab Jurius). - Updated TriD Makefile to find openGL libs specified in the perldl.conf file. - Updated Graphics/TriD/OpenGL/generate.p to include patch by Diab Jerius (ref PDL-Porters message dated 11/9/99). This fixes compilation problems with native openGL on solaris. Note: Patch to Graphics/TriD/TriD/GL.pm was not applied. (Risk of breaking GL on other platforms) CS - added function 'det' to PDL::Slatec -> calculate determinant Doug Burke - Graphics::LUT - added several intensity ramps, instead of just using a linear scale. - internal changes to Graphics::LUT - now stores data in external FITS files rather than within the module to improve speed and reduce use of disk-space. - first attempt at improving installation of OpenGL stuff - Graphics/IIS/iis.pd: minor change (re Christian's PP changes) - Graphics/PGPLOT/PGPLOT.pm: add CENTRE option [bin()], doc update - minor code cleanup for IO/NDF/NDF.pm and IO/Misc/misc.pd - added docs for sethdr to Basic/Core/Core.pm Marc Lehmann - small changes to complex.pd: remove bogus Cneg, streamline docs. Doug Burke - added TYPES/DEFTYPE options to PDL::IO::Misc::rcols() to specify the type of the piddles NOTE: (!!!) different from patch to 2.003 sent to perldl list (http://www.xray.mpe.mpg.de/mailing-lists/perldl/2000-01/msg00037.html), as you now specify the types directly, rather than as strings. - added HEADER option to PDL::IO::Misc::wcols() - added BORDER option to PDL::Graphics::PGPLOT - added examples of new PGPLOT options to 'demo pgplot' - added t/lut.t to test PDL::Graphics::LUT, and added tests of options in rcols() to t/misc.t - minor doc update for PDL::Primitive - example for whichND() now works CS - introduced switch for automatic hdr copying, off by default - PP: added pp_addbegin, pp_beginwrap and pp_setversion pp_addxs now adds to the current module's namespace by default, !not! to PDL anymore (patch by Marc Lehmann) pp_addisa now really works as advertised (i.e. adds to @ISA and doesn't split on whitespace anymore) - misc.pd: bswap functions work always inplace, remove [o] from sigs - added PDL::Complex to the dist (first try of a derived class), does remarkly many things already but needs some testing, donated by Marc Lehmann Doug Hunt - added PDL::Char, a subtype of PDL which allows manipulation of byte type PDLs as N dimensional arrays of fixed length strings Doug Burke - added AXIS option to PDL::Graphics::PGPLOT + doc changes - added PDL::LUT module to provide colour tables - useful for PGPLOT's ctab() function (note: plan, in near future, to change to a binary format to reduce size of this module) CS - Levenberg-Marquardt fitting module - added required additional slatec functions + some docs - some handy bits for PDL::Options function interface - bool.t didn't make it into 2.002 (touch problem?) - fftw.t test shouldn't rely on another module - PDL::Doc: support input from more than one file - Slatec/Makefile.PL: #include "g2c.h" seems unneccesary (and leeds to trouble on my debian 2.1 system) - PGPLOT patch from pdl-porters - Robin's Basic/Math patches 2.003 Christian Pellegrin - Patch to add an interface to the GSL (GNU Scientific Library) package. - Patch to compile under perl5.005_57 - Patch to add an interface to the FFTW library. (A free C FFT library including multi-dimensional, real, and parallel transforms) Christian Soller - Patch to add 'any' and 'all' functions to use for comparison operations. (e.g. This enables things like any($pdl == 3.2) or all($pdl > 0) ) - Patch to picnorgb test to fix greyscale and rgb generation on some platforms. - Misc Patch: Make Image.pm return 1. Make the gaussian fit routines use the correct xvals. Karl Glazebrook: - Patch to Basic/Core/Basic.pm to fix bug in centre=> when operating on pre-existing array. John Cerney: - Put File::Spec in the PREREQ_PM list. (PDL now requires File::Spec since PDL2.002) - Removed of ExtUtils::F77 from the distribution. Added ExtUtils::F77 to the PREREQ_PM list. (ExtUtils::F77 is already on CPAN separately. Having it also distributed with PDL causes confusion.) - Fixed cumuprodover docs to be similar to cumusumover. - Fixed typo in squaretotri function. (na changed to mna) - Fixed IO/FlexRaw to find properly find the howbig function. - Fixed export of rasc and rcube in IO/misc/ misc.pd. Brian Craft: - Patch to FastFaw.pm to fix sysread problems when reading from fifos. Lupe Christoph: - Patch to OpenGL.xs to compile with perlio/sfio. Brain Warner: - Patch so t/poly.t doesn't fail if Slatec not installed. Robin Williams: - Added Singular Value Decomposition (SVD) function. - Patch to IO/Browser/hists/dec_osf.pl to fix small syntax in -D_XOPEN_SOURCE_EXTENDED define flag. - Patch to Basic/Core/pdlthread.c to clarify error messages when barfing. - Patch to fix problems with generate.p and OpenGL on Solaris. Helmut Jarausch: - Change to pldcore.c to fix problem compiling on a IRIX6.5.3 box using perl 5.005_57 Mark Lehmann: - Patch to pdlcore.h and PP.pm to overwrite croak() via PP and not in pdlcore.h Joshua Pritikin: - Fix to Basic/Core/mkpldconv.p to change na variable to n_a. Al Danial: - Patch to fix compilation on RS/6000 running AIX 4.3.2 and perl 5.004_04. Doug Burke: - Patch to iis.pd to allow the user to change the title of an image displayed with iis(). - Patch to IO/Misc/misc.pd: 1) Added option PERLCOLS so you can now read in columns into perl arrays at the same time as reading in data into piddles. 2) Changed the meaning of the 'c' parameter in the LINES option. It will only affect you if you use LINES together with INCLUDE/EXCLUDE. 3) It now complains if you forget to surround patterns by // 4) It will also warn you (if $PDL::verbose is true) if no data is read in from a file. - Patch to PP.pod docs to clearup PRIV/CODE usage. Tim Pickering - Patch to Basic/Math/Makefile.PL to get the bessy0 and bessyn working again in glibc 2.1 systems. (glibc 2.0 as in RH 5.2 or debian 2.1 is not affected) 2.002 John Cerney: - Modified Basic/Core/Makefile.Pl so that ppport.h gets properly installed. - Removed Version.pm from distribution. This file now gets auto-generated during the build process. - Fixed permissions of Known_Problems file. - Misc Changes to Doc/mkhtmldoc.pl and Doc/scantree.pl to make html links work correctly. - Minor documentation fixes. Christian Soeller: - Fixed documentation build problems. Install process now builds a index html file. - Changes to get the win32 activestate port going. (available from ftp://ftp.aao.gov.au:/pub/perldl/dev/Win32) - Changes to compile under cygwin32. Doug Burke: - Modification to slices.pd docs clarifying the usage of -1 to indicate the last element when slicing. - misc.pd doc modification to indicate that rcols() will ignore lines beginning with a # character if no pattern is specified. - misc.pd patch to rcols where options can now be given to: only include lines matching a pattern exclude lines matching a pattern only use a specified range of line numbers - Patch to Graphics/IIS/iis.pd to fix warning messages when running with the perl -w flag. Karl Glazebrook: - Updated F77.pm to match version 1.10 of ExtUtils-F77. - Added polynomial fit package Polynomial.pm - Patch to Lib/Slatec/Makefile.Pl to fix problems compiling on sparc/solaris - Patch to Basic/Primitive/primitive.pd to make matmult thread properly and to make matmult an exported function. - Patch to Makefile.PL that allows PDL to be built and installed conveniently away from it's final destination. This is useful for making RPMs. Joshua Pritikin: - Patch to pdlcore.c moving some #defines around to improve portability between perl versions. Kristian Nielsen - Patch to Basic/Primitive/primitive.pd to fix whistogram and whistogram2d problems and updates documentation. Robin Williams - Update to Basic/Math/Makefile.PL. - Update to Basic/Primitive/Primitive.pd to include new functions. zcover, andover, etc. - Patch to FFT to fix but with single-column/row kernels Tim Jenness - Patch to IO/NDF/NDF.pm that updates the POD documentation and makes sure that the reader skips any array extensions (like those generated by Starlink CCDPACK). - Patch to Lib/Slatec/Makefile.PL to fix problems compiling slatec with g77 on Redhat linux - Patch to t/argtest.t, t/scope.t to get rid of warning messages. - Patch to perldl.PL that allows a user supplied subroutine to be called to pre-process all perldl strings. James Williams: - Patch to mkhtmldoc.pl to fix problem with not generating all html files. 2.001 John Cerney: - Added reference to the CPAN testers results page to the README file. - Fixed improper comments (causing warning messages) for '#endif _pdlmagic_h' in pdlmagic.h - Removed reference to PDL being only at 'alpha release' in Indexing.pod. - Updated Christian Soeller's email address in all files. - Clarified docs on the RMS element returned by the stats function. - Changed how $PDL::VERSION is set so CPAN will pick it up correctly: * PDL::VERSION is now set directly in PDL.pm * Makefile.PL reads $PDL::VERSION from PDL.pm and auto-generates Basic/Version.pm Joshua Pritikin: Changes for compatibility with PDL-Objstore. Includes all the fairly conservative changes. More radical changes to come. - Deals with portability between perl versions using Devel-PPPort. - Adds a version number to the PDL API. - Optional bounds checking for PP. - Simplistic support for C++ comments in PP code. - Much improved searching for the Solaris math library. Jarle Brinchmann: - Added 'isempty' function. Robin Williams: - Doc tidying in Basic/Math together with a wrapper routine for eigens and the start of a test set. Karl Glazebrook: - Patch to where function in primitive.pd to fix bug in ($i,$j,$k) = where($x,$y,$z, $x+5>0) - Added PDL::Fit-Gaussion Module - Patch to Core.pm so you can say $a = float(3,4,5) just as you can say $a = pdl(3,4,5). - Patch to slices.pd to export the dice and dice_axis functions. Robert Schwebel - Patch for the "perldl" shell that does the following: 1.) Print out usage information if non-valid option is given. 2.) Introduce "quit" equivalent to "exit" 3.) some linebreaks to fit comments into 80 char terminals Christian Soeller: - Commented out the close(STDERR) lines in pnd.pd to fix a problem where the output from a 'die' is not seen for certain test cases after using rpic/wpic from PDL::IO::Pic. - Misc Patch: - negative positions for dummy - matmult now also supports promotion to sig dims - PDL::matmult naming corrected - MathGraph: call PDL::random - Pic.pm: use PDL::Options -> minimum matching now supported removed 'close STDERR' calls - tifftopnm converter: added -nolut option - pnm.pd: get rid of 'uninitialized...' warning - flexraw.t: fix for broken linux dists that don't have compress (but gzip) - picnorgb.t: hopefully got rid of error with SGI format - slice.t/matmult.t: tests for new features. - Patch to - fix a bug when using pthreads and output argument creation - new function PDL::Core::pthreads_enabled - updated pthread.t - Fixed a problem in pdlapi.c where some vaffine optimizations had been broken by in a previous version. (Karl also added a test case to complain if this is broken again.) Doug Burke: - Patch to clean up some of the PGPLOT documentation. Harry Felder: - Patch to Basic/Math/Makefile.PL to not depend on PWD environment variable. Doug Hunt: - Patch to Core.pm to add '$PDL::undefval' variable, which controls how undefs are treaded when a PDL is created from a perl structure using pdl(), float(), double(), etc. Tim Jenness: - Change to perldl to accept -w flag. This runs perldl with the perl warnings (i.e. the perl -w flag) enabled. 2.0 (1.99990 with very minor changes) John Cerney - Fixed duplicate entry of PDL::IO::NDF information in the DEPENDENCIES file. - Added more items to Known_Problems file. 1.99990 John Cerney: - Renamed reorderDims method to reorder to slices.pd Christian Soeller: - Dimension promotion of 0-d PDLs patch. - Patch to pnm.pd to fix bug reported to the list by Karl. Tuomas Lukka: - Allow mmapping of null piddles (i.e. zero-length vectors: dims = (0)) - Fix Math spelling mistake: PI0 -> PIO - Fix Math compilation error: add ++ - Added close(fd) at the end of set_data_by_mmap in Core.xs Karl Glazebrook - Added Rcube to IO/Misc.pd Reads list of files directly into a large data cube (for efficiency). - Corrected spelling error in the README file. Pete Ratzlaff - Fix to imag() in PGPLOT.pm to set the world plotting coordinates to a more sensible result when specifying a translation. Jarle Brinchmann - Added FITS header support for comments & history. Joshua Pritikin - Patch to pdlapi.c to fix obvious memory leak. - Patch to PP.pm to workaround @_ bugs in perl5.005. Robin Williams - Fix for some reported compliation problems with Math library. 1.99989 Tuomas Lukka: - Added Fractal Mountain range to Tri-d demos - Corrected error in impatient.pod. ('top right' to 'top left' in 'Sections' section.) Tim Jenness - Updated dependency file to reflect the addition of PDL::IO::NDF to the distribution. Anton Berezin - Modified Basic/Math/Makefile.PL to fix potential conflicts with temp files in the /tmp directory John Cerney: - Added reorderDims method to slices.pd - Modified subclass2/3.t tests to be more representative of how a functional object would be subclassed. - Added '-I/usr/X11R6/include' to the default OPENGL_INC in perldl.conf Robin Williams - Cosmetic patch to TriDGallery - Addition of intover (integral) to Primitive.pm - Changes to Basic/Math files so that nan and infinity handling are now in a consistent interface. Pete Ratzlaff - Fixes typo in Gaussian.pm Karl Glazebrook - Patch to IO/Misc/misc.pd to fix a minor bug - Patch to IO/Misc/misc.pd to be more memory efficient. - Update to Simplex.pm docs to be more clear to mere mortals. Addition of tsimp2.pl example. Joshua Pritikin - Patch to pdlmagic.h to fix problems compliling with SunPro 4.2 C++. Christian Soeller: - Added a quick/simple ascii file reader (rasc) to IO/Misc.pd 1.99988 Christian Soeller: - patch to make the picrgb/picnorgb tests fail more gracefully with the commonplace 'maxval too large' problem. - Corrections for docs in PGPLOT.pm - Fix for pnm.pd to revert the STDERR redirection after a file is opened. Karl Glazebrook: - Updated Slatec's F77.pm from version 1.07 to 1.08 - Added qsorti function. - Added Karma text overlays - Added new indexing function dice_axis Robin Williams: - Fix for browser warnings appearing on finicky systems. Jarle Brinchmann: - Updated to PGPLOT.pm so that if you input a (100,1,100) image to imag, the 1-element dimensions will be ignored. It also checks that the piddle doesn't get too small, so that if you input a (100, 1, 1, 1) image, it will be treated as a (100,1) image by PGPLOT. John Cerney: - Modified PP.pod to get rid of 'head3' errors from the pod2man converters - Modified PDL.pm PDL::Lite.pm , PDL::LiteF.pm so that the $VERSION would be picked up correctly. 'use PDL 2.0' now correctly checks the version. - Fixed dead links in pod documentation. - Added dice and dice axis indexing functions in slice.pd (Cerney and Glazeblook) - Modified PdlParObj.pm to clarify 'too few dimemsions' errors. 1.99987 Karl Glazebrook: - Fix for minor array bounds bug in image2d.pd - Addition of PDL->create and PDL->destroy to pdlcore Core.xs - Change to perldl.conf to (a) Makes Karma find X better, (b) finds MesaGL as well as GL by default - Modification of the pic*rgb.t tests to fail more gracefully with bad converters. - Patch to Graphics/Karma/karma.pd to sort out some non- standard options casing. - Patch to Basic/Math/mconf.h to conditionally define INFINITY - Fix to IO/Misc/misc.pd so you can use pipes, + minor doc fix/update Jarle Brinchmann: - Minor Demos/PGPLOT_demo fix. Tim Jenness: - Patch to Core to get PDL->new() etc working. (pdlapi.c, pdlcore.h and Core.xs ) - Patch to perldl.PL so that $string, $code and $coderef can be used by the user. - Changes made to directory structure so NDF.pm would be installed correctly. Kaj Wiik - Minor syntax fix to PG_PLOT.pm 1.99986 Robin Williams: - Test for fft and fftconvolve and fix for fft.pd Karl Glazebrook: - Fix for PGPLOT to work more like it should Anton Berezin: - F77 Fixes for freebsd Anton Berezin - Fix to Pnm/pnm.pd to work under perl5.005 John Cerney - Fixes for subclassing to work properly - Addition of more test cases. - PP.pm and PP.pod additions for subclassing. - Minor Change to Html.pm to correct problem with it creating false html references from .pod text that contained '=head' as examples. - Updates to Doc/mkhtmldoc.pl to fix most problems with html documents not referencing each other correctly. In order to not change multiple .pod documents and documentation in .pm files, html docs will now be installed in ..../site_perl/PDL/htmldocs/PDL instead of ..../site_perl/PDL/htmldocs. (If installing over a previous version, the html files in .../site_perl/PDL/htmldocs should be deleted to avoid confusion. Robin Williams: - FFT test file addition (t/fft.t) (Test number 2 fails... commented-out for now) Andy Dougherty, John Cerney - Changes to compile with perl5.005 Anton Berezin: - Change for Browser to compile with freebsd Robin Williams: - Change behavior of overloaded bool operator to not stringify. This was causing a major slowdown in cases where a PDL object was being tested in a boolean context. (e.g. if($PDL){ ...} ) 1.99985 (2.0 one half to go ) Karl: - PGPLOT_demo.pm was hosed by Tjl. Fixed - same put in Makefile.PL and perldl.PL - perldl.PL: syntax error. - fft.pd: remove printf Tjl: - (noticed by Robin Williams) Whitespace removals - removed ops.pd SYNOPSIS Robin: - fix to browse building Dov Grobgeld: - the two pnm.pd one-liner for 5.005 (wpnm, rpnm) 1.9998 (2.0 try 7, one more to go ;) Robin: - spelling updates - PP.pm: silence xsubpp about prototypes - TriDGallery fixes - perldl: use pager, accept sub as prompt (added to by Achim) - PS to pnm in IO/Pnm/Pic.pm - MPEG border - ninterpol (n-dim regular grid interpolation), Lib/ImageND - badmask - fft.pd minimal patch - "using" - MPEG writing into stdin - save tmp files - fft new version - PP fixes: $P and cosmetics - rebin (N-dim rebinning algorithm) - rotate - curses.h include [ didn't include index() patch - incompatible. Maybe new name? ] Karl: - ExtUtils/F77.pm new version - debug/verbose patch - shift_elements (but supplanted by Robin's rotate later) - new Karma - NAN shall not spoil minimum/maximum - Make list() listindices do the right thing with nulls Tim Jenness: - fix misc problem when trying to write complicated headers to fits files - NDF writing/reading using the perl NDF module - MAIN__ into slatec.pd to avoid linkage errors - PDL::Options - minmax docpatch (modified by Tjl) Jarle: - PGPLOT update Joshua Pritikin: - -M, -m, -I arguments to perldl schinder@pobox.com: - use -f in Makefile.PL Tuomas: - Fix strndup in pdlthread.c - error if RAND_MAX not defined - cumu* (cumulative sum,product 1.9908 (2.0 try 6) Tjl: - memleak patch (idea by Robin) - pdl_destroytransform so that it doesn't core dump easily any more. 1.9907 (2.0 try 5) Christian: - major patch containing stuff from other people. Joshua: - dTHR -> errno if not defined Tjl: - quaternion rotate routine was totally hosed. added tests (probably will cause bad things where TriD doesn't exist :(.. 1.9906 (2.0 try 4) Robin: - patch Tjl's botched edit to his game of life - perldl.PL: do paging with page() and nopage(). Achim: - doc_install, pure_perl_install.. hopefully these now work Joshua Pritikin: - rename 'thr', 'op' and fix fftn.c error message for non-sick compilers - fix NAN on suns Tjl: - add #ifdef dTHR to be compatible with 5.004_* 1.9905 (2.0 try 3) Someone (lost the mail): - realclean Basic/Core/Config.pm Achim: - don't install pod2usage, pod2select in script dir - Lib/ImageRGB -> ImageRGB (!!!) - DEBUGGING => PDL_DEBUGGING - install patches for 5.005 Tjl: - remove gotos from str2D to not tickle bug in 5.004_64, which I couldn't reproduce at smaller scale :( - at Karl's prompting, removed the other mandelbrots for now :( - Fix memory leak (reported by Kaj Wiik) - change sin, cos, asin, acos, log, exp and the like to be [F,D] GenericTypes only. Robin: - TriDGallery: game of life! (edited by Tjl) Karl: - new karma.pd - reshape patch - callext patch 1.9904 (2.0 try 2) Tjl: - (Andreas Heitmann): rename rs in the rest of places - (Robin): openglq.pd: make COLORSAD not to warn for nonconstant init Karl: - histogram fix (which earlier fell through Tjl's fingers) - new ExtUtils::F77 - "aargh" patch Robin: - Demos/TriD2.pm: fix state at end - fix stupid Makefile.PL blooper by Tjl - patch Perldl.pm to do 'help $a' 1.9903 (2.0 try 1) Tjl: - PDL::Lib::FFT -> PDL::FFT (Robert Schwebel) - MathGraph stuff (same) - tiny TriD tweaks for VRML::Browser - strdup -> malloc(strlen+1)+strcpy - rename 'rs' Karl: - (finally applied) pdlcore.c datatype patch Jarle: - minmax + which_two - one2nd, whichND Robin: - PGPLOT fixes Achim: - Install fixes 1.9902 Tjl: - fix pdlcore.c to work with MAGIC hashes, to enable really wild constructions to come - twiddle with flexraw.t - PP cleanup: let 'SIZE' be used in RedoDimsCode. (needs to be cleaned up from the other kind of access to this.. also need '$PDL(a)') - null = just flag, so 0-dimensions are now allowed. - allow which to take other types for mask as well... - required cleaning PP to make RedoDimsCode be parsed just like Code, except without threadloop. Seems to work nicely. (I needed to take ($a == byte 5)->which for a large byte $a and was horrified to find that my program grew to dozens of Mb) !!! Note: possible incompatibility: before a floating value 0 exit: if slatec is not built, Lib/Makefile didn't get built Robin: - fix typo in Makefile.PL - add C<> in PG.pm Jarle: - better barf message for pdl((pdl 0), (pdl 1)) Gerald: - typo in PP.pod 1.9900 - make perldl-documentation startup not depend on verbose - '??' = apropos - wcols (with Robin) - fix the TriD demos a little bit... - clip - [xyz]linvals - TriD doc bug fix: grabPIC3d - vsearch - FastRaw doc bug - add to DEPENDS - misc.pd typos Karl: - deprecate where($a), multidim $a->where($b) 1.98_02 Tjl: - add maptextfraw - allow even more flexible PDL::Type::new: let it be a scalar piddle. - made stringize use listref_c for additional speed & avoiding stack overflows and other nasty stuff. - add scope.t to finally test for export stuff working and fix PDL.pm to use $pkg (from Karl). - undid the stupid glPolygonOffsetEXT fix, now it should finally work. - default.perldlrc: set verbose=0 to stop too much waffling! Karl [via Gerald] - Makefile.PL: -I patch 1.98_00 [ was 1.98_01 originally ] Tjl: - Various typos - for copyright notices, find ... | xargs perl -p -i.bak RULEZ! - remake Demos subdirectory with reasonable content. - new TriD demos in Demos/TriD - keeptwiddling3d etc. into TriD exported, NAME CHANGE !!! - hold3d parameter - POLAR2D context for TriD - document TriD::MathGraph briefly - fix TriD/Graph.pm to not barf when several graphs were removed - Fix mmapped piddle freeing for fastraw - now magickable. - Fix howbig, zeroes, Types stuff to accept PDL::Type objects instead of numbers in more places, e.g. FastRaw. fastraw.t updated - Removed TriD/Vertices.pm Lib/DataPresenter.pm - removed some of the old crud in Core.pm - Made Pod scanner not look into Pod::Parser. - lots of doc fixes, moving docs into the new format. - mkhtmldoc.pl: emulate "mkdir -p" when installing - Doc/Doc/Perldl.pm: allow e.g. 'new' to get 'PDL::new' to save typing. - standardize "3-d", "3-D" and "3d" into "3D". - Die on errors in evals in Basic/*.pm!!! (e.g. dynaloader unresolved symbols are now brought to light). - fix "GetHistory" bug by checking for "can". - Remove PCARout & PCA, as not really useful in present form !!! Robin: - mconf.h osf warnings patch 1.96_01 - TJL's jumbo patch - stuff into Basic/Math - TriD/MathGraph, for display of graphs in three dimensions, by finding an appropriate representation via a molecular dynamics-type search - Christian's clipping patch - set -ve indice patch - added my wcols() to PDL::IO::Misc - Lite.pm bug (Shawn) - Robin's mconf.h patch and Kaj's erfi.t test inserted - Christians type() patch - Christians const.c patch for IRIX - added Christian's COPYING suggestion - heroically went through and changed all the copyright messages on the docs to conform to the new standard - fixed (c) notice in Core.pm docs, others still need to be done - better explanation of GenericTypes and Pars in PP.pod - improved scantree.pl (portable cwd). - HTML docs!! - thanks to Christian's mkhtmldoc.pl (some changes) into the distribution. included a hacked Pod::Html (from perl 5.004) as PDL::Pod::Html Still not great but gives us something to work from. Some links still broken - patches welcome. See file:/usr/local/lib/perl5/site_perl/PDL/HtmlDocs for docs after 'make install' - TJL's average() patch and primitive.t patch - Docs now only built during 'make install' or 'make doctest' (which builds them under ./blib), this saves them being built unnecessarily during 'make' - PDL::Slatec now works on any system with a f77 compiler. All unused slatec functions were got rid of which fortunately removed all the ones with COMPLEX arguments. Also changed prototype generation which removes warnings on build. Added local copy of ExtUtils::F77 back into dist and WITH_SLATEC option to perldl.conf (undef by default for auto-decision). - removed Example/PP - out of date 1.95_07 - applied Christian's mega-patch - but there were problems I had to fix manually. (a) his maga-patch didn't include the patch to pdl.h he had already made. (b) the change should have been made to pdl.h.PL in any case. - fixed NAME in Indexing.pod - may have fixed executable install problem of 'perldl' shell - fixed PDL.pm being lost from docs db - Robin's problems 'compiling pdl 1.54_06 Basic/Math' patch 17/12/97 Rejected because of following error (Linux/gcc) const.c:80: parse error before `3.14159265358979323846' const.c:99: parse error before `__extension__' const.c:99: parse error before `}' Can the patch be revised? - Robin's at() accepts -ve indices patch. Can we have set() to? - removed 'docscan' and 'pdlhead2item' from MANIFEST - OK ? 1.95_06 KGB - FITS patch - restored cc8compt fibonacci from pdl-porters archive (!) - fixed misc module name problems in tests (thanks Bob!) - Robin and Christian's help patches - Robin's Object.pod patch - Achim: chmod 0755 on Doc/*.PL, - Achim wanted pdldoc.db in archlib, ignored this (don't understand why) - put fudge in ops.pd to get rid of that stupid compiler warning with abs() and byte/ushort types - rebuilt MANIFEST hope it is OK now - introduced new barf(...) routine in Core.pm and pdlcore.c [see help barf] we should use barf(...) in C and Perl code instead of croak etc. Note the barf engine is written in Perl, so is easy to customize! - changed references to 'croak' in pd/xs/c code to barf(..) or Perl_croak where appropriate - changed references to 'croak' in various .pm files to barf() where appropriate - croak #defined to barf() in pdlcore.h to catch the use in xsubpp (..fingers crossed..). Perhaps future xsubpp will allow an override of this. - renamed PDL::Io:: heirarchy PDL::IO:: for consistency with Perl IO:: 1.95_05 KGB - Renamed PDL.pdl_make_physical PDL.make_physical (woops!) - ditto physdims(). - Changed type config. Now Types.pm pdl.h pdlsimple.h are generated AUTOMATICALLY from Types.pm.PL pdl.h.PL and pdlsimple.h.PL files using perl Config information. int size issue is now handled from perl config information. Lots of potential for more flexibility. Hope this doesn't break Alpha stuff by mistake! - Revised PDL::CallExt. Now uses make_physical rather than PP and allows unlimited args in the same way as PDL-1.11. Ought to be more compiler friendly too! Put callext.t back. - Added 'dog' and 'cat' 1.95_04 KGB - Added glEnable/DisableClientState to dontfunc in OpenGL - Doug: added fake MAIN_ to cfft.f in Slatec for old g77s - Achim's patches of 4/12 - my IIS changes - Robin's random and Inf/NaN patches of 4/12 - Christian: 'minor doc polishing Core.pm+primitive.pd' - Christian: INSTALL patches. - Christian: 'docs in Doc/Doc/Perldl.pm' - Robin's minor perldl docs patch - Restored my missing hist() patch and test of Oct 10th (sic) - Achim's suggestions on help 'help' and help 'perldl', '?' and allow no quotes (with warning) - Added solaris_2 hints file for OpenGL - Robins perldl pod patches but NOT 'l' as a synonym for 'last' (I don't like this as 'last' is a perl keyword) 1.95_03 KGB: - Various small changes to TriD/test*.pl scripts. Renamed as *.p - minor TriD changes to comply with new zeroes() etc. - moved tests all into one top level t/ directory. - corrected PDL::initialise and convert (Christian) - Robin's primitive.pd patch - callext.t temporarily disabled - I will rewrite the module. - Minor changes to 'Doc'. - TriD renamed to PDL::Graphics::TriD 1.95_02 [emergency bug fixing release] KGB: - Redid all the zeroes/ones/[xyrz]vals/[g]random/sequence stuff someone please please give me some objective advice :-) - Added Robin's new FFT - 3 byte change to Pnm.pm for new zeroes() - added make_physical and make_physdims to PDL struct 1.95_01 KGB: - Added Cephes code to PDL::Math as backup, changed signature of jn, yn. - changed scalar convesion in pdlcore.c SvPDLV() - '2.0' is now double, '2' is now int. [Uses SvNOK SvIOK etc] - changed Basic/t/conv.t to comply. - Added magic {PDL} = code ref hook. And put test/example in subclass.t - random() is now like zeroes() and both allow type/dim and $x template arguments. New arg proc. method to support this. - Added grandom(). - Ressurected PDL::Exporter (q.v.). Much simpler than bizarrity in PDL-1.11. Now 'use PDL::Mod' defaults to loading ':Func'. Provision for noimports. Less typing!!!! Modified docs too. - Renamed PDL::Graphics::PG PDL::Graphics::PGPLOT - Reverted to manpages named PDL::FAQ.1, PDL::Dataflow.1, etc. This is simpler and maintains consistence between manpage and pod browsers. Fixed all the text links to comply. - small changes to Pod/ docs. - shut PP the hell up! Much less scary build now. - added Pods to files scanned in building doc database. - [xvyz]rvals now act like zeroes - but they now act like constructos so $derived->xvals does not give you what you expect. Need to think about this some more. 1.94_09 KGB: NOTE ONE MAJOR INCOMPATIBLE CHANGE [random] - removed PDL_OPTIONS - PDL_CONFIG for everything. I think this is better, e.g. if we want debugging we can add Debugging=>1 to %PDL_CONFIG. - changed use of PDL_CONFIG - see INSTALL. I think this is simpler. - made Karma conform with above - and simplified. - changed Callext arg limit to 10 to avoid compiler explosions. - integrated PDL::Doc, created PDL::Doc::Perldl. - manifying is now back from the .pm file rather then the .pd (this is a better design now pod are semi-generated from PP) - Christian's patches of 25/11/97: 'Core.xs and pdlapi.c' 'test' for Io::Pic - added docs for Doc field in PP.pod and made one-line a special case - Moved statistical functions from Basic.pm to Primitive.pm - Lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lots and lotsof miscellaneous docs. - Robin's browser patch of 26/11 - Core now completely OO - i.e. none of the stuff below Basic/ export routines to each other and it still works! - changed occurences of foo(sig) to use '=for sig' as this seems to work better with Pod::Parser. - made random $x=random($y), i.e. to get inplace now random(inplace $y) OK?????????? This is because I think it is natural to say $r = random(zeroes(10,20,2)), etc. If this is a major headache let me know and I will change it back. - Docs => undef allowed - no PP docs at all (not even the sig) - Various changes to Docs.pm and Docs::Perldl.pm - apropos text searches now include module names and one-line desriptions. God I love this language. - Renamed Iutil module as ImageRGB - hope this is OK??? - changed name of 'inv' to 'matinv' in Slatec for consistency with matmult in Primitive. 1.94_06 Christian: - lots of things. Robin: - add type to PdlParObj.pm Achim (req): - Version to Core.pm Tjl: - New configuration. 1.94_05 ... Not recorded. Real threading for example. 1.94_02 Lots of changes by everyone, e.g. FFT, Browser, ... 1.94_01 Christian: - simplescaler - VRML !!! Achim: - misc.t patch - Browser hints Karl: - autocreation memleak patch Robin: - flexraw test correction Jarle: - Ops.pd: prevent creation of -0 Tuomas: - Core bug fixes for e.g. $a->slice("...")->index(...) .= foo, originally reported by Christian. - mandel.pl demo Others?? 1.94 Kgb: - Autoload patch - subclass fixes: pdl_destroy + test. - sethdr + gethdr ref counts - rfits/wfits update Christian: - where etc. - imag3d without lines Kaj Wiik: - tsimp.pl use correction Achim: - Tk patch Tjl: - Change PP.pm to really allow Pars => 'a(tri=>3)' to happen. Embarrassingly, this was a one-liner. - OpenGL libs changed to take both GL and MesaGL. - openglq.pd: use tri=3 - rout.pd ditto - TriD.pm: documentation updates & 'LINE' as context - Graph.pm: coordinate axes labels! - test7.pl: some niceties. - make the thread incs etc. into register variables. this should, with a good compiler, result in some speedup. - primitive.pd: histogram -> histogram + whistogram, more thread-friendly. - correct foo.t - TriD: add imag3d_ns (no surface) and minor twiddling. 1.93_06 Kgb: - PP: use PDLOBJ for the stub subs. - Basic.pm: sec, ins fixes - use "int" to ensure type of coords. - PG.pm fixes - IIS fixes Achim: - ws fixes for docs, pptest.t - "small perldl fixes" Tjl: - start making support for piddle-controlled (e.g. affine) transformations by using magic. - Core.xs: setdims should now work with dataflow properly. - Core.xs, pdl.h, pdlapi.h, PP.pm: add support for foofunctions and PDL::Trans objects. These are a very basic way of accessing the internals of transformations so that in the future, as the mechanism is improved, you can e.g. change your slice from outside. The current level of support is enough to make a routine that takes a slice of one dimension and is given offset and increment and n in that. - TriD: - add test8.pl to demonstrate an use of foofunctions. - document OpenGLQ and Rout - add gl_triangles_n for shaded triangles - TriD.pm: - realcoords: add more contexts - make the default routines all plot a graph - GL.pm: - add glPolygonOffset call to GL::Window in order to get good-looking imag3d always - change the colors to somewhat lighter ones. - delete_viewports -> clear_viewports (like clear_objects) - new argument to twiddle - Graph.pm: - default names for dataseries - waffle less - support changed dataseries - Image.pm: - use realcoords COLOR context - Lines.pm: - start deprecation by renaming package - Objects.pm: - realcoords support better by r_type - waffle less - SLattice_S to draw shaded lattices - tests changed somewhat. - Core.xs: remove pdl_unpackint unnecessarity - Basic.pm: make axisvals return zeroes if not enough dimensions. - Opt/Simplex/Simplex.pm: add support for temperature a la Numerical Recipes. - (Christian) - remove Data::Dumper from FastRaw. 1.93_05 Tjl: - PP: several changes, basically inline *size and *incs into register variables to speed up execution. - TriD: - add TriD/Rout for misc C routines for TriD - add a routine to do flowing combination of 3 piddles into coordinates or colours - this makes the test3.pl data_changed stuff work again. - imagrgb now defaults to a whole-window image - no reason to make it rotatable with the mouse. 1.93_04 Tjl: - TriD: add stuff for Tk - OpenGL: ConnectionNumber - ButtonPress + Release: more info back - TriD.pm: add export imagrgb - Control3D: small changes + TriD::Tk::post_menu - GL.pm: ConnectionNumber support for Tk eventloop - Graph.pm: minor changes - Image.pm: major changes, make multi-D images actually work. also, support for different multi-D background color. ***** NOTE: calling convention now same as with coordinates! this means an incompatible change. - added Tk.pm, rudimentary support for a menu of actions associated with the displayed 3D graph. Currently, can save the image. - test3.pl: change to new imagrgb calling sequence. - GoBoard.pm: ditto - test6.pl: test the Tk functionality. - testimg.pl: really test the multidimensional picture facility with an 8-D tricolor picture. - Io/Pnm/Pic.pm: use the new 'Func' convention - perldl.PL: new '-tk' option to use Tk and the Tk event loop. 1.93_03 Tjl: - TriD: - Change default controller to ArcCone - Graphs with axes! - PP: - EquivDimCheck now honoured - iis.pd: #undef Generic - OpenGL/Makefile.PL update + generate.PL tuning - Browse: manpage twiddle 1.93_02 Tjl: - Core/Basic.pm: use PDL::Core qw/:Func/; - Core/Core.xs, pdl.h, pdlapi.h: hdr stuff (untested) - Core/Core.xs: bugfix threadover_n to make_physical - Core/pdlapi.c: pdl_destroy will not destroy if an affine trans the child of which hasn't been allocated exists. - Core/pdlapi.c: pdl_changed will not try to do overeager optimization. Fixes flow.t bug - Basic/t/flow.t: enable again the tests that now work. - Gen/PP.pm: new '$a = inner($b,$c)' changes. - Slices/slices.pd: splitdim checks arguments - Basic/t/thread.t: semi-add new test - Graphics/TriD/OpenGL: new PDL::OpenGL module to enable virtualization - Graphics/TriD/OpenGLQ: a test for TriD virtualization of OpenGL, this will later on expand a lot - Graphics/TriD/TriD.pm & TriD/*: new docs, small changes. - Io/Fastraw/FastRaw.pm: don't waffle when mmapping - MANIFEST.SKIP: add more ignorable stuff KGB: - Fixed multiple 'use PDL' etc problem for loaders. - "use 5.004" 1.93_01 (Kgb) MAJOR CHANGES - these are very significant and affect code throughout the system so EXPECT problems. In particular note that this code is the new PATCHBASE. - NEW IMPORT/EXPORT system PDL_OO.pm now deleted. PDL::Exporter is DEAD and gone!! (hooray) All modules now define their functions in package PDL. The idea is a PDL::Module now looks like this: package PDL::Module; @EXPORT_OK = qw( sub1 sub2 ...); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); @ISA = qw( Exporter ... ); *sub1 = \&PDL::sub1; sub PDL::sub1 { ... def ...} # If you wanted to do something special (e.g. a constructor) you can: sub rfits(PDL->rfits(@_)); # This gets exported sub PDL::rfits { my $class = shift; # etc... } i.e. the onus is entirely on the module writer. Thus saying 'use PDL::Module' will load (cheaply) PDL methods. If you want to (less cheaply) import functions say 'use PDL::Module qw/:Func/' PP has been modified to generate modules which follow this scheme. i.e. by default it stuffs its functions in to the PDL namespace, and writes stubs '*sub1 = \&PDL::sub1;' into the PM file. This can be changed at whim however. There is a new pp function - pp_bless('MyObj') which will change the default package from "PDL" to 'MyObj' in anticipation of future Object-Oriented PP modules. (Up to the author how he writes his module). Also the pp_def(PMFunc=>'...') attribute can be used to generate special purpose PM code instead of the default. Comments please, hopefully nice ones as I have spent all day changing code everywhere and debugging!!! - Karl (exhausted) - Module defaults PDL.pm now loads a set of standard packages (with :Func) - including graphics and I/O for TPJ article and v1.11 compatibility. Thus a script with 'use PDL' is v1.11 compatible (modulo bug fixes!) Lite.pm loads only the truly fundametal core, with no imports, for method speed freaks. Thus a lean script need only say 'use PDL::Lite' plus whatever else it needs. I hope various other sets of meta-modules (PDL::Astronomy, PDL::Medical) etc will follow this simple scheme. Basically there is nothing sacred about 'use PDL' anymore - it is just one of many loaders. - perldl shell The 'perldl' script sources C<~/.perldlrc> if present or falls back to C. The latter just does the standard 'use PDL' Thus by creating a C<~/.perldlrc> you are free to 'use PDL::Lite' or whatever set of modules you fancy without impinging on v1.11 compatibility. I think this is a rather elegant solution to all our aesthetic tastes (namespace polluters vs method maniacs, module hoarders vs leany meanies) while still ensuring script compatibility with v1.11. I hope everyone is happy with this! - Fixed minor bug in FlexRaw 1.92_10: 'make test' ok but see flow.t - PATCHBASE reset to zero (KGB) - new wfits() with BITPIX support and clever BSCALE/BZERO - PLEASE TEST!! - added Robin's PDL::Io::Browser - Robin's 'cutmask' function (need PP version!!!) - needs docs SOMEWHERE!! - string() no longer make_physical() - added mslice and test (slice.t) - lags patch (Jun 29) - extra tests to flow.t which FAIL, currently disabled as 'make test' then stops early. - added some tests of simple ops and functions - moved all the 2D routines (med2d etc) into PDL::Image2D - Inserted new TriD 16/Jul (untested) - tjl's 'IMPORTANT: Just let me eat my words once more today' patch - applied tjl's 'minorities' patch - ext modules now seem to work - fixed rfits/wfits bugs, added gzip/compress support via suffixes - increased size trap in pdlhash.c to 1Gb 1.92_09: - applied Tuomas' Simplex patch - applied Robin's patch: SlowRaw -> FlexRaw - added PDL::Io::Pnm and PDL::Io::Pic (+PDL::Lib::Iutil) to support image I/O based on pbmplus/netpbm (+ wmpeg based on mpeg_encode) - PDL::PP - $TBSULFD(B,S,U,L,F,D)_func now expands to B_func, S_func, etc *without* intervening whitespace - byte+ qualifier to make a pdl a "typeslave" - dispensed with Pthread.pm, thread_define now part of PDL::Core - new PDL::Dbg 1.92_08: - ops.pd debugged - FastRaw doc patches (TJL) 1.92_06/07: Applied the 41(!) missing patches. See file KGB.1.92_06_TO_1.92_07 - numerous small changes. 1.92_05/06: - Rudimentary perl level threading; see documentation in Pthread.pm. - Diagonal patch - workaround for slice and clump to *not* leave trans in a too ill-defined state when croaking (previously sometimes coredumped upon destruction (as reported by Karl), see tests in croak.t). - Karl's zeroes patch. - Matmult in primitive.pd. - history mechanism for perldl. - PDL::PP : type+ qualifiers, int, float and double now supported $GENERIC, $SIZE, fixed $P vaffine bug, [t] now does something, set named dimension from an 'OtherPars', i.e. OtherPars => 'int nsz => n' - primitive.pd : added histogram + interpol - Basic.pm : added hist - new file tests.pd in Basic/Test to hold tests for PP features - updated indexing.pod, PP.pod and FAQ.pod - Lib/Makefile.PL : only build slatec stuff if we have f2c (until we get a Makefile that works with ExtUtils::F77) - Dev.pm : change postambles so that C files built from .pd's will be cleaned 1.92_04: Lots of patches from people installed. If I forget someone's attribution, please remind me. 1.92_02: Vaffining. Just about everything should work now. New library files that don't work properly yet. 1.91_01: Perldl: don't use blib unless have to (eval). Hashes done away with: $a->{...} doesn't work. It was impossible to get both that *and* a reasonable assignment behaviour. 1.91: Bug fixen New PDL::PP The perldl shell now aborts on , q and Q. PDL-2.018/COPYING0000644060175006010010000000675512562522364011453 0ustar chmNone Copyright (c) 1997-2006 by the contributors named in the individual files. All rights reserved. This distribution is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The demonstration image m51.fits is derived from the Hubble Heritage project archival images; its creation was funded in part by a grant from NASA. The image is in the public domain. Inline documentation in any module files (pod format) and documentation files (.pod files) in this distribution are additionally protected by the following statement: Permission is granted for verbatim copying (and formatting) of this documentation as part of the PDL distribution. Permission is granted to freely distribute verbatim copies of this documentation only if the following conditions are met: 1. that the copyright notice remains intact 2. the original authors' names are clearly displayed, 3. that any changes made to the documentation outside the official PDL distribution (as released by the current release manager) are clearly marked as such and 4. That this copyright notice is distributed with the copied version so that it may be easily found. All the files in the distribution should have a copyright notice according to the following template: Copyright (C) 199X Author1, Author2. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. In addition, the following disclaimers apply: THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. PDL-2.018/cygwin/0000755060175006010010000000000013110402046011663 5ustar chmNonePDL-2.018/cygwin/drivers.list0000644060175006010010000001466112562522365014267 0ustar chmNone! PGPLOT drivers. !------------------------------------------------------------------------------ ! To configure PGPLOT, ensure that drivers you do not want are ! commented out (place ! in column 1). N.B. Many device-drivers are ! available on selected operating systems only. !------------------------------------------------------------------------------ ! File Code Description Restrictions ! BCDRIV 0 /BCANON Canon Laser printer (bitmap version), landscape ! CADRIV 0 /CANON Canon Laser printer, LBP-8/A2, landscape ! CCDRIV 0 /CCP DEC LJ250 Color Companion printer ! CGDRIV 1 /CGM CGM metafile, indexed colour selection C ! CGDRIV 2 /CGMD CGM metafile, direct colour selection C ! CWDRIV 0 /CW6320 Gould/Bryans Colourwriter 6320 pen plotter Std F77 ! EPDRIV 0 /EPSON Epson FX100 dot matrix printer ! EXDRIV 1 /EXCL Talaris/EXCL printers, landscape ! EXDRIV 2 /EXCL Talaris/EXCL printers, portrait ! GCDRIV 0 /GENICOM Genicom 4410 dot-matrix printer, landscape ! Caution: use of GIDRIV may require a license from Unisys: ! GIDRIV 1 /GIF GIF-format file, landscape ! GIDRIV 2 /VGIF GIF-format file, portrait ! GLDRIV 1 /HPGL Hewlett-Packard HP-GL plotters, landscape Std F77 ! GLDRIV 2 /VHPGL Hewlett-Packard HP-GL plotters, portrait Std F77 ! GODRIV 0 /GOC GOC Sigma T5670 terminal VMS ! GVDRIV 0 /GVENICOM Genicom 4410 dot-matrix printer, portrait ! HGDRIV 0 /HPGL2 Hewlett-Packard graphics language ! HIDRIV 0 /HIDMP Houston Instruments HIDMP pen plotter ! HJDRIV 0 /HJ Hewlett-Packard Desk/Laserjet printer ! HPDRIV 0 /HP7221 Hewlett-Packard HP7221 pen plotter Std F77 ! LADRIV 0 /LA50 Dec LA50 and other sixel printers ! LJDRIV 0 /LJ Hewlett-Packard LaserJet printers VMS ! LSDRIV 1 /LIPS2 Canon LaserShot printer (landscape) ! LSDRIV 2 /VLIPS2 Canon LaserShot printer (portrait) ! LNDRIV 0 /LN03 Dec LN03-PLUS Laser printer (landscape) VMS ! LVDRIV 0 /LVN03 Dec LN03-PLUS Laser printer (portrait) VMS LXDRIV 0 /LATEX LaTeX picture environment ! MFDRIV 0 /FILE PGPLOT graphics metafile ! NEDRIV 0 /NEXT Computers running NeXTstep operating system NUDRIV 0 /NULL Null device (no output) Std F77 ! PGDRIV 0 /PGMF PGPLOT metafile (new format, experimental) Std F77 ! PNDRIV 1 /PNG Portable Network Graphics file C ! PNDRIV 2 /TPNG Portable Network Graphics file - transparent background C PPDRIV 1 /PPM Portable Pixel Map file, landscape PPDRIV 2 /VPPM Portable PIxel Map file, portrait PSDRIV 1 /PS PostScript printers, monochrome, landscape Std F77 PSDRIV 2 /VPS Postscript printers, monochrome, portrait Std F77 PSDRIV 3 /CPS PostScript printers, color, landscape Std F77 PSDRIV 4 /VCPS PostScript printers, color, portrait Std F77 ! PXDRIV 0 /PRINTRONI Printronix P300 or P600 dot-matrix printer ! QMDRIV 1 /QMS QUIC devices (QMS and Talaris), landscape Std F77 ! QMDRIV 2 /VQMS QUIC devices (QMS and Talaris), portrait Std F77 ! TFDRIV 0 /TFILE Tektronix-format disk file VMS ! TODRIV 0 /TOSHIBA Toshiba "3-in-one" printer, model P351 ! TTDRIV 1 /TEK4010 Tektronix 4006/4010 storage-tube terminal Std F77 ! TTDRIV 2 /GF GraphOn terminal Std F77 ! TTDRIV 3 /RETRO RetroGraphics terminal Std F77 ! TTDRIV 4 /GTERM GTERM Tektronix terminal emulator Std F77 TTDRIV 5 /XTERM XTERM Tektronix terminal emulator Std F77 ! TTDRIV 6 /ZSTEM ZSTEM terminal emulator Std F77 ! TTDRIV 7 /V603 Visual 603 terminal Std F77 ! TTDRIV 8 /KRM3 Kermit 3 on IBM-PC Std F77 ! TTDRIV 9 /TK4100 Tektronix 4100-series terminals Std F77 ! TTDRIV 10 /VMAC Macintosh VersaTerm-PRO Tektronix-4105 emulator Std F77 ! TXDRIV 0 /TX TeX PK Font Output files ! VADRIV 0 /VCANON Canon Laser printer, LBP-8/A2, portrait ! VBDRIV 0 /VBCANON Canon Laser printer (bitmap version), portrait ! VTDRIV 0 /VT125 Dec Regis terminals (VT125 etc.) Std F77 WDDRIV 1 /WD X Window dump file, landscape WDDRIV 2 /VWD X Window dump file, portrait ! WSDRIV 0 /WS VAX workstations running VWS software VMS ! X2DRIV 0 /XDISP PGDISP or FIGDISP server for X workstations C XWDRIV 1 /XWINDOW Workstations running X Window System C XWDRIV 2 /XSERVE Persistent window on X Window System C ! ZEDRIV 0 /ZETA Zeta 8 Digital Plotter ! ! The following drivers can only be used in PGPLOT installations on MS-DOS ! systems with appropriate hardware and software. Do not select these ! on UNIX or VMS systems. ! ! LHDRIV 0 /LH IBM PCs and clones, Lahey F77 32-bit Fortran v5.0 ! MSDRIV 0 /MSOFT IBM PCs and clones running Microsoft Fortran 5.0 ! SSDRIV 0 /SS IBM PCs and clones, MS-DOS, Salford Software FTN ! ! The following driver can only be used in PGPLOT installations on Acorn ! Archimedes systems with appropriate hardware and software. ! ! ACDRIV 0 /ARC Acorn Archimedes computer ! ! Selection of the XMOTIF driver causes a stub driver to be placed in ! the main PGPLOT library. The real driver is placed in libXmPgplot.a. ! Applications that need the Motif driver should link with libXmPgplot.a ! before the PGPLOT library. This treatment means that only Motif ! applications have to be linked with Motif libraries. ! ! XMDRIV 0 /XMOTIF Motif applications containing XmPgplot widgets. C ! ! Selection of the XATHENA driver causes a stub driver to be placed in ! the main PGPLOT library. The real driver is placed in libXawPgplot.a. ! Applications that need the Athena driver should link with libXawPgplot.a ! before the PGPLOT library. This treatment means that only Athena ! applications have to be linked with Xaw libraries. ! ! XADRIV 0 /XATHENA Motif applications containing XaPgplot widgets. C ! ! Selection of the TK driver causes a stub driver to be placed in ! the main PGPLOT library. The real driver is placed in libtkpgplot.a. ! Applications that need the Tk driver should link with libtkpgplot.a ! before the PGPLOT library. This treatment means that only Tcl/Tk ! applications have to be linked with the Tcl and Tk libraries. ! ! TKDRIV 0 /XTK X-window Tcl/Tk programs with pgplot widgets. C ! ! The following driver is included solely for use by the aips++ team. ! ! RVDRIV 0 /XRV X-window Rivet/Tk programs with pgplot widgets. C PDL-2.018/cygwin/g77_gcc.conf0000644060175006010010000000755212562522365014004 0ustar chmNone# Cygnus cygwin32 b19 using # GNU g77 FORTRAN compiler # Gnu gcc C compiler. # # David Billinghurst (David.Billinghurst@riotinto.com.au) #----------------------------------------------------------------------- # Optional: Needed by XWDRIV (/xwindow and /xserve) and # X2DRIV (/xdisp and /figdisp). # The arguments needed by the C compiler to locate X-window include files. XINCL="-I/usr/X11R6/include" # Optional: Needed by XMDRIV (/xmotif). # The arguments needed by the C compiler to locate Motif, Xt and # X-window include files. MOTIF_INCL="$XINCL" # Optional: Needed by TKDRIV (/xtk). # The arguments needed by the C compiler to locate Tcl, Tk and # X-window include files. TK_INCL="$XINCL " # Optional: Needed by RVDRIV (/xrv). # The arguments needed by the C compiler to locate Rivet, Tcl, Tk and # X-window include files. RV_INCL="" # Mandatory. # The FORTRAN compiler to use. FCOMPL="g77" # Mandatory. # The FORTRAN compiler flags to use when compiling the pgplot library. # (NB. makemake prepends -c to $FFLAGC where needed) FFLAGC="-Wall -O2" # Mandatory. # The FORTRAN compiler flags to use when compiling fortran demo programs. # This may need to include a flag to tell the compiler not to treat # backslash characters as C-style escape sequences FFLAGD="-fno-backslash -I/usr/include" # Mandatory. # The C compiler to use. CCOMPL="gcc" # Mandatory. # The C compiler flags to use when compiling the pgplot library. CFLAGC="-DPG_PPU -O2 -DNOMALLOCH -I. -I/usr/include" # Mandatory. # The C compiler flags to use when compiling C demo programs. CFLAGD="-Wall -O2" # Optional: Only needed if the cpgplot library is to be compiled. # The flags to use when running pgbind to create the C pgplot wrapper # library. (See pgplot/cpg/pgbind.usage) PGBIND_FLAGS="bsd" # Mandatory. # The library-specification flags to use when linking normal pgplot # demo programs. LIBS="-L/usr/X11R6/lib -lX11 -lpng -lz" # Optional: Needed by XMDRIV (/xmotif). # The library-specification flags to use when linking motif # demo programs. MOTIF_LIBS="-lXm -lXt " # Optional: Needed by TKDRIV (/xtk). # The library-specification flags to use when linking Tk demo programs. # Note that you may need to append version numbers to -ltk and -ltcl. TK_LIBS="-ltk -ltcl -ldl" # Mandatory. # On systems that have a ranlib utility, put "ranlib" here. On other # systems put ":" here (Colon is the Bourne-shell do-nothing command). RANLIB="ranlib" # Optional: Needed on systems that support shared libraries. # The name to give the shared pgplot library. SHARED_LIB="" # Optional: Needed if SHARED_LIB is set. # How to create a shared library from a trailing list of object files. SHARED_LD="" # Optional: # On systems such as Solaris 2.x, that allow specification of the # libraries that a shared library needs to be linked with when a # program that uses it is run, this variable should contain the # library-specification flags used to specify these libraries to # $SHARED_LD SHARED_LIB_LIBS="" # Optional: # Compiler name used on Next systems to compile objective-C files. MCOMPL="" # Optional: # Compiler flags used with MCOMPL when compiling objective-C files. MFLAGC="" # Optional: (Actually mandatory, but already defined by makemake). # Where to look for any system-specific versions of the files in # pgplot/sys. Before evaluating this script, makemake sets SYSDIR to # /wherever/pgplot/sys_$OS, where $OS is the operating-system name # given by the second command-line argument of makemake. If the # present configuration is one of many for this OS, and it needs # different modifications to files in pgplot/sys than the other # configurations, then you should create a subdirectory of SYSDIR, # place the modified files in it and change the following line to # $SYSDIR="$SYSDIR/subdirectory_name". SYSDIR="$SYSDIR" PDL-2.018/cygwin/INSTALL0000644060175006010010000003326413036512175012740 0ustar chmNoneCreated on: Thu 27 Jul 2006 09:43:26 PM Last saved: Tue 11 Oct 2011 12:53:55 PM ================================================================= GENERAL NOTES ================================================================= NOTE: These install notes have been partially reviewed for the PDL-2.4.9 release. It is recommended that you build and install PDL based on a full cygwin 1.7.17 or later install. Please post to the perldl mailing list for help or questions regarding a cygwin install. By default, Cygwin has an ~300MB process memory limit. If you work with large data sets, you may wish to use the native win32 PDL with either ActiveState Perl or Strawberry Perl. Otherwise, you'll want to set the value of heap_chunk_in_mb to allow for bigger data as described in the Cygwin Users Guide: http://www.cygwin.com/cygwin-ug-net/setup-maxmem.html Work is underway to improve the native win32 perl PDL support for external dependencies so that it may be used, feature for feature, instead of the cygwin port. WARNING: There is a known problem with windows DLL base addresses being scrambled causing mysterious failures for cygwin builds. See the REBASEALL directions below for the current work around. Development for recent cygwins appear to be making progress towards fixing this problem. ================================================================= Installing with CPAN on Cygwin ================================================================= If you already have a full cygwin install on your PC, the simplest way to get a basic PDL is to use the cpan shell. This will get you all the functionality that is supported by existing cygwin package functionality (i.e. available from the standard Setup.exe installs). !! NOTE: you will be asked to answer some configuration !! questions the first time you use cpan on your system. !! Most should be self-explanatory. Just start up an xterm and run cpan from the bash prompt: bash$ cpan cpan> install ExtUtils::F77 cpan> install OpenGL cpan> force install Inline cpan> install PDL This installs the Perl OpenGL (a.k.a POGL) module, ExtUtils::F77, and Inline (the force here is necessary to work around a taint bug in the current release---should be no problem unless you need to run Inline programs with taint enabled), and should pull in installs for the following dependencies: Astro::FITS::Header Convert::UU Data::Dumper File::Spec Filter::Util::Call Pod::Parser Pod::Select Storable Text::Balanced if they are not already installed or of a recent enough version. You should finish with a PDL having the following functionality: - base PDL modules - PDL::IO::GD - PDL::GIS::Proj - PDL::Graphics::TriD - PDL::GSL::* - PDL::Minuit - PDL::Slatec - PDL::Transform::Proj4 ================================================================= Manual Configuration and Install ================================================================= In general, the standard install process for perl modules should work on cygwin. If you don't want to accept the default build options for PDL, edit the perldl.conf file. You'll find that file in the top level PDL folder/directory. The remaining PDL functionality depends on external libraries and packages that must be pre-installed before installing PDL. If you want to use other modules with external dependencies not available through the Setup.exe from http://www.cygwin.com then you'll need to get, build, and install the desired libraries yourself (see the HOW-TO notes below). The manual configure/build/install process is: Edit the PDL/perldl.conf file as desired From the bash$ prompt in the top level PDL/ directory: perl Makefile.PL # configures all the Makefile make # builds/compiles everything make test # run test suite make doctest # builds online documentation # and html docs If any tests fail (rather than skipped) you can run them by hand for more detailed diagnostic messages. For example: perl -Mblib t/plplot.t 1..27 ok 1 - use PDL::Graphics::PLplot; # Looks like you planned 27 tests but only ran 1. perl -Mblib t/proj_transform.t 1..4 # Looks like your test died before it could output anything. These test failures with the number of planned tests not equal to the number of tests run (1) or if a test died before it could output anything usually indicates a problem with the DLL base addresses. See the instructions for REBASEALL below. If PDL built ok and passed tests, you can test the interactive PDL shell before actually installing PDL by running from the PDL/ top level directory: perl -Mblib Perldl2/pdl2 # type quit to exit the PDL shell To finally install the PDL into your system run: make install ================================================================= FFTW ================================================================= !! You'll need to build *version 2* of the FFTW library for PDL. !! Version 3 has a new API and is not compatible with this PDL. # download the source code if needed, I used wget wget http://www.fftw.org/fftw-2.1.5.tar.gz # extract the source files tar xzf fftw-2.1.5.tar.gz # change to the source directory cd fftw-2.1.5/ # this is the standard GNU build process ./configure make make check make install The FFTW library built without a hitch and installed in /usr/local as the default (/usr/local/lib, /usr/local/include, and /usr/local/info). A clean build of PDL should pick it up. NOTE: if problems see REBASEALL below. ================================================================= PGPLOT ================================================================= NOTE: cygwin 1.7.9 has new include locations so the following will not work without changing the various paths!! 1. build the pgplot library and install. Download from http://astro.caltech.edu/~tjp/pgplot # Extract the archive file into a source location, I used ~/ $ tar xzf pgplot5.2.tar.gz $ cd ~/pgplot # Make an install directory, this is a typical default location $ mkdir /usr/local/pgplot $ cp drivers.list /usr/local/pgplot/ $ cd /usr/local/pgplot $ vi drivers.list Edit drivers.list to enable the drivers you wish but uncommenting desired drivers by removing the leading ! on the line. Here are the ones I used (see PDL/cygwin/driver.list): $ grep -v '^!' drivers.list LXDRIV 0 /LATEX LaTeX picture environment NUDRIV 0 /NULL Null device (no output) Std F77 PPDRIV 1 /PPM Portable Pixel Map file, landscape PPDRIV 2 /VPPM Portable PIxel Map file, portrait PSDRIV 1 /PS PostScript printers, monochrome, landscape Std F77 PSDRIV 2 /VPS Postscript printers, monochrome, portrait Std F77 PSDRIV 3 /CPS PostScript printers, color, landscape Std F77 PSDRIV 4 /VCPS PostScript printers, color, portrait Std F77 TTDRIV 5 /XTERM XTERM Tektronix terminal emulator Std F77 WDDRIV 1 /WD X Window dump file, landscape WDDRIV 2 /VWD X Window dump file, portrait XWDRIV 1 /XWINDOW Workstations running X Window System C XWDRIV 2 /XSERVE Persistent window on X Window System C Edit the sys_cygwin configuration file to work with the current version of cygwin. (TBD, update this file and pass on to pgplot distribution for inclusion, for now see PDL/cygwin/g77_gcc.conf) $ vi sys_cygwin/g77_gcc.conf # This diff command shows the lines that need changing $ diff g77_gcc.conf* 12c12 < XINCL="-I/usr/X11R6/include" --- > XINCL="-I/usr/X11R6.4/include" 48c48 < FFLAGD="-fno-backslash -I/usr/include" --- > FFLAGD="-fno-backslash" 58c58 < CFLAGC="-DPG_PPU -O2 -DNOMALLOCH -I. -I/usr/include" --- > CFLAGC="-DPG_PPU -O2 -DNOMALLOCH -I." 75c75 < LIBS="-L/usr/X11R6/lib -lX11 -lpng -lz" --- > LIBS="-L/usr/X11R6.4/lib -lX11" $ ~/pgplot/makemake ~/pgplot cygwin $ make $ make clean $ make cpg $ PGPLOT_DIR="/usr/local/pgplot/"; export PGPLOT_DIR Be sure to add PGPLOT_DIR to your environment and add it to your PATH as well. Now we can build the PGPLOT module for perl. Download from www.cpan.org if needed. 2. Now install the PGPLOT perl module. This is used by PDL::Graphics::PGPLOT. $ tar xzf PGPLOT-2.19.tar.gz $ cd PGPLOT-2.19 # Be sure to set the environment! $ export PGPLOT_DIR=/usr/local/pgplot $ export PATH=$PGPLOT_DIR:$PATH $ perl Makefile.PL Hand edit the Makefile generated by Makefile.PL and correct the link line (TBD: fix the Makefile.PL build process and propagate cygwin fixes back to the module author. Sorry, you'll have to edit this one). $ vi Makefile Edit the EXTRALIBS = ... and LDLOADLIBS = ... lines to change "-lpgplot -lcpgplot" to "-lcpgplot -lpgplot -lpng -lz" The first part of the modified lines look like this: EXTRALIBS = -L/usr/X11R6/lib -L/usr/local/pgplot -lcpgplot -lpgplot -lpng -lz -lX11 ... LDLOADLIBS = -L/usr/X11R6/lib -L/usr/local/pgplot -lcpgplot -lpgplot -lpng -lz -lX11 ... Build it now: $ make # Lots of tests! $ make test $ make install pgplot library is installed and working. PGPLOT module is installed and working. 3. Build PDL configured to use PGPLOT (in perldl.conf file). If your pgplot installation worked, it should be picked up automatically. NOTE: if problems see REBASEALL below. ================================================================= FFMPEG ================================================================= ffmpeg later than 0.6.1 (i.e, gotten by git clone of the ffmpeg.git repository) builds out-of-the-box with the standard directions on cygwin 1.7.7+. You'll need the latest version because of a namespace conflict with the bswap_16, bswap_32, and bswap_64 macros. See this page for the git clone information: http://ffmpeg.org/download.html An alternative is to download the latest GIT snapshot following these directions. You'll need to have the various dependencies for ffmpeg install to build successfully. A full cygwin install should work. (1) Download the git snapshot of the ffmpeg tree from: http://git.videolan.org/?p=ffmpeg.git;a=snapshot;h=HEAD;sf=tgz (2) The file will be named something like ffmpeg-HEAD-xxxxxxx.tar.gz where the xxxxxxx is a hexadecimal number related to the commit. Extract the tar file and change to that directory: bash$ tar xzf ffmpeg-HEAD-xxxxxxx.tar.gz bash$ cd ffmpeg-HEAD-xxxxxxx/ (3) Configure, build, and install ffmpeg: bash$ ./configure --enable-static --disable-shared bash$ make # build bash$ make check # test bash$ make install # install bash$ type ffmpeg # check install ffmpeg is /usr/local/bin/ffmpeg (4) Now you should be able to run the wmpeg.pl demo in Example/IO of the PDL source distribution directory. If the check install does not work, check that /usr/local/bin (or wherever the ffmpeg installed) is in the PATH. NOTE: wmpeg('file.gif') can be used to generate an uncompressed GIF animation (BIG!). You can build/install gifsicle on cygwin with the default instructions to use to optimize the memory usage of the GIF animations. See the gifsicle site for the source and build instructions: http://www.lcdf.org/gifsicle/ ================================================================= REBASEALL ================================================================= There is a known issue on cygwin where DLLs have to have their base addresses fixed so that runtime conflicts do not occur. The problems occur for the external modules and their interfaces using DLLs. Specifically, the DLLs in /usr/lib/perl5 and the DLLs in the PLplot bin directory at least. The usual sign for this is that some tests fail mysteriously. If you run the failing test by hand (for example): perl -Mblib t/plplot.t You may see no error but only 1 test run or even a message saying that the test failed before generating any output. If so, you'll need to run rebaseall: 0. Generate a list of additional DLLs to check: find /usr/lib/perl5 /usr/bin /usr/local /pdl_build_dir/blib -iname '*.dll' > /bin/fixit.list 1. Exit all cygwin processes, windows, shells, X server,... 2. Start up a windows CMD shell window (Start->Run cmd) 3. cd to the cygwin /bin directory (cd c:\cygwin\bin by default) 4. Run ash in that directory (ash) 5. Run rebaseall (./rebaseall -T fixit.list) Note that we created the fixit.list file in the c:\cygwin\bin folder to begin with. If you put it elsewhere, you'll need to use the appropriate pathnames. 6. Run peflagsall (./peflagsall -T fixit.list) 7. Restart cygwin After the rebaseall command has completed, you should be able to start up X windows and rerun the failed tests (perl -Mblib t/testname.t) or all tests (make test). NOTE: From the cygwin-xfree mailing list: > Also, I've found that using a different base address with rebaseall > seems to help with some X problems: > > dash -c "rebaseall -b 0x77000000" > > http://cygwin.com/ml/cygwin/2011-04/msg00306.html > > cgf ================================================================= HDF ================================================================= TBD ================================================================= NDF ================================================================= TBD PDL-2.018/cygwin/README0000644060175006010010000000740113036512175012561 0ustar chmNoneCreated on: Thu 27 Jul 2006 09:43:26 PM Last saved: Mon 09 Jan 2012 09:44:26 AM ================================================================= Overview ================================================================= This directory contains supplemental build information to configure and install PDL on a windows system with the cygwin toolset (http://www.cygwin.com). The cygwin library provides the missing unix/posix functionality to allow unix applications to be more easily ported to windows. A windows PC with cygwin looks like different flavor of unix. Since cygwin looks like a unix, [almost] all of the standard perl functionality works and PDL can build pretty much as it does on other unix systems. See the INSTALL file for instructions on building and installing PDL on cygwin and for notes on building the external dependencies. See the PDL/win32 subdirectory for instructions on building a native windows PDL. ================================================================= WORKING ================================================================= The cygwin PDL includes all the base PDL functionality including bad values support (if configured) as well as the following modules which depend on the presence of various external dependencies: PDL::FFTW (Builds if FFTW version 2 has been hand built and installed, cygwin Setup.exe only provides FFTW version 3). PDL::Graphics::PGPLOT (Builds if the FORTRAN pgplot library has been hand built and installed, and if the *Perl* PGPLOT module is installed and FORTRAN) PDL::Graphics::TriD (Builds automatically if you have X11 and OpenGL + FreeGLUT installed). PDL::GSL::* PDL::GSLSF::* (Builds if GSL is installed via cygwin Setup.exe) PDL::IO::GD (Builds if the gd lib is installed via cygwin Setup.exe) PDL::GIS::Proj PDL::Transform::Proj4 (Builds if the PROJ4 lib is installed via cygwin Setup.exe) PDL::Minuit (Builds if ExtUtils::F77 has been installed and FORTRAN) PDL::Slatec (Builds if ExtUtils::F77 has been installed. Needs a FORTRAN compiler.) PDL::IO::Browser (Build may pass if enabled, disabled by default for all OSes) pdl2 (Installed by default. To use the new features, you will need to install Devel::REPL and one of either Term::ReadLine::Perl or Term::ReadLine::Gnu. The Gnu flavor is currently recommended for cygwin.) and also PDL::ParallelCPU (Parallel pthread support will build and install by default since the cygwin DLL includes POSIX threads) ================================================================= GRAPHICS (non-CORE DISTRIBUTION) ================================================================= These graphics modules are known to work but are not in the core PDL distribution. You'll need to install from CPAN separately: PDL::Graphics::Gnuplot Needs the gnuplot executable PDL::Graphics::Prima Install Prima and PDL::Graphics::Prima via the cpan shells cpan, cpanm... Give interactive plotting support and a full GUI toolkit that can be used to implement graphical perl/PDL/Prima apps. ================================================================= NOT WORKING ================================================================= These modules with external dependencies are not yet available for cygwin: PDL::Graphics::IIS PDL::IO::HDF (HDF4 has not been ported to cygwin but HDF5 is available via the cygwin setup program. PDL::IO::HDF5 fails to build due to unix/linux specific library detection for libhdf5) PDL::IO::NDF (NDF has not been ported to cygwin) PDL-2.018/debian/0000755060175006010010000000000013110402046011605 5ustar chmNonePDL-2.018/debian/changelog0000644060175006010010000006075012562522365013510 0ustar chmNonepdl (1:2.4.11-4) unstable; urgency=low * fix pdl versioned dep in dh_pdl -- Henning Glawe Wed, 30 May 2012 16:06:03 +0200 pdl (1:2.4.11-3) unstable; urgency=low * fix the building of pdl wrapper * set -fPIC when compiling fortran extensions -- Henning Glawe Mon, 28 May 2012 20:44:46 +0200 pdl (1:2.4.11-2) unstable; urgency=low * fix calls to croak in Lib/GIS/Proj/Proj.pd and IO/GD/GD.pd (croak was not called with a format string literal, causing -Werror=format-security to abort the compilation) -- Henning Glawe Sun, 27 May 2012 16:01:22 +0200 pdl (1:2.4.11-1) unstable; urgency=low * new upstream release * acknowledge NMU (closes: #670693), thanks to Jari Aalto * switch to 3.0 quilt packaging format, the +dfsg repackaging of upstream source is not needed anymore * provide pdlapi-$version virtual package to keep binary extension modules from breaking silently * introduce dh_pdl providing ${pdl:Depends} for extension packages * use dpkg-buildflags in debian/rules to determine flags * link with --as-needed to avoid spurious dependencies * switch to dh_auto_configure to call EU::MM with the proper flags * read LDFLAGS and FFLAGS in f77conf.pl from env * depend on newer dpkg-dev due to buildflags options -- Henning Glawe Sat, 26 May 2012 10:30:55 +0200 pdl (1:2.4.10+dfsg-1.1) unstable; urgency=low * Non-maintainer upload. * Remove deprecated dpatch and upgrade to packaging format "3.0 quilt". * Update to Standards-Version to 3.9.3 and debhelper to 9. * Add build-arch and build-indep targets; use dh_prep in rules file. * Fix copyright-refers-to-symlink-license (Lintian). * Fix duplicate-in-relation-field libastro-fits-header-perl (Lintian). * Fix unused-override (Lintian). -- Jari Aalto Sat, 28 Apr 2012 08:44:59 +0300 pdl (1:2.4.10+dfsg-1) unstable; urgency=low * new upstream release * sync debian/perldl.conf with perldl.conf -- Henning Glawe Sun, 19 Feb 2012 10:42:56 +0100 pdl (1:2.4.7+dfsg-2) unstable; urgency=low * remove left-over file 'test.log', which slipped into the 1:2.4.7+dfsg-1 debian diff * include upstream release notes in deb * fix Pod of PDL::IO::FastRaw * add lintian override: it is OK to have dpatch dependency with an empty patch list. Usually I am adding fixes as dpatch patches, and it is useless to add/remove the dpatch support in case there are no patches for one particular revision. * add a lintian override for a long code line in a manpage, which cannot be easily broken -- Henning Glawe Sun, 22 Aug 2010 21:19:32 +0200 pdl (1:2.4.7+dfsg-1) unstable; urgency=low * new upstream version - much improved documentation (closes: #132900) * build-depend on netpbm (improves testsuite runs) * build-depend on proj-bin (alternatively with proj) to have 'proj' command available * build-depend and suggest libdevel-repl-perl (for new pdl2 shell) * update debian standards-version to 3.9.1 (no further changes needed) * improve test suite run output in build log -- Henning Glawe Thu, 19 Aug 2010 11:40:22 +0200 pdl (1:2.4.6+dfsg-2) unstable; urgency=low * pgperl is back in debian, name changed to libpgplot-perl; changed the pdl recommends to reflect that (closes: #407463) -- Henning Glawe Tue, 11 May 2010 07:56:50 +0200 pdl (1:2.4.6+dfsg-1) unstable; urgency=low * fix paths in generated HTML docs * add dpkg trigger for documentation index and HTML documentation updates * add ${misc:Depends} to pdl's Depends (recommended by lintian due to debhelper usage) * use DESTDIR instead of PREFIX when installing (recommended by lintian, as this works only due to a debian-specific MakeMake extension) * bump (build-)dependency on libopengl-perl to 0.62 * update to standards-version 3.8.4 * build-depend on libhdf4-alt-dev (closes: #540404) * modify hdf support build scripts to autodetect the 'alt'-flavour * build-depend on libproj-dev (closes: #521822) * move Homepage to Homepage control field and improve description (closes: #574372) -- Henning Glawe Sat, 08 May 2010 17:10:16 +0200 pdl (1:2.4.5+dfsg-2) unstable; urgency=low * switch TriD from X11 to freeglut * patch test suite to give more meaningful results * repair f77config, link against libgfortran.so * run testsuite in verbose mode to get more information * build-depend and suggest ExtUtils::F77 * suggest Astro::FITS::Header -- Henning Glawe Mon, 09 Nov 2009 12:32:34 +0100 pdl (1:2.4.5+dfsg-1) unstable; urgency=low * new upstream release * repacked upstream source without debian dir * build-depend on sharutils to have uuencode/uudecode available for test suite * build-depend on libraries needed for the reworked TriD module * remove maintainer script postrm, it was actually empty * bump standards-version to 3.8.3 * bump debhelper compatibility level to 7 * generate html docs and doc index in /var/lib/pdl * put symlink to files in /var/lib/pdl into /usr/lib/perl5/PDL -- Henning Glawe Fri, 06 Nov 2009 21:45:44 +0000 pdl (1:2.4.3-8) unstable; urgency=low * add proper description to the dpatch pathes (6 lintian warnings) * backport documentation 'apropos' search function from upstream cvs (closes: #499758) * remove empty manpage /usr/share/man/man3/PDL::PP.3pm (lintian warning) * update standarts version to 3.8.0 (lintian warning) * build-depend on x11proto-core-dev instead of x-dev (lintian error) * remove libgl1 from Suggests; there is no 3d support presently * bump readline Suggests: to Recommends:, as users are lost in interactive mode without it * Fix doc-base entry (Science/Mathematics instead of Apps/Math) * suggest doc-base -- Henning Glawe Mon, 22 Sep 2008 09:42:25 +0200 pdl (1:2.4.3-7) unstable; urgency=low * patch upstream IO/Makefile.PL to also install Dicom IO module (closes: #474751) * disable opengl based PDL::Graphics::TriD, it is not working with perl 5.10. this considerably lowers PDL's dependencies, upstream does not yet have a solution for this problem (closes: #495379) * apply upstream patch for the pct() problem (closes: #488092) -- Henning Glawe Sat, 20 Sep 2008 13:44:57 +0200 pdl (1:2.4.3-6) unstable; urgency=low [ Rafael Laboissiere ] * Switch from g77 to gfortran [ Henning Glawe ] * apply Rafael's patch (closes: #468637) -- Henning Glawe Tue, 4 Mar 2008 09:05:08 +0100 pdl (1:2.4.3-4) unstable; urgency=low * clean up leftover files not caught by pdl's distclean target (closes: #424345) * clearly state in PDL::Fit::Gaussian synopsis that PDL has to be loaded first (closes: #379932) * apply patch for uniqvec/qsortvec from upstream BTS (closes: #415426) * encode Latin1 characters in POD documentation as roff * postprocess the "reduce" manpage's NAME section to remove roff macros (closes: #304217) * remove misplaced whitespace characters from changelog * fix the menu entry to reflect current menu policy * add lintian override to ignore the missing html files; they are generated in the postinst script, so lintian can not see them * fix the gsl version check * comment out the dump() calls in t/xvals.t test, as this seems to confuse the test result parser * rebuild for the ldbl128 transition (closes: #430319) -- Henning Glawe Tue, 16 Oct 2007 10:25:18 +0200 pdl (1:2.4.3-3) unstable; urgency=low * add -DGLvoid=void in the cpp call for setting up the OpenGL typemaps in order to make PDL build with newer mesa versions (closes: #390122) -- Henning Glawe Mon, 9 Oct 2006 18:07:41 +0200 pdl (1:2.4.3-2) unstable; urgency=low * upstream: enhance the 64bit-excludelist for the flexraw-test * let the build continue anyways if problems are found in the testsuite, so its output is only informational -- Henning Glawe Mon, 25 Sep 2006 10:43:58 +0200 pdl (1:2.4.3-1) unstable; urgency=low * new upstream * enable gd, proj and HDF support * force-enable WITH_3D, as on debian autobuilders, there is no $DISPLAY and therefore the autodetection does not work -- Henning Glawe Thu, 17 Aug 2006 12:27:03 +0200 pdl (1:2.4.2-6) unstable; urgency=low * Graphics::TriD did not compile anymore. Backport this module from HEAD. * update standarts-version to 3.7.2 * build-depend on libxext-dev, as the TriD GL needs it * incorporate OpenGL build fix from upstream BTS 1505132 -- Henning Glawe Tue, 13 Jun 2006 10:14:39 +0200 pdl (1:2.4.2-5) unstable; urgency=low * add workaround for broken ExtUtils::MakeMaker in perl 5.8.8 (closes: #356975): - as EU::MM generated Makefiles reference PERLRUN instead of PERLRUNINST, explicitly "use blib;" in the BAD{,2}_demo.pm.PL -- Henning Glawe Fri, 2 Jun 2006 10:17:39 +0200 pdl (1:2.4.2-4) unstable; urgency=low * make the xlibs-dev transition for x.org 6.9 (closes: #346926): - build-depending on x-dev should be enough according to http://www.inutil.org/jmm/xlibs/xlibs-split-2005-11-15.tar-bz2 * Suggest libplplot-dev and tell about the PDL::Graphics::PLplot examples it contains in pdl's README.Debian -- Henning Glawe Mon, 9 Jan 2006 09:15:31 +0100 pdl (1:2.4.2-3) unstable; urgency=low * change Build-dependencies to build with xorg (closes: #318258) * add libinline-perl to suggests * add perl readline modules to suggests -- Henning Glawe Thu, 14 Jul 2005 14:49:42 +0000 pdl (1:2.4.2-2) unstable; urgency=low * use dpatch for patch management * split out Makefile clean target patch * split out patch preventing the generation of an empty manpage pdl.1p * get fix for transform.pd from cvs (problem reported on pdl mailing list) * fix a second problem with PDL_Double used not in C code in transform.pd * patch mkhtmldoc.pl to generate relative links instead of absolute ones; absolute pathnames confused dhelp sometimes. * move debhelper template in prerm up, so the doc-base remove call is done before the dynamically generated html files are removed * patch remove obsolete upstream debian files until these changes are checked in. * mention new pdl htmldoc location in README.Debian -- Henning Glawe Sun, 16 Jan 2005 18:42:29 +0100 pdl (1:2.4.2-1) unstable; urgency=low * new upstream release * remove comment about not including m51.fits from debian/copyright * re-import COPYING to debian/copyright * include perldl.conf used in "official" package as debian/perldl.conf * install Known_problems to docdir * fix clean target in upstream makefiles * use upstream makefile distclean target in debian/rules clean target * fix description+synopsis * remove references to obsolete websites from README * rework packaging with debhelper * build html docs in /usr/share/doc/pdl/html/PDL and install doc-base entry for this * remove lintian override, slatec is now built with -fPIC * disable building of pdl.1p from pdl.PL, so the correct pdl.1p from Basic/Pod/Intro.pod is included -- Henning Glawe Mon, 10 Jan 2005 15:59:25 +0100 pdl (1:2.4.1-1) unstable; urgency=low * new upstream release * don't print debug info in preinst (Closes: #69978) * enable bad value support, the impact should be minimal on modern hardware (Closes: #113607) * took plplot from PDL HEAD * clean up doc index and html docs in prerm (Closes: #160034) -- Henning Glawe Thu, 22 Jul 2004 19:16:24 +0200 pdl (1:2.4.0-1) unstable; urgency=low * new maintainer (Closes: #215543) * acknowlege NMU (Closes: #141117, #104630, #140104, #170182) * new upstream release. * enable plplot support (Closes: #196185) * enable gsl support * enable fftw support * swap out m51.fits and COPYING, taken from PDL CVS HEAD (Closes: #223793) -- Henning Glawe Sat, 13 Dec 2003 22:25:41 +0100 pdl (1:2.3.2-0.6) unstable; urgency=low * NMU for xlib6g-dev dependency (Closes: #170182) -- Joshua Kwan Sat, 15 Mar 2003 16:55:39 -0800 pdl (1:2.3.2-0.5) unstable; urgency=low * NMU for perl 5.8. Set build-dependency to perl 5.8. * debian/rules: moved prefix selection to installation time. -- Josselin Mouette Wed, 21 Aug 2002 22:39:24 +0200 pdl (1:2.3.2-0.2) unstable; urgency=low * Non-Maintainer Upload * In postinst, specify path to /usr/bin/perl so that users with a conflicting perl in /usr/local/bin do not get a blow-up. (Closes: #141117) * (Note that the above change was made in debian/rules, NOT debian/postinst, because of the very strange way the original maintainer made the debian/postinst be auto-generated..) -- Ben Gertzfield Mon, 8 Apr 2002 18:47:16 +0900 pdl (1:2.3.2-0.1) unstable; urgency=low * Non-Maintainer Upload * Newest version needed to fix gimp-perl build problems (perl segfaults on alpha otherwise). * Use F77CONF=debian/f77conf.pl, signify hppa needed changes in there instead of hacking Lib/Slatec/Makefile.PL . * Include small patch to change $(INST_LIBDIR)/PDL to $(INST_LIBDIR) in Basic/Gen/Makefile.PL (debian/rules has a very long, strange find command that barfs if there are multiple directories named PDL, and this looks like a typo anyway) * debian/rules was writing to file called "substvers", and was missing a $ anyway when writing Perl depends substvars. Commented out, added a call to dh_perl and tightened Build-Depends on debhelper to (>= 3.0.18). * Add call to dh_clean to clean up debhelper-generated files. -- Ben Gertzfield Tue, 2 Apr 2002 22:07:56 +0900 pdl (1:2.2.1-7.1) unstable; urgency=low * Non-Maintainer Upload * Fix to build on hppa, patch in BTS. Closes: #104630 -- Matt Taggart Wed, 5 Dec 2001 19:42:37 -0700 pdl (1:2.2.1-7) unstable; urgency=low * rebuild with dh_gencontrol instead of dpkg-gencontrol, new perl policy seems to need this. * include lintian override for non-pic code in Slatec.so * include debian/all (build/check script) in source -- Raul Miller Sun, 26 Aug 2001 21:44:51 -0400 pdl (1:2.2.1-6) unstable; urgency=low * Introduced a build-depends on libextutils-f77-perl. [Which breaks cross compilation since I've not released that package yet -- waiting on DFSG copyright, but allows building with slatec.] -- Raul Miller Sat, 9 Jun 2001 22:54:30 -0400 pdl (1:2.2.1-5) unstable; urgency=low * fix postinst.base -- postinst was missing set -e -- Raul Miller Fri, 25 May 2001 11:09:44 -0400 pdl (1:2.2.1-4) unstable; urgency=low * Ok, found out how to resolve $Config{version}. -- Raul Miller Fri, 25 May 2001 01:04:12 -0400 pdl (1:2.2.1-3) unstable; urgency=low * changed INSTALLDIRS=perl to INSTALLDIRS=vendor in debian/rules, for the new perl policy, changed Build-Depends to match. (fixes #95423) * made other changes to debian/rules and debian/control as indicated by this new policy. I hope the OPTIMIZE attribute doesn't hose PDL... * FIXME: I've backed out compliance with 3.4.2 of the new perl policy: "Binary modules must specify a dependency on either perl or perl-base with a minimum version of the perl package used to build the module, and must additionally depend on the expansion of perlapi-$Config{version}." This fails to indicate what context to use for that expansion. In my initial tests, this broke the package, and `apt-cache search perlapi` turns up nothing. -- Raul Miller Thu, 24 May 2001 14:01:33 -0400 pdl (1:2.2.1-2) unstable; urgency=low * replaced mesag-dev with xlibmesa-dev in build depends. (fixes #97508) replaced mesag3 with libgl1 in depends. * Rant: [None of this rant is immediately relevant to this version of PDL, except through examining the implications of bug #97508.] This whole "trash the old i/o-library interface" thing strikes me as *really bad*. Interfaces should be treated as sacred, and maintaining backwards compatibility is important for long term system survivability. Basically, what we're saying here is that these interfaces are immature, and people who built code against the earlier (obsolete) libraries acted prematurely. Either that, or we're saying that distributing binary packages for debian is a mistake on the part of anyone outside of debian. * I'm leaving the Build-Depends for libncurses-dev in the control file, even though it's now a virutal package, to see if I get any bug reports filed against pdl because of it (for the record, I'm using version 5.2.20010318-1 of libncurses5-dev to build this instance). * updated debian/rules (added prerm, minor cleanups) -- Raul Miller Mon, 21 May 2001 10:18:55 -0400 pdl (1:2.2.1-1) unstable; urgency=low * renamed directory from PDL-2.2.1 to pdl-2.2.1, and chmod +x debian/rules (required so that dpkg-buildpackage works). * changed Source-Depends: to Build-Depends: in control file, and restored build dependency for libncurses-dev. * restored debian/postinst.base and debian/prerm from debian 2.2 -- Raul Miller Sun, 20 May 2001 22:14:49 -0400 pdl (1:2.2.1-0) unstable; urgency=low * new upstream release -- PDL Porters Tue, 24 Apr 2001 15:01:23 -0400 pdl (1:2.2-2) unstable; urgency=low * delete bogus debian.orig directory -- Raul Miller Wed, 14 Mar 2001 15:15:59 -0500 pdl (1:2.2-1) unstable; urgency=medium * new upstream release * turned off make test because it has problems: 1. requires an active X session (bad for autobuilders), and 2. requires slatec (or linfit fails). [Can't support slatec until ExtUtils::F77 is a debian package] * bumped up urgency because old pdl doesn't support newest perl, and some people consider that serious. -- Raul Miller Mon, 12 Mar 2001 20:51:12 -0500 pdl (1:2.1.1-1) unstable; urgency=low * reintroduced scantree.pl and mkhtmldoc to postinst (fixes problem reported in private email by Dav Clark and Gordon Haverland -- thanks). * note: this version won't purge cleanly, as it creates a couple files a postinst time which aren't removed even at purge time. * got rid of bashisms from debian/rules * translated /usr/doc to /usr/share/doc and /usr/man to /usr/share/man * never released -- ignore epoch -- Raul Miller Mon, 20 Nov 2000 01:17:43 -0500 pdl (2.1.1-0pre1) unstable; urgency=low * new upstream version * this is a pre-release, among other things, I'm waiting for xlib6g-dev to stabilize. Please email me, personally, with any bug reports. This is not an official release. Changes from the 2.1.1 sources on sourceforge for this prerelease: + chmod +x debian/rules + this entry in debian/changelog + editted copy of perldl.conf as debian/.perldl.conf (no -lMesa*) + HOME=`pwd`/debian added to Makefile.PL part of debian/rules -- Raul Miller Sun, 19 Nov 2000 14:46:31 -0500 pdl (2.005-2) frozen; urgency=medium * Argh, forgot to fix t/gauss.t -- this is required for Bug#55268 to really be fixed. -- Raul Miller Tue, 25 Apr 2000 13:45:28 -0400 pdl (2.005-1) frozen; urgency=medium * new bugfix upstream version * two hacks: (1) disable #ifdef in Basic/Math/mconf.h which includes on our linux alpha, (2) disable test which shows that guassian doesn't work properly on our linux alpha. (Fixes Bug#55268) -- Raul Miller Mon, 17 Apr 2000 08:17:18 -0400 pdl (2.003-1) unstable; urgency=low * new upstream version -- Raul Miller Mon, 1 Nov 1999 07:16:55 -0500 pdl (2.002-3) unstable; urgency=low * new maintainer * recreated source package, unpack in pdl-2.002 instead of PDL-2.002 [this oddity in source package accounts for earlier diff problems]. (Fixes #45771). * do "make test" at build time * removed suggests jpeg-progs, I can't find any such package * removed suggests pgperl, there's a well labeled demo that fails and that should be enough of a suggestion for people who would want this non-free support. If there's demand, and if special compilation support turns out to be needed, I supposed I'll have to create a pdl-nonfree... -- Raul Miller Sun, 10 Oct 1999 19:20:09 -0400 pdl (2.002-2) unstable; urgency=low * added depends on libterm-readkey-perl -- John Lapeyre Sun, 8 Aug 1999 14:25:39 -0700 pdl (2.002-1) unstable; urgency=low * New upstream * Build with new perl 5.005 package * fixes #40433 with workaround for error in Bessel functions in libc6 2.1 * Fixes #36402, docs are now made at build time and are purged with dpkg --purge. Also previous cruft from old versions is purged in preinst. * Fixes #38429, typo in Depends -- John Lapeyre Fri, 25 Jun 1999 17:52:33 -0700 pdl (2.001-1) unstable; urgency=low * New upstream * Add r-pdl code (merging r-pdl package) -- John Lapeyre Wed, 21 Apr 1999 14:47:54 -0700 pdl (2.0-2) unstable; urgency=low * link with glibc 2.1.1 * add menu entry -- John Lapeyre Thu, 25 Mar 1999 01:52:12 -0700 pdl (2.0-1) unstable; urgency=low * new upstream version -- John Lapeyre Mon, 25 Jan 1999 16:59:48 -0700 pdl (1.99988-5) unstable frozen; urgency=low * html docs were put in wrong place. -- John Lapeyre Tue, 8 Dec 1998 03:39:42 -0700 pdl (1.99988-4) unstable frozen; urgency=low * Some package (mesa?) change and broke the build Add X11 include path by hand. -- John Lapeyre Fri, 6 Nov 1998 22:03:17 -0700 pdl (1.99988-3) unstable; urgency=low * link against mesag3. -- John Lapeyre Sun, 25 Oct 1998 01:32:34 -0700 pdl (1.99988-2) unstable; urgency=low * Make rules less i386-centric -- John Lapeyre Tue, 6 Oct 1998 11:44:39 -0700 pdl (1.99988-1) unstable; urgency=low * New minor revision -- John Lapeyre Fri, 2 Oct 1998 00:00:03 -0700 pdl (1.99985-1) unstable; urgency=low * New minor revision -- John Lapeyre Fri, 31 Jul 1998 14:24:09 -0700 pdl (1.9906-1) frozen unstable; urgency=low * New minor revision -- John Lapeyre Fri, 1 May 1998 15:29:16 -0700 pdl (1.9905-1) unstable; urgency=low * New minor revision -- John Lapeyre Fri, 24 Apr 1998 16:17:42 -0700 pdl (1.9904-1) unstable; urgency=low * New minor revision -- John Lapeyre Mon, 13 Apr 1998 13:45:34 -0700 pdl (1.9902-2) unstable; urgency=low * suggests mesag2 not mesa2 -- John Lapeyre Mon, 13 Apr 1998 13:45:34 -0700 pdl (1.9902-1) unstable; urgency=low * Upstream minor revision. * Note doc lookup was still broken in 1.9901 * Changed architecture from i386 to any * Fixed doc lookup, I hope -- John Lapeyre Mon, 23 Mar 1998 15:31:34 -0700 pdl (1.9901-2) unstable; urgency=low * Fixed online doc lookup. -- John Lapeyre Sat, 14 Mar 1998 18:21:28 -0700 pdl (1.9901-1) unstable; urgency=low * New upstream minor version including ... * New Free license. * Bug fixes, doc improvements -- John Lapeyre Mon, 9 Mar 1998 12:53:32 -0700 pdl (1.9900-1) non-free; urgency=low * New upstream release -- John Lapeyre Fri, 27 Feb 1998 16:42:27 -0700 pdl (1.95.07-3) non-free; urgency=low * removed perllocal.pod; only for local build -- John Lapeyre Fri, 23 Jan 1998 22:04:49 -0700 pdl (1.95.07-2) non-free; urgency=low * existed a debstd bug; upgraded debstd and repackaged. -- John Lapeyre Fri, 23 Jan 1998 21:09:05 -0700 pdl (1.95.07-1) non-free; urgency=low * Initial Release. -- John Lapeyre Fri, 16 Jan 1998 19:32:22 -0700 PDL-2.018/debian/compat0000644060175006010010000000000212562522365013024 0ustar chmNone9 PDL-2.018/debian/control0000644060175006010010000000354713036512175013235 0ustar chmNoneSource: pdl Section: math Priority: optional Maintainer: Henning Glawe Standards-Version: 3.9.3 Build-Depends: gfortran, dpkg-dev (>= 1.16.1~), x11proto-core-dev, libncurses-dev, perl (>= 5.8.0-3), debhelper (>= 9), libinline-perl (>= 0.43), libgsl0-dev, fftw-dev, libxext-dev, libhdf4-alt-dev | libhdf4g-dev, libproj-dev | proj, proj-bin | proj, libgd2-xpm-dev, libastro-fits-header-perl, sharutils, libopengl-perl (>= 0.65), libxi-dev, libxmu-dev, freeglut3-dev, libextutils-f77-perl, netpbm, libdevel-repl-perl (>=1.003011), libtest-warn-perl Homepage: http://pdl.perl.org/ Package: pdl Architecture: any Depends: ${perl:Depends}, libterm-readkey-perl, ${shlibs:Depends}, libopengl-perl (>=0.62), ${misc:Depends} Recommends: libterm-readline-gnu-perl | libterm-readline-perl-perl Suggests: libpgplot-perl, netpbm | imagemagick, libastro-fits-header-perl, libinline-perl, doc-base, libextutils-f77-perl, proj-bin | proj, libdevel-repl-perl (>=1.003011) Conflicts: r-pdl Replaces: r-pdl Provides: ${pdlapi:Provides} Description: perl data language: Perl extensions for numerics PDL gives standard perl the ability to COMPACTLY store and SPEEDILY manipulate the large N-dimensional data arrays which are the bread and butter of scientific computing. The idea is to turn perl in to a free, array-oriented, numerical language in the same sense as commercial packages like IDL and MatLab. One can write simple perl expressions to manipulate entire numerical arrays all at once. For example, using PDL the perl variable $a can hold a 1024x1024 floating point image, it only takes 4Mb of memory to store it and expressions like $a=sqrt($a)+2 would manipulate the whole image in a few seconds. . A simple interactive shell (perldl) is provided for command line use together with a module (PDL) for use in perl scripts. PDL-2.018/debian/copyright0000644060175006010010000000761312562522365013570 0ustar chmNoneThis package was debianized by John Lapeyre lapeyre@physics.arizona.edu on Fri, 16 Jan 1998 02:56:53 -0700. Pdl source and information is available at http://pdl.perl.org/ Following is the PDL copyright: Copyright (c) 1997-2004 by the contributors named in the individual files. All rights reserved. This distribution is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The demonstration image m51.fits is derived from the Hubble Heritage project archival images; its creation was funded in part by a grant from NASA. The image is in the public domain. Inline documentation in any module files (pod format) and documentation files (.pod files) in this distribution are additionally protected by the following statement: Permission is granted for verbatim copying (and formatting) of this documentation as part of the PDL distribution. Permission is granted to freely distribute verbatim copies of this documentation only if the following conditions are met: 1. that the copyright notice remains intact 2. the original authors' names are clearly displayed, 3. that any changes made to the documentation outside the official PDL distribution (as released by the current release manager) are clearly marked as such and 4. That this copyright notice is distributed with the copied version so that it may be easily found. All the files in the distribution should have a copyright notice according to the following template: Copyright (C) 199X Author1, Author2. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. In addition, the following disclaimers apply: THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. On Debian GNU/Linux systems, the complete text of the GNU General Public License can be found in `/usr/share/common-licenses/GPL-2' and the Artistic Licence in `/usr/share/common-licenses/Artistic'. PDL-2.018/debian/dh_pdl0000755060175006010010000000532212562522365013010 0ustar chmNone#!/usr/bin/perl -w =head1 NAME dh_pdl - calculates pdl dependencies =cut use strict; use Config; use File::Find; use Debian::Debhelper::Dh_Lib; use PDL::Config::Debian; =head1 SYNOPSIS B [S>] [B<-d>] [S>] =head1 DESCRIPTION dh_pdl is a debhelper program that is responsible for generating the ${pdl:Depends} substitutions and adding them to substvars files. The program will look at perl scripts and modules in your package, and will use this information to generate a dependency on pdl or pdlapi. The dependency will be substituted into your package's control file wherever you place the token "${pdl:Depends}". =head1 OPTIONS =over 4 =item B<-V> By default, scripts and architecture independent modules don't depend on any specific version of pdl. The -V option causes the current version of the pdl package to be specified. =item I If your package installs perl modules in non-standard directories, you can make dh_perl check those directories by passing their names on the command line. It will only check the vendorlib and vendorarch directories by default. =back =head1 CONFORMS TO Debian policy, version 3.8.3 =cut init(); my $vendorlib = substr $Config{vendorlib}, 1; my $vendorarch = substr $Config{vendorarch}, 1; # Cleaning the paths given on the command line foreach (@ARGV) { s#/$##; s#^/##; } my $pdl = 'pdl'; my $version; # dependency types use constant PROGRAM => 1; use constant PM_MODULE => 2; use constant XS_MODULE => 4; foreach my $package (@{$dh{DOPACKAGES}}) { my $tmp=tmpdir($package); # Check also for alternate locations given on the command line my @dirs = grep -d, map "$tmp/$_", $vendorlib, $vendorarch, @ARGV; # Look for perl modules and check where they are installed my $deps = 0; find sub { return unless -f; $deps |= PM_MODULE if /\.pm$/; $deps |= XS_MODULE if /\.so$/; }, @dirs if @dirs; # find scripts find sub { return unless -f and (-x or /\.pl$/); return if $File::Find::dir=~/\/usr\/share\/doc\//; local *F; return unless open F, $_; if (read F, local $_, 32 and m%^#!\s*(/usr/bin/perl|/usr/bin/env\s+perl)\s%) { $deps |= PROGRAM; } close F; }, $tmp; if ($deps) { my $version=""; if ($deps & XS_MODULE or $dh{V_FLAG_SET}) { ($version) = `dpkg -s $pdl` =~ /^Version:\s*(\S+)/m unless $version; $version = ">= $version"; } addsubstvar($package, "pdl:Depends", $pdl, $version); # add pdlapi- for XS modules addsubstvar($package, "pdl:Depends", "pdlapi-$PDL::Config::Debian::pdl_core_version") if $deps & XS_MODULE; } } =head1 SEE ALSO L =head1 AUTHOR Henning Glawe Based on dh_perl by Brendan O'Dea =cut PDL-2.018/debian/f77conf.pl0000644060175006010010000000320512562522365013434 0ustar chmNonepackage F77Conf; # a minimal hardcoded config designed for debian so that we don't need # ExtUtils::F77 when building PDL print "Config ",__PACKAGE__->config(),"\n"; print "Compiler ",__PACKAGE__->compiler(),"\n"; print "Runtime ",__PACKAGE__->runtime(),"\n"; print "Trail_ ",__PACKAGE__->trail_() ? "yes" : "no", "\n"; print "Cflags ",__PACKAGE__->cflags(),"\n"; sub config { return 'debian'; } sub runtime { my $libpath = `gfortran -print-libgcc-file-name`; $libpath =~ s/libgcc[.]a$//; chomp $libpath; my $ldflags = ''; $ldflags .= $ENV{LDFLAGS} if (defined $ENV{LDFLAGS}); $ldflags .= " -L$libpath -lgcc -lgfortran"; return($ldflags); } sub trail_ { return 1; } sub compiler { return 'gfortran'; } sub cflags { my $fflags = ''; $fflags = $ENV{FFLAGS} if (defined $ENV{FFLAGS}); $fflags.=' -fPIC'; return($fflags); } sub testcompiler { my ($this) = @_; my $file = "/tmp/testf77$$"; my $ret; open(OUT,">$file.f"); print OUT " print *, 'Hello World'\n"; print OUT " end\n"; close(OUT); print "Compiling the test Fortran program...\n"; my ($compiler,$cflags) = ($this->compiler,$this->cflags); system "$compiler $cflags $file.f -o ${file}_exe"; print "Executing the test program...\n"; if (`${file}_exe` ne " Hello World\n") { print "Test of Fortran Compiler FAILED. \n"; print "Do not know how to compile Fortran on your system\n"; $ret=0; } else{ print "Congratulations you seem to have a working f77!\n"; $ret=1; } unlink("${file}_exe"); unlink("$file.f"); unlink("$file.o") if -e "$file.o"; return $ret; } 1; PDL-2.018/debian/fix_man_encoding.sed0000644060175006010010000000006212562522365015610 0ustar chmNones/Grégory/Gr\\['e]gory/g s/Halldór/Halld\\['o]r/g PDL-2.018/debian/fix_man_name.sed0000644060175006010010000000017212562522365014744 0ustar chmNone# HG: remove *roff special syntax from manpage's NAME section /.SH \"NAME\"/,+1 { s/\\f(CW\\\*(C`/"/g s/\\\*(C'\\fR/"/g } PDL-2.018/debian/patches/0000755060175006010010000000000013110402044013232 5ustar chmNonePDL-2.018/debian/patches/series0000644060175006010010000000000112562522365014461 0ustar chmNone PDL-2.018/debian/pdl.dirs0000644060175006010010000000006012562522365013264 0ustar chmNoneusr/bin usr/share/lintian/overrides var/lib/pdl PDL-2.018/debian/pdl.doc-base0000644060175006010010000000074312562522365014010 0ustar chmNoneDocument: pdl Title: PDL online manual Author: Various Abstract: Perl Data Language is an extension to perl for numerics. It allows high-speed manipulation of multidimensional data arrays and includes bindings to a lot of external libraries for data processing and representation (plotting). This manual includes both introductory documents and a command reference. Section: Science/Mathematics Format: HTML Index: /var/lib/pdl/html/Index.html Files: /var/lib/pdl/html/*.html PDL-2.018/debian/pdl.docs0000644060175006010010000000005612562522365013260 0ustar chmNoneBUGS Known_problems README TODO Release_Notes PDL-2.018/debian/pdl.install0000644060175006010010000000014512562522365013775 0ustar chmNoneDoc/scantree.pl usr/lib/perl5/PDL/Doc/ Doc/mkhtmldoc.pl usr/lib/perl5/PDL/Doc/ debian/dh_pdl usr/bin PDL-2.018/debian/pdl.links0000644060175006010010000000031612562522365013447 0ustar chmNone/var/lib/pdl/Index.pod /usr/lib/perl5/PDL/Index.pod /var/lib/pdl/pdldoc.db /usr/lib/perl5/PDL/pdldoc.db /var/lib/pdl/html /usr/share/doc/pdl/html /usr/share/man/man3/PDL.3pm.gz /usr/share/man/man1/pdl.1.gz PDL-2.018/debian/pdl.lintian-overrides0000644060175006010010000000120512562522365015763 0ustar chmNone# HG: the html doc is generated in the postinst maintainer script, so lintian # just does not see it pdl: doc-base-file-references-missing-file pdl:12 /var/lib/pdl/html/Index.html pdl: doc-base-file-references-missing-file pdl:13 /var/lib/pdl/html/*.html # there is one long code line in the manpage, which cannot be broken pdl: manpage-has-errors-from-man usr/share/man/man3/PDL::FFT.3pm.gz 215: warning [p 2, 2.0i]: can't break line # these two images neeed to be in usr/lib pdl: image-file-in-usr-lib usr/lib/perl5/PDL/Transform/Cartography/earth_day.jpg pdl: image-file-in-usr-lib usr/lib/perl5/PDL/Transform/Cartography/earth_night.jpg PDL-2.018/debian/pdl.manpages0000644060175006010010000000002012562522365014112 0ustar chmNonedebian/dh_pdl.1 PDL-2.018/debian/pdl.menu0000644060175006010010000000017012562522365013271 0ustar chmNone?package(pdl):\ needs="text"\ section="Applications/Science/Mathematics"\ title="PerlDl"\ command="/usr/bin/perldl" PDL-2.018/debian/pdl.postinst0000644060175006010010000000221512562522365014212 0ustar chmNone#! /bin/sh # postinst script for pdl # # see: dh_installdeb(1) set -e # summary of how this script can be called: # * `configure' # * `abort-upgrade' # * `abort-remove' `in-favour' # # * `abort-deconfigure' `in-favour' # `removing' # # for details, see http://www.debian.org/doc/debian-policy/ or # the debian-policy package # case "$1" in configure|triggered) perl /usr/lib/perl5/PDL/Doc/scantree.pl /usr/lib/perl5/ /var/lib/pdl/pdldoc.db /var/lib/pdl/Index.pod >/dev/null 2>&1 perl /usr/lib/perl5/PDL/Doc/mkhtmldoc.pl -s "PDL/" /usr/lib/perl5/PDL /var/lib/pdl/html >/dev/null 2>&1 ;; abort-upgrade|abort-remove|abort-deconfigure) ;; *) echo "postinst called with unknown argument \`$1'" >&2 exit 1 ;; esac # dh_installdeb will replace this with shell code automatically # generated by other debhelper scripts. #DEBHELPER# exit 0 PDL-2.018/debian/pdl.prerm0000644060175006010010000000170212562522365013454 0ustar chmNone#! /bin/sh # prerm script for pdl # # see: dh_installdeb(1) set -e # summary of how this script can be called: # * `remove' # * `upgrade' # * `failed-upgrade' # * `remove' `in-favour' # * `deconfigure' `in-favour' # `removing' # # for details, see http://www.debian.org/doc/debian-policy/ or # the debian-policy package # dh_installdeb will replace this with shell code automatically # generated by other debhelper scripts. #DEBHELPER# case "$1" in remove|upgrade|deconfigure) rm -rf /var/lib/pdl/html rm -f /var/lib/pdl/pdldoc.db /var/lib/pdl/Index.pod ;; failed-upgrade) ;; *) echo "prerm called with unknown argument \`$1'" >&2 exit 1 ;; esac exit 0 PDL-2.018/debian/pdl.remove0000644060175006010010000000026512562522365013627 0ustar chmNoneusr/share/man/man3/PDL::BAD_demo.3pm usr/share/man/man3/PDL::BAD2_demo.3pm usr/share/man/man3/PDL::Config.3pm usr/share/man/man3/PDL::Doc::Config.3pm usr/share/man/man3/PDL::PP.3pm PDL-2.018/debian/pdl.triggers0000644060175006010010000000003412562522365014152 0ustar chmNoneinterest /usr/lib/perl5/PDL PDL-2.018/debian/perldl.conf0000644060175006010010000001710713036512175013760 0ustar chmNone#!/usr/bin/perl # -*-perl-*- # PDL Configuration options # You can edit this here or say 'perl Makefile.PL PDLCONF=file' # or use ~/.perldl.conf # Note in general "0" means False, "1" means "True" and "undef" # means "Try if possible (e.g. because the library is found)" # # You can also use a string that matches /^y/i to mean True or # one that matches /^n/i to mean False. It will be automatically # converted to 1 or 0 before being loaded into the Config.pm module. # %PDL_CONFIG = ( # # Version of the perldl.conf file. This should be incremented # in the units for any PDL visible changes to the file (i.e., # the non-comment ones). Other changes may be indicated by # the fractional part but are more for informational purposes. # PDL_CONFIG_VERSION => 0.005, PDL_BUILD_VERSION => undef, # filled in by Makefile.PL PDL_BUILD_DIR => undef, # filled in by Makefile.PL # # Do we generate HTML documentation? This is normally a good idea, # as it's nice to browse -- but many folks don't use it, preferring # the man page and/or help versions of the documentation. Undef or 1 # causes the HTML documentation to be built; 0 turns it off. # HTML_DOCS => 1, # Location of directory for temporary files created during the # build/test process. See the getpdl_config() routine in Makefile.PL # for the choice made if TEMPDIR is left as 'undef': it boils down to # the first value that is defined from # $TEMP, $TMP, or "/tmp" [a TEMP directory for MSWin users] # TEMPDIR => undef, # Decides if the output of attempts to link various function # during 'perl Makefile.PL' will be hidden when building PDL # should only be set to 0 for debugging purposes # see also L HIDE_TRYLINK => 1, # you can set machine specific optimizations here the settings will be # passed to the toplevel Makefile.PL which *should* pass it to any # recursively invoked ones. Add -O0 to turn off compiler # optimization, and -g to produce debugging information that GDB and # other debuggers can use. OPTIMIZE => undef, # '-O0 -g', # Use posix threading to make use of multiprocessor machines # undef -> try if possible # 0 -> don't use # true -> force use WITH_POSIX_THREADS => undef, POSIX_THREADS_INC => undef, # '-I/usr/pthread/include' POSIX_THREADS_LIBS => undef, # '-L/usr/pthread -lpthreadGC2' MALLOCDBG => undef, # { # include => '-I/home/csoelle/tmp', # libs => '-L/home/csoelle/tmp -lmymalloc', # define => << 'EOD', ##define malloc(n) dbgmalloc(n,__FILE__,__LINE__) ##define free(p) dbgfree(p) #EOD # include => '', # libs => '-lefence', # define => '', # }, # Do we want routines to handle bad values? # saying no will make PDL a bit faster # true -> yes # false -> no, undef -> no # # WITH_BADVAL => 0, WITH_BADVAL => 1, # if WITH_BADVAL == 1, do we use NaN/Inf to represent badvalues # (not convinced setting this results in faster code) # BADVAL_USENAN => 0, # BADVAL_USENAN => 1, # The original BADVAL implementation assigned bad-values on pdl-types, # not per pdl, setting the following to one will make it a pdl-variable # THIS IS AN EXPERIMENTAL FEATURE -- BEWARE... BADVAL_PER_PDL => 0, # BADVAL_PER_PDL => 1, # Try to build Graphics/TriD # # true -> force build of PDL::Graphics:::TriD # false -> skip build of PDL::Graphics:::TriD # undef -> let PDL build decide based on dependencies present # WITH_3D => undef, # Build Graphics/TriD using Perl OpenGL # # true -> use new Perl OpenGL bindings # false -> use legacy, deprecated X11 only bindings # undef -> let PDL build decide (check if Perl OpenGL is present) # USE_POGL => undef, # USE_POGL => 0, # POGL_VERSION => 0.65, # minimum compatible OpenGL version # POGL_WINDOW_TYPE => 'x11', # use X11+GLX for windows POGL_WINDOW_TYPE => 'glut', # use GLUT for windows # Whether or not to build the PDL::Slatec module # false -> don't use # true -> force use WITH_SLATEC => undef, # Leave it up to PDL to decide # Whether or not to build the PDL::Minuit module # false -> don't use # true -> force use WITH_MINUIT => undef, # Leave it up to PDL to decide # If MINUIT_LIB is undef a standalone version of Minuit will be compiled # and PDL::Minuit will link to this library (fortran code can be found # at Lib/Minuit/minuitlib) # If you want to try to link directly to the Minuit present # in the CERN library libpacklib.a, include the full path to the library # here, e.g., MINUIT_LIB => '/usr/local/lib/libpacklib.a', MINUIT_LIB => undef, # Whether or not to build the PDL::GSL module # false -> don't use # true -> force use WITH_GSL => undef, # Leave it up to PDL to decide # Link flags for the GSL libs, e.g. '-L/usr/local/lib -lgsl -lm' GSL_LIBS => undef, # use gsl-config # Location to find GSL includes: GSL_INC => undef, # use gsl-config # Whether or not to build the PDL::FFTW module # false -> don't use # true -> force use WITH_FFTW => undef, # Leave it up to PDL to decide # Location to search for the FFTW libs FFTW_LIBS => [ '/lib','/usr/lib','/usr/local/lib'], # Location to find FFTW includes: FFTW_INC => ['/usr/include/','/usr/local/include'], # FFTW Numeric Precision Type to link in: (double or single precision) FFTW_TYPE => 'double', # Whether or not to build the PDL::IO::HDF module # false -> don't use # true -> force use WITH_HDF => undef, # Leave it up to PDL to decide HDF_LIBS => undef, HDF_INC => ['/usr/include/hdf'], # Whether or not to build the PDL::IO::GD module # false -> don't use # true -> force use WITH_GD => undef, # Leave it up to PDL to decide GD_LIBS => undef, GD_INC => undef, # Whether or not to build the PDL::GIS::Proj module # false -> don't use # true -> force use # WITH_PROJ => undef, # Leave it up to PDL to decide PROJ_LIBS => undef, PROJ_INC => undef, # N.B. These are array ref values and *not* strings # # PROJ_LIBS => [ 'C:/_32/msys/1.0/local/lib'], # PROJ_INC => [ 'C:/_32/msys/1.0/local/include'], # Do we build PDL::IO::Browser? # default -> do not build # WITH_IO_BROWSER => 0, # Quiet Astro::FITS::Header warnings for PDL build process by default # Eventually would be better to set undef by default, and have the # Makefile.PL change the value after it has been found missing once. # TBD after PDL 2.4.3 release... # FITS_LEGACY => 1, # Whether or not to enable the new Devel::REPL based PDL shell # Given the large numbers of dependencies for Devel::REPL, we # don't want to have that as a required dependency for PDL. # Still, if it is there already, we could use it... # # false -> don't install pdl2 support # true -> force pdl2 install (default) WITH_DEVEL_REPL => 1, # Set this for official CPAN releases of PDL since these # tests will always fail until they are fixed. It can also # be set from the value of the environment variable of the # same name. # SKIP_KNOWN_PROBLEMS => 0, # # Set this to make the pdldoc command ignore PDL::AutoLoader # routines (*.pdl files in your @PDLLIB path). While most # users will want the new behavior, the performance impact # could be noticable. Setting this to 1 will turn off the # new feature. # PDLDOC_IGNORE_AUTOLOADER => 0, ); 1; # Return OK status on 'require' PDL-2.018/debian/README.Debian0000644060175006010010000000063513036512175013666 0ustar chmNonepdl for Debian -------------- pdl or perlDL pdl is the perl data language. Try "man PDL", or , for more man pages, "man -k PDL". Html documents are found in /usr/share/doc/pdl/html/. More information can be found at: http://pdl.perl.org/ -- John Lapeyre , Fri, 16 Jan 1998 02:56:53 -0700 -- Henning Glawe , Sun, 9 Jan 2005 15:34:57 +0100 PDL-2.018/debian/rules0000755060175006010010000000666012562522365012716 0ustar chmNone#!/usr/bin/make -f # -*- makefile -*- # PDL debian/rules that uses debhelper. # much of it is based on the original debmake-based one. # This file was originally written by Joey Hess and Craig Small. # As a special exception, when this file is copied by dh-make into a # dh-make output file, you may use that output file without restriction. # This special exception was added by Craig Small in version 0.37 of dh-make. # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 unexport DISPLAY ifneq (,$(findstring noopt,$(DEB_BUILD_OPTIONS))) export DEB_CFLAGS_MAINT_APPEND:=-Wall else export DEB_CFLAGS_MAINT_APPEND:=-Wall -ffunction-sections endif export DEB_LDFLAGS_MAINT_APPEND:=-Wl,--as-needed DPKG_EXPORT_BUILDFLAGS = 1 include /usr/share/dpkg/buildflags.mk subst_pdlapi = -Vpdlapi:Provides="`perl -Mblib -MPDL::Config::Debian -e 'print \"pdlapi-$$PDL::Config::Debian::pdl_core_version\n\"'`" configure: configure-stamp configure-stamp: dh_testdir # Add here commands to configure the package dh_auto_configure -- F77CONF=debian/f77conf.pl PDLCONF=debian/perldl.conf touch configure-stamp build-arch: build build-indep: build build: build-stamp build-stamp: configure-stamp dh_testdir # Add here commands to compile the package. $(MAKE) LD_RUN_PATH="" mkdir -p blib/lib/PDL/Config perl -Mblib debian/write_config_debian.pl > blib/lib/PDL/Config/Debian.pm pod2man debian/dh_pdl > debian/dh_pdl.1 touch build-stamp test: test-stamp test-stamp: build-stamp dh_testdir @echo "BEGIN test normal" -$(MAKE) TEST_VERBOSE=0 LC_ALL=C test | perl debian/filter-test.pl @echo "END test normal" @echo "BEGIN test verbose" -$(MAKE) TEST_VERBOSE=1 LC_ALL=C test | perl debian/filter-test.pl @echo "END test verbose" touch test-stamp clean: dh_testdir dh_testroot rm -f build-stamp configure-stamp test-stamp dh_clean # Add here commands to clean up after the build process. [ ! -f Makefile ] || $(MAKE) distclean rm -f t/callext.o t/callext.so Graphics/TriD/OpenGL/tmp*.h-out \ Perldl2/pdl2.pod debian/dh_pdl.1 install: build test dh_testdir dh_testroot dh_prep dh_installdirs # Add here commands to install the package into debian/pdl. $(MAKE) install DESTDIR=$(CURDIR)/debian/pdl cd debian/pdl/usr/share/man/man3 ; mv PDL\:\:Reduce.3pm old.3pm ; sed -f $(CURDIR)/debian/fix_man_name.sed old.3pm > PDL\:\:Reduce.3pm ; rm old.3pm cd debian/pdl/usr/share/man/man3 ; mv PDL\:\:Func.3pm old.3pm ; sed -f $(CURDIR)/debian/fix_man_encoding.sed old.3pm > PDL\:\:Func.3pm ; rm old.3pm cd debian/pdl/usr/share/man/man3 ; mv PDL\:\:Complex.3pm old.3pm ; sed -f $(CURDIR)/debian/fix_man_encoding.sed old.3pm > PDL\:\:Complex.3pm ; rm old.3pm cd debian/pdl; while read f ; do rm -f "$$f" ; done < ../pdl.remove # Build architecture-independent files here. binary-indep: build install # We have nothing to do by default. # Build architecture-dependent files here. binary-arch: build install dh_testdir dh_testroot dh_installchangelogs dh_installdocs dh_installexamples dh_install dh_installmenu dh_lintian # dh_installdebconf # dh_installlogrotate # dh_installemacsen # dh_installpam # dh_installmime # dh_installinit # dh_installcron # dh_installinfo dh_installman dh_link dh_strip dh_compress dh_fixperms dh_perl # dh_python # dh_makeshlibs dh_installdeb dh_shlibdeps dh_gencontrol -- $(subst_pdlapi) dh_md5sums dh_builddeb binary: binary-indep binary-arch .PHONY: build clean binary-indep binary-arch binary install configure PDL-2.018/debian/source/0000755060175006010010000000000013110402044013103 5ustar chmNonePDL-2.018/debian/source/format0000644060175006010010000000001412562522365014334 0ustar chmNone3.0 (quilt) PDL-2.018/debian/write_config_debian.pl0000755060175006010010000000051712562522365016152 0ustar chmNone#!/usr/bin/perl use strict; use warnings; use PDL; use Inline qw{Pdlpp}; my $v = pdl(1)->pdl_core_version()->at(0); print <<"EOPM"; package PDL::Config::Debian; our \$pdl_core_version = $v; 1; EOPM __DATA__ __Pdlpp__ pp_def('pdl_core_version', Pars => 'dummy(); int [o] pcv();', Code => '$pcv() = PDL_CORE_VERSION;'); pp_done; PDL-2.018/Demos/0000755060175006010010000000000013110402046011432 5ustar chmNonePDL-2.018/Demos/BAD2_demo.pm.PL0000644060175006010010000000674312562522364014010 0ustar chmNone# # Create BAD2_demo.pm # - requires both bad-value support and PGPLOT # use strict; use Config; use File::Basename qw(&basename &dirname); use blib; # check for bad value support use lib '../Basic/Core'; # so Config.pm is found during build use PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; if ( $bvalflag ) { print "Extracting $file (WITH bad value support)\n"; } else { print "Extracting $file (NO bad value support)\n"; } chmod 0644, $file; print OUT <<'!NO!SUBS!'; # # Created by BAD2_demo.pm.PL # ** DO NOT EDIT THIS FILE ** # package PDL::Demos::BAD2_demo; use PDL; use PDL::IO::Misc; use PDL::Graphics::PGPLOT; use File::Spec; PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { !NO!SUBS! if ( ! $bvalflag ) { print OUT <<'!NO!SUBS!'; comment q| Your version of PDL has been compiled without support for bad values, hence this demo cannot do anything. |; !NO!SUBS! } else { print OUT <<'!NO!SUBS!'; $ENV{PGPLOT_XW_WIDTH}=0.6; $ENV{PGPLOT_DEV}=$^O =~ /MSWin32/ ? '/GW' : "/XSERVE"; # try and find m51.fits $d = File::Spec->catdir( "PDL", "Demos" ); $m51path = undef; foreach my $path ( @INC ) { my $check = File::Spec->catdir( $path, $d ); if ( -d $check ) { $m51path = $check; last; } } barf "Unable to find directory ${m51path} within the perl libraries.\n" unless defined $m51path; comment q| This demo is just a bit of eye-candy to show bad values in action, and requires PGPLOT support in PDL. It makes use of the image of M51 kindly provided by the Hubble Heritage group at the Space Telescope Science Institute. It also serves to demonstrate that you often don't need to change your code to handle bad values, as the routines may 'do it' for you. |; act q| # read in the image ($m51path has been set up by this demo to # contain the location of the file) $m51 = rfits "$m51path/m51.fits"; # display it $just = { JUSTIFY => 1 }; imag $m51, $just; # These are used to create the next image ( $nx, $ny ) = $m51->dims; $centre = [ $nx/2, $ny/2 ]; |; act q| # now, let's mask out the central 40 pixels and display it $masked = $m51->setbadif( $m51->rvals({CENTRE=>$centre}) < 40 ); # since imag auto-scales the output, the bad values are not displayed imag $masked, $just; # compare the statistics of the images # (as $PDL::verbose = 1, stats prints out the answers itself) print "Original:\n"; $m51->stats; print "Masked:\n"; $masked->stats; |; act q| # let's filter it a little bit use PDL::Image2D; $nb = 15; $filtered = med2d $masked, ones($nb,$nb), { Boundary => 'Truncate' }; # this is a model of the diffuse component of M51 imag $filtered, $just; |; act q| # unsharp masking, to bring out the small-scale detail $unsharp = $masked - $filtered; imag $unsharp, $just; |; act q| # add on some contours showing the large scale structure of the galaxy imag $unsharp, $just; hold; cont $filtered; rel; |; !NO!SUBS! } # if: $bvalflag print OUT <<'!NO!SUBS!'; } 1; !NO!SUBS! # end PDL-2.018/Demos/BAD_demo.pm.PL0000644060175006010010000001372612562522364013725 0ustar chmNone# # Create BAD_demo.pm # - needed since we allow bad pixel handling to be switched off # use strict; use Config; use File::Basename qw(&basename &dirname); use blib; # check for bad value support use lib '../Basic/Core'; # so Config.pm is found during build use PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; if ( $bvalflag ) { print "Extracting $file (WITH bad value support)\n"; } else { print "Extracting $file (NO bad value support)\n"; } chmod 0644, $file; print OUT <<'!NO!SUBS!'; # # Created by BAD_demo.pm.PL # ** DO NOT EDIT THIS FILE ** # package PDL::Demos::BAD_demo; use PDL; PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { !NO!SUBS! if ( ! $bvalflag ) { print OUT <<'!NO!SUBS!'; comment q| Your version of PDL has been compiled without support for bad values, hence this demo doesn't do anything. |; !NO!SUBS! #' } else { print OUT <<'!NO!SUBS!'; comment q| Welcome to this tour of the bad value support in PDL Each piddle contains a flag - accessible via the badflag() method - which indicates whether: the piddle contains no bad values (flag equals 0) the piddle *MAY* contain bad values (flag equals 1) If the flag is set, then the routines (well, those that have been converted) will process these bad values correctly, otherwise they are ignored. The code has been written so as to provide as little overhead as possible; therefore there should be almost no difference in the time it takes to process piddles which do not have their bad flag set. |; act q| # There are 2 ways to see whether bad-value support has been # compiled into your perldl or pdl2 shell: print("You can use bad values.\n") if $PDL::Bad::Status; # or use PDL::Config; print("You can stil use bad values.\n") if $PDL::Config{WITH_BADVAL}; # note that PDL::Bad is included by default when you use # 'use PDL', 'use PDL::Lite', or 'use PDL::LiteF' |; act q| # create a piddle $a = byte(1,2,3); print( "Bad flag (a) == ", $a->badflag(), "\n" ); # set bad flag, even though all the data is good $a->badflag(1); print( "Bad flag (a) == ", $a->badflag(), "\n" ); # note the bad flag is infectious $b = 2 * $a; print( "Bad flag (b) == ", $b->badflag(), "\n\n" ); |; act q| # the badflag is also included in the state info of # piddle # $c = pdl(2,3); # just a piddle without the badflag set print " Type Dimension State Mem\n"; print "-------------------------------------------------\n"; print "a ", $a->info("%-6T %-15D %-5S %12M"), "\n"; print "b ", $b->info("%-6T %-15D %-5S %12M"), "\n"; print "c ", $c->info("%-6T %-15D %-5S %12M"), "\n\n"; |; act q| print "No bad values: $a\n"; # set the middle value bad $a->setbadat(1); # now print out print "Some bad values: $a\n"; print "b contains: $b\n"; $c = $a + $b; print "so a + b = $c\n\n"; |; act q| # The module PDL::Bad contains a number of routines designed # to make using bad values easy. print "a contains ", $a->nbad, " bad elements.\n"; print "The bad value for type #",$a->get_datatype," is ",$a->badvalue,"\n"; print "It is easy to find whether a value is good: ", isgood($a), "\n\n"; print "or to remove the bad values\n"; $a->inplace->setbadtoval(23); print "a = $a and \$a->badflag == ", $a->badflag, "\n\n"; |; act q| print "We can even label certain values as bad!\n"; $a = sequence(3,3); $a = $a->setbadif( $a % 2 ); # unfortunately can not be done inplace print $a; |; act q| # the issue of how to cope with dataflow is not fully resolved. At # present, if you change the badflag of a piddle, all its children # are also changed: $a = sequence( byte, 2, 3 ); $a = $a->setbadif( $a == 3 ); $b = $a->slice("(1),:"); print "b = $b\tbadflag = ", $b->badflag, "\n"; $a->inplace->setbadtoval(3); print "b = $b\tbadflag = ", $b->badflag, "\n\n"; |; act q| # Note that "boolean" operators return a bad value if either of the # operands are bad: one way around this is to replace all bad values # by 0 or 1. $a = sequence(3,3); $a = $a->setbadif( $a % 2 ); print $a > 5; print setbadtoval($a > 5,0); # set all bad values to false |; act q| # One area that is likely to cause confusion is the return value from # comparison operators (e.g. all and any) when ALL elements are bad. # Currently, the bad value is returned; however most code will not # be aware of this and just see it as a true or false value (depending # on the numerical value used to store bad values). # There is also the fact that the bad value need not relate to the # type of the input piddle (due to internal conversion to an 'int +'). $a = ones(3); $a = $a->setbadif( $a == 1 ); print "Any returns: ", any( $a > 2 ), "\n"; print "which is the bad value of 'long' (", long->badvalue, ").\n"; print "Whereas the bad value for \$a is: ", $a->badvalue, "\n"; |; comment q| Many of the 'core' routines have been converted to handle bad values. However, some (including most of the additional modules) have not, either because it does not make sense or its too much work to do! To find out the status of a particular routine, use the 'badinfo' command in perldl or pdl2 shell (this information is also included when you do 'help'), or the '-b' switch of pdldoc. |; !NO!SUBS! } # if: $bvalflag print OUT <<'!NO!SUBS!'; } 1; !NO!SUBS! # end PDL-2.018/Demos/Cartography_demo.pm0000644060175006010010000001341613036512174015277 0ustar chmNone# package PDL::Demos::Cartography_demo; use PDL; use PDL::Graphics::PGPLOT::Window; use PDL::Transform::Cartography; use File::Spec; PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { local($PDL::debug) = 0; local($PDL::verbose) = 0; ##$ENV{PGPLOT_XW_WIDTH}=0.6; $ENV{PGPLOT_DEV} = $^O =~ /MSWin32/ ? '/GW' : defined($ENV{PGPLOT_DEV}) ? $ENV{PGPLOT_DEV} : "/XWIN"; unless( PDL->rpiccan('JPEG') ) { comment q| This demo illustrates the PDL::Transform::Cartography module. It requires PGPLOT and also the ability to read/write JPEG images. You don't seem to have that ability at the moment -- this is likely because you do not have NetPBM installed. See the man page for PDL::IO::Pic. I'll continue with the demo anyway, but it will likely crash on the earth_image('day') call on the next screen. | } comment q| This demo illustrates the PDL::Transform::Cartography module. It also requires PGPLOT support: you must have PGPLOT installed to run it. PDL::Transform::Cartography includes a global earth vector coastline map and night and day world image maps, as well as the infrastructure for transforming them to different coordinate systems. If you are using an RGB-enabled version of PGPLOT, then the map images will appear in color on your screen. Otherwise they will appear in greyscale. (The vector data will appear in color regardless). |; act q| ### Load the necessary modules use PDL::Graphics::PGPLOT::Window; use PDL::Transform::Cartography; ### Get the vector coastline map (and a lon/lat grid), and load the Earth ### RGB daytime image -- both of these are built-in to the module. The ### coastline map is a set of (X,Y,Pen) vectors. $coast = earth_coast() -> glue( 1, scalar graticule(15,1) ); print "Coastline data are a collection of vectors: ", join("x",$coast->dims),"\n"; $map = earth_image('day'); print "Map data are RGB: ",join("x",$map->dims),"\n\n"; |; act q& ### Map data are stored natively in Plate Caree format. ### The image contains a FITS header that contains coordinate system info. print "FITS HEADER INFORMATION:\n"; for $_(keys %{$map->hdr}){ next if(m/SIMPLE/ || m/HISTORY/ || m/COMMENT/); printf (" %8s: %10s%s", $_, $map->hdr->{$_}, (++$i%3) ? " " : "\n"); } print "\n"; $dev = $^O =~ /MSWin32/ ? '/GW' : defined($ENV{PGPLOT_DEV}) ? $ENV{PGPLOT_DEV} : "/XW"; # $dev = $^O =~ /MSWin/i ? '/GW' : '/xw'; $w = pgwin(Dev=> $dev, size=>[8,6]); $w->fits_imag($map, {Title=>"NASA/MODIS Earth Map (Plate Caree)",J=>0}); &; act q& ### The map data are co-aligned with the vector data, which can be drawn ### on top of the window with the "->lines" PGPLOT method. The ### clean_lines method breaks lines that pass over the map's singularity ### at the 180th parallel. $w->hold; $w->lines( $coast -> clean_lines ); $w->release; &; act q& ### There are a large number of map projections -- to list them all, ### say "??cartography" in the perldl or pdl2 shell. Here are four ### of them: $w->close; # Close old window undef $w; #$dev = $^O =~ /MSWin/i ? '/GW' : '/xw'; $dev = $^O =~ /MSWin32/ ? '/GW' : defined($ENV{PGPLOT_DEV}) ? $ENV{PGPLOT_DEV} : "/XW"; $w = pgwin( Dev=> $dev, size=>[8,6], nx=>2, ny=>2 ) ; sub draw { ($tx, $t, $px, $opt ) = @_; $w->fits_imag( $map->map( $tx, $px, $opt ),{Title=>$t, CharSize=>1.5, J=>1} ); $w->hold; $w->lines( $coast -> apply( $tx ) -> clean_lines ); $w->release; } ## (The "or" option specifies the output range of the mapping) draw( t_mercator, "Mercator Projection", [400,300] ); draw( t_aitoff, "Aitoff / Hammer", [400,300] ); draw( t_gnomonic, "Gnomonic", [400,300],{or=>[[-3,3],[-2,2]]} ); draw( t_lambert, "Lambert Conformal Conic",[400,300],{or=>[[-3,3],[-2,2]]} ); &; act q| ### You can create oblique projections by feeding in a different origin. ### Here, the origin is centered over North America. draw( t_mercator( o=>[-90,40] ), "Mercator Projection", [400,300] ); draw( t_aitoff ( o=>[-90,40] ), "Aitoff / Hammer", [400,300] ); draw( t_gnomonic( o=>[-90,40] ), "Gnomonic",[400,300],{or=>[[-3,3],[-2,2]]} ); draw( t_lambert( o=>[-90,40] ), "Lambert ",[400,300],{or=>[[-3,3],[-2,2]]} ); |; act q| ### There are three main perspective projections (in addition to special ### cases like stereographic and gnomonic projection): orthographic, ### vertical, and true perspective. The true perspective has options for ### both downward-looking and aerial-view coordinate systems. draw( t_orthographic( o=>[-90,40] ), "Orthographic", [400,300]); draw( t_vertical( r0=> (2 + 1), o=>[-90,40] ), "Vertical (Altitude = 2 r\\\\de\\\\u)", [400,300]); draw( t_perspective( r0=> (2 + 1), o=>[-90,40] ), "True Perspective (Altitude= 2 r\\\\de\\\\u)", [400,300]); # Observer is 0.1 earth-radii above surface, lon 117W, lat 31N (over Tijuana). # view is 45 degrees below horizontal, azimuth -22 (338) degrees. draw( t_perspective( r0=> 1.1, o=>[-117,31], cam=>[-22,-45,0] ), "Aerial view of West Coast of USA", [400,300], {or=>[[-60,60],[-45,45]], method=>'linear'}); |; comment q| That concludes the basic cartography demo. Numerous other transforms are available. Because PDL's cartographic transforms work with in the Transform module and are invertible, it's easy to use them both forwards and backwards. In particular, the perspective transformation is useful for ingesting scientific image data of the Earth or other planets, and converting to a map of the imaged body. Similarly, scanned images of map data can easily be converted into lat/lon coordinates or reprojected to make other projections. |; $w->close; undef $w; } 1; PDL-2.018/Demos/earth-interp.pl0000644060175006010010000000316712562522364014420 0ustar chmNone############################## # Demo code to interpret the map data in earth.txt # # Craig DeForest, 17-Dec-2002 # $| = 1; print "Initializing...\n"; use PDL; use PDL::NiceSlice; # Snarf the file and build a separate piddle for each polyline print "Interpreting map file...\n"; open(MAP,") { next if(m/^\#/ || m/^\s*$/); s/^\s+//; ($x,$y,$z,$color) = split /\s+/; if($color==0 and $#a > 1) { push(@a,$a[0]); my $c = $a[1]->[3]; print $c; ($a[-1])->[3] = $c; $nelem++; push(@mainlist,pdl(@a)); undef @a; } push(@a,[$x,$y,$z,$color ? $color-1:0]); $nelem++; } print "Breaking up elements...\n"; $elements = zeroes(4,$nelem); $pos = 0; foreach $z(@mainlist) { $n = $z->dim(1); $elements->(0:2,$pos:$pos+$n-1) .= $z->(0:2); $elements->((3),$pos:$pos+$n-2) .= $z->((3),1:-1); $elements->((3),$pos+n-1) .= 0; $pos += $n; } print "... $nelem vectors\n"; # Transform all the polylines into spherical coordinates. use PDL::Transform; $t = t_compose(t_scale(ones(3)*180/3.14159),t_spherical()); $lonlat = $t->apply( $elements->(pdl(2,0,1)) ) ->(1:2); # discard radius # Clean up the pen values at the longitude singularity print "cleaning up singularities...\n"; $p = $elements->((3)); $idx = which((abs($lonlat->((0),0:-2) - $lonlat->((0),1:-1))) > 355); $p->($idx) .= 0 if($idx->nelem > 0); # Plot map use PDL::Graphics::PGPLOT::Window; $w = pgwin(dev=>'/xs',size=>[10,10]); $w->lines($lonlat,$p,{Title=>'Lat/Lon map of world coastlines',XTitle=>'East Longitude',YTitle=>'North Latitude',Axis=>2}); wfits($lonlat->glue(0,$p->dummy(0,1)),'earth_coast.vec.fits'); 1; PDL-2.018/Demos/earth.txt0000644060175006010010000162242612562522364013333 0ustar chmNone# Map data demo file from XEarth by Kirk Johnson # # http://www.cs.colorado.edu/~tuna/xearth/ # # This file is copyright (C) 1995 Kirk Lauritz Johnson. Permission to # use, copy, modify, and freely distribute this file for non-commercial # and not-for-profit purposes is hereby granted without fee, provided # this copyright notice appears in all copies and in supporting # documentation. You may distribute this file and charge a fee for the # act of doing so, though the file itself is free. # # Notes (CED 17-Dec-2002): # Format: ,,, # ( = north, = toward Greenwich, = east from Greenwich) # Color=0: new line # # Outlines are derived from the CIA World Map (interpreted and distributed # c. 1988 on USENET by Joe Dellinger, geojoe@freeusp.org). # 13663 15523 21733 0 13525 15597 21767 2 13594 15626 21703 2 13556 15645 21713 2 13463 15669 21754 2 13340 15671 21828 2 13201 15694 21896 2 13108 15640 21990 2 13062 15657 22006 2 13095 15690 21962 2 12950 15653 22075 2 12891 15571 22167 2 12774 15527 22266 2 12691 15448 22367 2 12593 15389 22464 2 12464 15390 22534 2 12332 15452 22564 2 12196 15482 22618 2 12050 15504 22681 2 11930 15541 22719 2 11793 15581 22763 2 11661 15631 22797 2 11524 15658 22848 2 11384 15681 22902 2 11243 15713 22950 2 11110 15717 23012 2 10987 15683 23094 2 10863 15727 23122 2 10768 15851 23082 2 10634 15901 23110 2 10498 15896 23175 2 10355 15920 23223 2 10220 15971 23248 2 10069 15984 23305 2 9953 16064 23300 2 9883 16178 23251 2 9732 16230 23279 2 9591 16274 23306 2 9454 16302 23342 2 9303 16302 23403 2 9188 16247 23487 2 9051 16228 23553 2 8938 16169 23636 2 8832 16102 23721 2 8749 16014 23812 2 8693 15908 23904 2 8697 15781 23986 2 8754 15654 24048 2 8835 15537 24095 2 8839 15411 24174 2 8783 15302 24263 2 8702 15208 24351 2 8591 15143 24431 2 8454 15124 24491 2 8314 15174 24507 2 8185 15251 24503 2 8060 15335 24492 2 7920 15394 24501 2 7779 15445 24514 2 7638 15491 24530 2 7492 15527 24552 2 7347 15551 24580 2 7200 15555 24621 2 7054 15585 24644 2 6918 15651 24641 2 6817 15756 24602 2 6748 15876 24544 2 6702 16001 24475 2 6583 16080 24456 2 6433 16103 24481 2 6290 16148 24488 2 6155 16213 24479 2 6008 16245 24495 2 5863 16274 24511 2 5721 16289 24535 2 5583 16253 24590 2 5434 16259 24619 2 5292 16305 24620 2 5138 16376 24606 2 5013 16414 24606 2 4891 16457 24602 2 4760 16583 24543 2 4622 16608 24552 2 4474 16652 24550 2 4363 16745 24507 2 4331 16867 24428 2 4428 16953 24351 2 4539 17027 24279 2 4626 17118 24199 2 4681 17228 24110 2 4701 17337 24027 2 4649 17465 23945 2 4527 17546 23909 2 4422 17646 23855 2 4412 17768 23766 2 4515 17847 23688 2 4581 17951 23596 2 4563 18052 23522 2 4418 17989 23598 2 4293 17978 23630 2 4234 18108 23541 2 4102 18152 23530 2 3980 18183 23528 2 3840 18146 23579 2 3724 18083 23646 2 3601 18031 23705 2 3453 18022 23733 2 3288 18010 23766 2 3158 18057 23748 2 3021 18063 23761 2 2880 18020 23811 2 2739 18063 23796 2 2619 18050 23819 2 2499 17988 23879 2 2358 17958 23915 2 2224 17910 23964 2 2098 17968 23932 2 1951 18007 23915 2 1799 18012 23923 2 1647 18011 23935 2 1509 17977 23970 2 1357 17959 23993 2 1216 17953 24004 2 1076 17890 24058 2 930 17888 24065 2 782 17870 24084 2 630 17860 24096 2 484 17843 24112 2 350 17792 24152 2 213 17741 24191 2 91 17674 24241 2 -3 17573 24315 2 -156 17570 24316 2 -298 17525 24347 2 -439 17489 24371 2 -535 17398 24434 2 -648 17322 24485 2 -779 17258 24527 2 -927 17246 24530 2 -1075 17257 24516 2 -1215 17285 24490 2 -1306 17348 24441 2 -1473 17297 24467 2 -1622 17311 24448 2 -1770 17296 24448 2 -1917 17281 24448 2 -2058 17324 24406 2 -2170 17403 24340 2 -2249 17500 24263 2 -2310 17580 24199 2 -2487 17535 24215 2 -2562 17427 24284 2 -2622 17311 24361 2 -2680 17194 24437 2 -2747 17079 24510 2 -2821 16968 24579 2 -2903 16859 24644 2 -2997 16759 24702 2 -3127 16688 24733 2 -3263 16627 24757 2 -3403 16573 24774 2 -3545 16524 24787 2 -3681 16463 24808 2 -3789 16377 24848 2 -3898 16281 24895 2 -4012 16192 24935 2 -4079 16084 24993 2 -4111 15958 25069 2 -4203 15852 25121 2 -4298 15746 25171 2 -4363 15626 25235 2 -4385 15496 25311 2 -4401 15365 25388 2 -4383 15259 25455 2 -4331 15144 25533 2 -4378 15014 25601 2 -4465 14903 25651 2 -4562 14796 25696 2 -4654 14688 25741 2 -4761 14586 25780 2 -4885 14505 25802 2 -5022 14438 25813 2 -5139 14348 25840 2 -5249 14247 25874 2 -5386 14184 25880 2 -5528 14131 25879 2 -5676 14098 25866 2 -5825 14076 25844 2 -5956 14021 25845 2 -6058 13913 25879 2 -6128 13785 25931 2 -6201 13663 25978 2 -6263 13534 26031 2 -6373 13437 26054 2 -6509 13368 26056 2 -6639 13300 26058 2 -6736 13200 26085 2 -6799 13072 26132 2 -6871 12945 26177 2 -6939 12819 26220 2 -6963 12682 26281 2 -7011 12548 26332 2 -7116 12447 26352 2 -7231 12350 26366 2 -7344 12248 26383 2 -7468 12163 26387 2 -7513 12078 26414 2 -7599 11912 26464 2 -7680 11780 26500 2 -7743 11660 26534 2 -7807 11529 26573 2 -7898 11403 26601 2 -8018 11322 26599 2 -8100 11197 26627 2 -8139 11062 26672 2 -8180 10920 26718 2 -8216 10781 26763 2 -8205 10718 26792 2 -8117 10767 26799 2 -8062 10639 26867 2 -7968 10573 26921 2 -7896 10444 26992 2 -7871 10315 27049 2 -7906 10184 27089 2 -7978 10044 27119 2 -7990 9969 27144 2 -7933 9794 27224 2 -7904 9657 27281 2 -7881 9518 27337 2 -7876 9375 27388 2 -7885 9231 27434 2 -7910 9087 27474 2 -7961 8947 27506 2 -8028 8813 27530 2 -8099 8683 27550 2 -8153 8545 27577 2 -8192 8403 27609 2 -8207 8257 27649 2 -8246 8117 27679 2 -8332 7990 27690 2 -8419 7867 27699 2 -8520 7754 27700 2 -8645 7674 27684 2 -8680 7619 27688 2 -8549 7540 27750 2 -8470 7425 27805 2 -8415 7293 27857 2 -8367 7256 27881 2 -8287 7293 27895 2 -8311 7163 27922 2 -8306 7031 27957 2 -8220 6934 28006 2 -8077 6974 28038 2 -7926 6989 28077 2 -7787 7000 28114 2 -7764 6988 28123 2 -7929 6974 28080 2 -8079 6959 28041 2 -8203 6888 28023 2 -8340 6954 27966 2 -8435 6914 27947 2 -8431 6769 27984 2 -8441 6619 28017 2 -8373 6581 28046 2 -8264 6552 28085 2 -8095 6571 28130 2 -7955 6543 28176 2 -7847 6596 28194 2 -7815 6612 28199 2 -7946 6526 28183 2 -8090 6546 28137 2 -8235 6532 28098 2 -8374 6532 28057 2 -8437 6434 28061 2 -8305 6350 28120 2 -8200 6349 28150 2 -8170 6195 28193 2 -8029 6230 28226 2 -8006 6211 28237 2 -8010 6137 28252 2 -7865 6181 28283 2 -7727 6203 28316 2 -7642 6170 28347 2 -7840 6101 28307 2 -7772 6058 28335 2 -7698 6040 28359 2 -7809 5931 28352 2 -7752 5798 28395 2 -7685 5774 28418 2 -7648 5745 28434 2 -7597 5676 28462 2 -7504 5681 28485 2 -7462 5592 28514 2 -7412 5599 28526 2 -7432 5461 28547 2 -7345 5333 28594 2 -7199 5269 28643 2 -7099 5166 28686 2 -6985 5103 28726 2 -6945 4958 28761 2 -6840 4852 28804 2 -6785 4741 28836 2 -6734 4614 28868 2 -6731 4489 28888 2 -6682 4442 28907 2 -6794 4372 28892 2 -6695 4275 28929 2 -6629 4147 28963 2 -6560 4049 28993 2 -6430 4002 29028 2 -6366 3899 29056 2 -6242 3782 29099 2 -6105 3728 29135 2 -5982 3647 29170 2 -5879 3544 29204 2 -5769 3459 29236 2 -5637 3391 29270 2 -5557 3291 29297 2 -5393 3218 29335 2 -5278 3137 29365 2 -5173 3036 29394 2 -5064 2931 29424 2 -4955 2833 29452 2 -4848 2721 29480 2 -4730 2634 29507 2 -4600 2564 29534 2 -4469 2495 29560 2 -4337 2422 29586 2 -4197 2372 29610 2 -4061 2310 29634 2 -3917 2277 29656 2 -3780 2337 29669 2 -3642 2398 29681 2 -3507 2456 29693 2 -3366 2507 29705 2 -3223 2560 29716 2 -3083 2617 29726 2 -2929 2653 29739 2 -2785 2668 29751 2 -2705 2702 29755 2 -2484 2691 29776 2 -2334 2712 29786 2 -2181 2724 29796 2 -2150 2750 29796 2 -2336 2729 29784 2 -2406 2745 29777 2 -2190 2769 29792 2 -2045 2771 29802 2 -1975 2744 29809 2 -1734 2707 29827 2 -1646 2748 29828 2 -1572 2668 29840 2 -1357 2602 29856 2 -1209 2560 29866 2 -1070 2494 29877 2 -925 2555 29877 2 -798 2630 29874 2 -646 2672 29874 2 -504 2719 29872 2 -362 2765 29870 2 -231 2836 29865 2 -93 2898 29860 2 42 2963 29853 2 181 3014 29848 2 308 3069 29841 2 222 3153 29833 2 401 3016 29845 2 527 3083 29836 2 628 3187 29824 2 773 3232 29815 2 920 3265 29808 2 1070 3288 29800 2 1221 3306 29792 2 1372 3321 29784 2 1524 3335 29775 2 1676 3337 29767 2 1794 3403 29752 2 1890 3391 29748 2 2084 3352 29739 2 2234 3332 29731 2 2372 3275 29726 2 2491 3182 29727 2 2607 3059 29730 2 2711 2999 29726 2 2804 2888 29729 2 2876 2836 29727 2 2816 2720 29743 2 2838 2605 29752 2 2904 2453 29758 2 3015 2335 29757 2 3142 2276 29748 2 3265 2286 29734 2 3437 2300 29714 2 3518 2357 29700 2 3534 2463 29689 2 3631 2376 29685 2 3714 2396 29673 2 3727 2430 29668 2 3841 2389 29657 2 3948 2393 29643 2 4092 2368 29625 2 4264 2382 29600 2 4321 2476 29584 2 4331 2536 29577 2 4448 2426 29569 2 4573 2389 29553 2 4666 2189 29554 2 4794 2094 29540 2 4922 2091 29520 2 5025 2051 29505 2 5043 1882 29513 2 5120 1751 29508 2 5170 1619 29507 2 5139 1472 29520 2 5115 1323 29531 2 5095 1177 29541 2 5095 1022 29546 2 5037 858 29562 2 4957 754 29578 2 4919 610 29588 2 5050 533 29567 2 5016 327 29576 2 4961 314 29585 2 4883 267 29599 2 4989 148 29582 2 5134 101 29557 2 5129 63 29558 2 4981 74 29584 2 4874 98 29601 2 4857 -121 29604 2 4799 -254 29613 2 4727 -374 29623 2 4641 -396 29636 2 4573 -382 29647 2 4654 -548 29632 2 4732 -677 29617 2 4863 -756 29594 2 4888 -842 29587 2 4745 -731 29613 2 4721 -715 29618 2 4810 -869 29599 2 4886 -973 29583 2 4916 -1040 29576 2 5026 -1241 29550 2 5148 -1296 29527 2 5196 -1333 29517 2 5101 -1335 29533 2 5217 -1448 29507 2 5333 -1541 29482 2 5441 -1644 29457 2 5532 -1764 29433 2 5635 -1870 29407 2 5724 -1988 29382 2 5828 -2093 29354 2 5923 -2203 29327 2 6033 -2307 29297 2 6111 -2438 29270 2 6168 -2560 29247 2 6250 -2656 29221 2 6300 -2832 29194 2 6287 -2974 29183 2 6389 -3106 29147 2 6493 -3134 29121 2 6620 -3061 29100 2 6713 -3087 29076 2 6512 -3155 29114 2 6367 -3210 29140 2 6432 -3386 29106 2 6509 -3511 29074 2 6590 -3632 29041 2 6618 -3781 29016 2 6667 -3923 28985 2 6721 -4062 28954 2 6784 -4198 28920 2 6850 -4329 28885 2 6863 -4470 28860 2 6797 -4586 28858 2 6694 -4688 28865 2 6712 -4839 28836 2 6753 -4982 28802 2 6789 -5117 28770 2 6838 -5249 28735 2 6901 -5389 28694 2 6981 -5513 28651 2 7020 -5643 28616 2 7040 -5791 28582 2 7011 -5936 28559 2 7000 -6085 28530 2 6968 -6232 28506 2 6896 -6377 28492 2 6811 -6489 28487 2 6689 -6555 28501 2 6567 -6659 28505 2 6504 -6789 28489 2 6399 -6894 28487 2 6325 -7018 28474 2 6291 -7175 28442 2 6222 -7308 28423 2 6206 -7451 28390 2 6170 -7598 28358 2 6115 -7732 28334 2 6065 -7867 28308 2 6021 -8019 28274 2 5928 -8137 28260 2 5887 -8251 28236 2 5887 -8395 28193 2 5889 -8539 28150 2 5870 -8683 28109 2 5843 -8831 28069 2 5821 -8971 28029 2 5809 -9115 27985 2 5823 -9258 27936 2 5884 -9384 27881 2 5940 -9511 27825 2 6038 -9615 27769 2 6116 -9732 27711 2 6180 -9854 27653 2 6231 -9984 27595 2 6289 -10109 27536 2 6346 -10235 27477 2 6413 -10354 27417 2 6449 -10490 27356 2 6488 -10624 27295 2 6539 -10750 27234 2 6606 -10870 27170 2 6675 -10987 27106 2 6725 -11115 27041 2 6802 -11226 26976 2 6876 -11339 26910 2 6926 -11465 26844 2 6942 -11600 26782 2 6891 -11715 26744 2 6884 -11881 26673 2 6876 -12013 26616 2 6861 -12153 26556 2 6848 -12289 26497 2 6881 -12422 26426 2 6925 -12544 26357 2 6956 -12673 26287 2 6939 -12810 26225 2 6939 -12945 26159 2 6937 -13078 26093 2 6955 -13210 26022 2 6976 -13332 25954 2 6997 -13457 25884 2 7009 -13585 25813 2 7028 -13715 25739 2 7069 -13836 25663 2 7121 -13955 25584 2 7179 -14071 25504 2 7263 -14171 25425 2 7351 -14265 25347 2 7449 -14358 25266 2 7510 -14462 25188 2 7569 -14574 25106 2 7606 -14695 25024 2 7636 -14820 24941 2 7652 -14947 24860 2 7676 -15072 24777 2 7707 -15193 24694 2 7752 -15309 24608 2 7793 -15426 24522 2 7844 -15539 24434 2 7901 -15647 24347 2 7962 -15754 24257 2 7983 -15877 24170 2 7979 -16006 24086 2 7948 -16134 24011 2 7835 -16224 23988 2 7737 -16273 23986 2 7772 -16368 23910 2 7792 -16443 23852 2 7870 -16595 23721 2 7876 -16718 23632 2 7816 -16831 23572 2 7863 -16868 23530 2 7997 -16845 23501 2 8065 -16929 23417 2 8173 -16996 23331 2 8253 -17080 23241 2 8378 -17113 23172 2 8498 -17078 23154 2 8632 -16999 23163 2 8783 -16961 23134 2 8912 -16942 23099 2 9050 -16944 23043 2 9200 -16929 22994 2 9331 -16850 23000 2 9465 -16800 22982 2 9610 -16782 22935 2 9727 -16808 22866 2 9866 -16803 22811 2 10008 -16777 22768 2 10139 -16799 22694 2 10261 -16832 22614 2 10400 -16849 22538 2 10522 -16772 22539 2 10661 -16782 22465 2 10771 -16753 22435 2 10883 -16659 22451 2 11018 -16664 22381 2 11153 -16660 22317 2 11291 -16607 22287 2 11426 -16548 22263 2 11557 -16473 22250 2 11688 -16398 22238 2 11817 -16321 22226 2 11941 -16231 22225 2 12069 -16152 22214 2 12191 -16061 22213 2 12309 -15968 22215 2 12422 -15869 22223 2 12535 -15770 22230 2 12661 -15687 22217 2 12787 -15607 22202 2 12902 -15506 22206 2 13010 -15401 22216 2 13111 -15289 22234 2 13209 -15176 22253 2 13304 -15058 22277 2 13407 -14948 22289 2 13494 -14826 22318 2 13600 -14715 22327 2 13712 -14617 22323 2 13831 -14525 22310 2 13953 -14455 22279 2 14080 -14362 22259 2 14165 -14247 22279 2 14248 -14120 22308 2 14303 -13988 22355 2 14368 -13858 22395 2 14444 -13730 22424 2 14514 -13599 22459 2 14562 -13466 22508 2 14607 -13331 22559 2 14598 -13239 22619 2 14524 -13137 22726 2 14628 -13023 22725 2 14745 -12903 22718 2 14876 -12822 22678 2 14998 -12769 22627 2 15128 -12714 22572 2 15258 -12668 22510 2 15389 -12619 22449 2 15519 -12570 22386 2 15647 -12510 22331 2 15757 -12415 22306 2 15860 -12301 22297 2 15930 -12163 22322 2 15900 -12098 22379 2 15976 -11899 22432 2 16035 -11765 22460 2 16067 -11656 22494 2 16093 -11501 22555 2 16135 -11359 22597 2 16097 -11345 22631 2 16053 -11404 22633 2 16084 -11218 22704 2 16094 -11078 22766 2 16076 -10946 22842 2 16079 -10831 22895 2 16094 -10679 22955 2 16040 -10574 23041 2 16003 -10465 23117 2 16052 -10318 23149 2 16072 -10178 23197 2 16075 -10119 23221 2 16192 -10154 23124 2 16306 -10067 23082 2 16414 -9965 23050 2 16510 -9857 23027 2 16630 -9753 22986 2 16753 -9695 22920 2 16848 -9627 22880 2 16956 -9510 22848 2 17073 -9388 22812 2 17145 -9256 22811 2 17260 -9166 22761 2 17369 -9088 22710 2 17489 -9014 22647 2 17608 -8949 22580 2 17707 -8890 22526 2 17854 -8835 22432 2 17960 -8797 22362 2 18095 -8740 22275 2 18197 -8651 22227 2 18312 -8578 22161 2 18414 -8481 22113 2 18500 -8377 22081 2 18585 -8262 22053 2 18683 -8145 22013 2 18782 -8030 21972 2 18842 -7886 21972 2 18884 -7787 21972 2 18926 -7691 21969 2 18956 -7517 22004 2 18946 -7434 22040 2 18936 -7333 22083 2 18954 -7151 22128 2 18967 -7013 22160 2 18989 -6878 22184 2 18995 -6717 22228 2 19042 -6578 22229 2 19033 -6419 22283 2 19058 -6278 22303 2 19062 -6137 22338 2 19072 -5984 22371 2 19082 -5858 22396 2 19145 -5709 22381 2 19170 -5569 22394 2 19141 -5418 22456 2 19057 -5339 22546 2 18972 -5275 22632 2 18899 -5173 22717 2 18897 -5017 22754 2 18876 -4883 22801 2 18857 -4734 22848 2 18838 -4615 22887 2 18803 -4451 22948 2 18817 -4309 22964 2 18871 -4163 22947 2 18836 -4049 22996 2 18847 -3888 23014 2 18906 -3768 22986 2 18950 -3649 22969 2 18872 -3553 23049 2 18811 -3435 23116 2 18734 -3348 23191 2 18698 -3187 23243 2 18721 -3039 23244 2 18773 -2896 23220 2 18823 -2752 23197 2 18864 -2601 23182 2 18913 -2461 23157 2 19005 -2369 23091 2 19067 -2230 23054 2 19104 -2092 23036 2 19176 -1940 22989 2 19202 -1843 22976 2 19273 -1721 22926 2 19325 -1569 22893 2 19343 -1424 22887 2 19444 -1338 22806 2 19551 -1297 22717 2 19622 -1184 22662 2 19656 -1050 22639 2 19783 -1012 22530 2 19872 -905 22456 2 19944 -786 22397 2 20009 -646 22344 2 20061 -515 22300 2 20132 -416 22238 2 20212 -295 22167 2 20282 -189 22104 2 20364 -75 22029 2 20440 34 21959 2 20515 145 21889 2 20590 255 21818 2 20665 364 21744 2 20746 465 21665 2 20831 556 21581 2 20909 658 21503 2 20989 757 21421 2 21074 848 21334 2 21161 933 21245 2 21252 1007 21151 2 21344 1076 21054 2 21434 1153 20959 2 21523 1229 20863 2 21601 1325 20776 2 21670 1433 20696 2 21743 1536 20612 2 21814 1641 20530 2 21880 1753 20450 2 21944 1865 20371 2 22010 1974 20290 2 22074 2084 20208 2 22135 2199 20130 2 22197 2311 20049 2 22246 2436 19980 2 22286 2568 19918 2 22337 2691 19845 2 22390 2810 19768 2 22437 2936 19697 2 22480 3064 19628 2 22518 3196 19564 2 22530 3340 19525 2 22550 3482 19477 2 22582 3616 19416 2 22624 3740 19343 2 22668 3863 19268 2 22699 4000 19203 2 22710 4140 19160 2 22768 4253 19066 2 22806 4380 18992 2 22836 4509 18926 2 22860 4647 18863 2 22902 4766 18783 2 22935 4897 18709 2 22925 5049 18680 2 22923 5196 18642 2 22913 5348 18611 2 22982 5421 18505 2 23006 5447 18467 2 22953 5487 18521 2 22940 5632 18494 2 22916 5785 18476 2 22888 5927 18466 2 22903 6065 18404 2 22868 6165 18414 2 22763 6214 18527 2 22680 6180 18639 2 22634 6067 18732 2 22559 6001 18843 2 22470 5969 18959 2 22379 5941 19076 2 22297 5888 19188 2 22204 5856 19305 2 22103 5881 19413 2 22005 5868 19529 2 21922 5807 19639 2 21824 5788 19754 2 21723 5803 19860 2 21627 5789 19968 2 21553 5709 20072 2 21474 5635 20177 2 21387 5578 20285 2 21286 5600 20386 2 21173 5629 20494 2 21082 5628 20588 2 20998 5556 20693 2 20913 5491 20796 2 20827 5436 20897 2 20715 5431 21009 2 20606 5443 21113 2 20504 5529 21190 2 20408 5625 21257 2 20322 5738 21309 2 20248 5874 21343 2 20159 5969 21400 2 20060 6032 21475 2 19943 6008 21591 2 19900 6027 21625 2 19987 6125 21518 2 20075 6191 21416 2 20152 6273 21320 2 20117 6428 21307 2 20042 6545 21342 2 19950 6657 21394 2 19850 6719 21467 2 19753 6836 21520 2 19667 6919 21572 2 19588 7057 21598 2 19491 7154 21655 2 19382 7227 21728 2 19288 7338 21774 2 19202 7455 21811 2 19108 7565 21855 2 18987 7611 21944 2 18895 7700 21993 2 18793 7750 22063 2 18681 7783 22146 2 18615 7917 22154 2 18529 7946 22216 2 18508 7853 22266 2 18412 8014 22289 2 18348 8117 22304 2 18263 8255 22323 2 18207 8398 22316 2 18163 8542 22297 2 18117 8678 22281 2 18055 8821 22276 2 17991 8956 22274 2 17915 9089 22281 2 17832 9218 22295 2 17753 9327 22312 2 17643 9391 22372 2 17543 9482 22413 2 17421 9589 22462 2 17311 9646 22523 2 17233 9775 22527 2 17174 9915 22511 2 17111 10061 22494 2 17079 10193 22459 2 17027 10330 22436 2 16994 10479 22392 2 16947 10615 22364 2 16891 10758 22337 2 16901 10834 22293 2 16773 11029 22294 2 16710 11163 22275 2 16653 11294 22251 2 16533 11377 22298 2 16425 11473 22329 2 16314 11560 22366 2 16180 11633 22425 2 16107 11735 22425 2 16014 11860 22425 2 15966 11994 22388 2 15946 12147 22320 2 15989 12204 22258 2 15861 12307 22293 2 15738 12430 22312 2 15654 12551 22303 2 15572 12675 22290 2 15481 12798 22283 2 15395 12920 22273 2 15304 13042 22264 2 15208 13159 22261 2 15117 13281 22251 2 15025 13405 22238 2 14958 13531 22208 2 14890 13655 22177 2 14802 13770 22165 2 14697 13904 22152 2 14655 14009 22113 2 14542 14122 22115 2 14432 14226 22121 2 14326 14334 22120 2 14231 14448 22108 2 14146 14567 22084 2 14085 14694 22039 2 13976 14807 22032 2 13971 14942 21944 2 14020 14943 21912 2 14106 14792 21959 2 14194 14685 21975 2 14308 14581 21970 2 14388 14464 21995 2 14453 14339 22034 2 14569 14239 22022 2 14679 14138 22015 2 14794 14045 21997 2 14928 13994 21939 2 14970 14102 21841 2 14932 14237 21780 2 14940 14359 21694 2 14933 14489 21612 2 14916 14615 21538 2 14926 14734 21451 2 14976 14732 21418 2 14990 14594 21502 2 15010 14464 21576 2 15035 14332 21646 2 15034 14195 21736 2 15077 14126 21752 2 15218 14116 21660 2 15333 14021 21640 2 15431 13905 21646 2 15528 13789 21650 2 15622 13674 21656 2 15726 13566 21649 2 15826 13452 21647 2 15920 13337 21649 2 16019 13218 21650 2 16104 13115 21649 2 16190 13019 21642 2 16294 12899 21636 2 16391 12782 21633 2 16449 12640 21672 2 16500 12532 21695 2 16604 12411 21686 2 16706 12330 21654 2 16827 12277 21590 2 16949 12194 21541 2 17060 12098 21508 2 17154 11977 21501 2 17241 11848 21502 2 17317 11726 21508 2 17385 11627 21508 2 17483 11458 21519 2 17499 11328 21574 2 17518 11186 21633 2 17586 11063 21641 2 17635 10924 21672 2 17695 10790 21690 2 17796 10671 21667 2 17879 10563 21650 2 17976 10450 21626 2 18086 10394 21561 2 18210 10323 21490 2 18321 10232 21439 2 18419 10135 21401 2 18505 10020 21381 2 18593 9884 21368 2 18673 9754 21359 2 18737 9611 21367 2 18827 9494 21340 2 18900 9366 21333 2 18990 9240 21307 2 19096 9146 21253 2 19199 9053 21200 2 19281 8935 21175 2 19339 8814 21173 2 19441 8686 21133 2 19513 8562 21117 2 19566 8421 21125 2 19607 8273 21145 2 19595 8135 21209 2 19635 7995 21226 2 19647 7878 21259 2 19744 7702 21233 2 19797 7568 21232 2 19825 7458 21245 2 19890 7275 21247 2 19964 7148 21222 2 19993 7004 21242 2 20017 6859 21267 2 20091 6723 21240 2 20166 6609 21205 2 20293 6567 21097 2 20398 6560 20997 2 20491 6602 20893 2 20585 6636 20790 2 20677 6645 20695 2 20741 6746 20599 2 20822 6817 20494 2 20884 6915 20397 2 20980 6950 20286 2 21084 6960 20175 2 21188 6964 20064 2 21281 7000 19953 2 21371 7045 19841 2 21460 7091 19728 2 21525 7184 19624 2 21601 7255 19513 2 21697 7260 19405 2 21791 7266 19296 2 21881 7311 19178 2 21927 7421 19082 2 21971 7529 18989 2 22047 7595 18874 2 22127 7647 18759 2 22216 7679 18641 2 22300 7715 18525 2 22373 7782 18410 2 22460 7814 18290 2 22545 7848 18169 2 22625 7895 18050 2 22695 7956 17934 2 22760 8024 17821 2 22823 8107 17703 2 22785 8258 17682 2 22788 8396 17613 2 22838 8489 17503 2 22910 8542 17382 2 22983 8594 17261 2 23059 8637 17137 2 23137 8671 17014 2 23205 8734 16889 2 23274 8781 16770 2 23360 8787 16647 2 23452 8759 16531 2 23525 8802 16404 2 23535 8935 16317 2 23505 9073 16285 2 23532 9185 16183 2 23607 9220 16054 2 23686 9238 15926 2 23759 9268 15800 2 23781 9378 15700 2 23762 9522 15643 2 23777 9637 15550 2 23831 9701 15426 2 23900 9734 15298 2 23980 9744 15165 2 23982 9836 15104 2 23927 9976 15099 2 23876 10117 15085 2 23859 10254 15020 2 23838 10393 14958 2 23846 10509 14863 2 23902 10487 14790 2 23968 10478 14688 2 23965 10624 14589 2 23962 10734 14512 2 23971 10848 14412 2 24002 10938 14292 2 24017 11040 14189 2 24010 11164 14103 2 24004 11285 14016 2 23985 11416 13942 2 23916 11501 13991 2 23824 11573 14089 2 23738 11686 14140 2 23650 11794 14197 2 23565 11910 14243 2 23481 12002 14303 2 23395 12028 14423 2 23301 12066 14543 2 23213 12093 14660 2 23119 12135 14774 2 23024 12188 14878 2 22928 12282 14949 2 22837 12392 14997 2 22748 12504 15039 2 22667 12631 15055 2 22604 12765 15037 2 22549 12900 15004 2 22486 13029 14987 2 22451 13169 14916 2 22399 13262 14913 2 22377 13084 15101 2 22354 12995 15212 2 22323 12914 15327 2 22309 12803 15441 2 22287 12703 15554 2 22249 12612 15682 2 22235 12519 15776 2 22230 12427 15856 2 22211 12313 15971 2 22152 12252 16098 2 22072 12230 16225 2 21976 12251 16339 2 21887 12269 16445 2 21787 12275 16572 2 21722 12251 16675 2 21658 12191 16802 2 21561 12206 16915 2 21465 12321 16954 2 21395 12347 17023 2 21330 12404 17064 2 21304 12499 17027 2 21307 12660 16904 2 21257 12796 16864 2 21187 12933 16848 2 21160 13044 16796 2 21058 13166 16829 2 20976 13189 16914 2 20969 13074 17011 2 20989 12948 17083 2 21007 12819 17158 2 21071 12684 17180 2 21080 12607 17225 2 20967 12753 17256 2 20874 12893 17264 2 20776 12998 17303 2 20686 13130 17312 2 20663 13214 17275 2 20632 13336 17218 2 20551 13465 17214 2 20467 13555 17244 2 20357 13641 17307 2 20265 13708 17362 2 20160 13828 17389 2 20036 13907 17469 2 19969 14001 17471 2 19867 14130 17483 2 19773 14260 17484 2 19683 14382 17485 2 19595 14495 17492 2 19505 14614 17493 2 19410 14708 17519 2 19348 14762 17542 2 19390 14852 17420 2 19316 15010 17366 2 19463 14975 17232 2 19530 15012 17124 2 19536 15102 17037 2 19517 15209 16964 2 19572 15164 16941 2 19684 15071 16894 2 19786 15028 16812 2 19868 15078 16671 2 19968 14970 16649 2 20076 14859 16619 2 20184 14760 16576 2 20269 14630 16587 2 20361 14527 16565 2 20458 14416 16543 2 20540 14285 16555 2 20633 14164 16543 2 20733 14061 16506 2 20834 14010 16421 2 20936 13985 16314 2 21044 13922 16227 2 21150 13828 16169 2 21239 13740 16128 2 21344 13668 16050 2 21454 13614 15950 2 21554 13520 15895 2 21648 13487 15794 2 21739 13482 15674 2 21839 13425 15583 2 21931 13393 15480 2 21979 13461 15354 2 22036 13511 15227 2 22075 13580 15108 2 22131 13636 14976 2 22180 13697 14847 2 22263 13697 14722 2 22361 13653 14614 2 22440 13564 14576 2 22523 13423 14580 2 22591 13291 14595 2 22662 13164 14599 2 22756 13048 14558 2 22857 13011 14431 2 22941 12975 14330 2 23027 12952 14213 2 23106 12950 14086 2 23195 12908 13977 2 23277 12878 13869 2 23349 12886 13739 2 23435 12862 13615 2 23519 12848 13483 2 23592 12846 13357 2 23683 12794 13245 2 23769 12764 13119 2 23854 12739 12989 2 23907 12752 12878 2 23980 12729 12763 2 24031 12758 12639 2 24068 12776 12550 2 24137 12795 12398 2 24207 12791 12265 2 24275 12796 12124 2 24307 12855 11998 2 24373 12861 11855 2 24459 12808 11736 2 24526 12793 11611 2 24577 12827 11465 2 24628 12849 11329 2 24689 12850 11194 2 24739 12875 11054 2 24792 12895 10913 2 24812 12912 10846 2 24944 12747 10738 2 25008 12615 10746 2 25086 12579 10604 2 25145 12492 10568 2 25214 12366 10551 2 25296 12230 10513 2 25366 12138 10451 2 25433 12131 10297 2 25494 12071 10215 2 25546 12039 10122 2 25563 12114 9989 2 25572 12107 9974 2 25576 11995 10099 2 25638 11883 10075 2 25712 11776 10011 2 25789 11703 9899 2 25861 11642 9782 2 25926 11609 9646 2 25956 11651 9515 2 25988 11698 9369 2 26027 11694 9266 2 26051 11514 9421 2 26021 11460 9569 2 25990 11423 9699 2 25941 11405 9848 2 25908 11399 9941 2 25997 11241 9888 2 26070 11149 9799 2 26147 11047 9710 2 26221 10945 9626 2 26295 10835 9549 2 26367 10739 9457 2 26438 10662 9347 2 26503 10611 9220 2 26541 10634 9081 2 26568 10690 8938 2 26585 10750 8813 2 26607 10814 8668 2 26599 10908 8573 2 26565 11048 8498 2 26491 11185 8553 2 26451 11346 8462 2 26469 11375 8367 2 26523 11337 8247 2 26559 11198 8319 2 26611 11083 8308 2 26652 11073 8190 2 26663 10938 8335 2 26729 10798 8305 2 26795 10673 8251 2 26846 10531 8271 2 26877 10398 8337 2 26915 10259 8387 2 26962 10126 8398 2 27016 10003 8372 2 27070 9884 8339 2 27118 9759 8331 2 27161 9625 8346 2 27214 9476 8342 2 27261 9347 8334 2 27321 9189 8315 2 27374 9051 8290 2 27424 8914 8273 2 27475 8769 8260 2 27529 8610 8248 2 27564 8502 8244 2 27623 8342 8209 2 27674 8219 8160 2 27734 8088 8089 2 27781 7975 8039 2 27835 7818 8005 2 27893 7689 7928 2 27946 7567 7858 2 27985 7467 7814 2 28029 7330 7786 2 28083 7176 7734 2 28124 7052 7701 2 28160 6913 7697 2 28208 6744 7671 2 28244 6635 7631 2 28296 6468 7581 2 28341 6338 7525 2 28389 6219 7444 2 28435 6102 7362 2 28479 5974 7296 2 28520 5851 7236 2 28561 5704 7192 2 28598 5567 7153 2 28639 5427 7098 2 28675 5301 7047 2 28703 5202 7005 2 28733 5067 6983 2 28767 4872 6982 2 28796 4763 6934 2 28831 4652 6867 2 28878 4491 6773 2 28917 4375 6683 2 28957 4277 6571 2 28996 4227 6432 2 29019 4278 6293 2 29034 4360 6164 2 29029 4491 6097 2 29016 4618 6060 2 29020 4738 5947 2 29041 4785 5805 2 29063 4826 5662 2 29093 4817 5513 2 29098 4822 5483 2 29058 4875 5644 2 29032 5003 5666 2 29026 5128 5582 2 29017 5257 5510 2 29015 5365 5419 2 29040 5362 5287 2 29045 5424 5196 2 29016 5574 5197 2 28988 5722 5190 2 28950 5886 5218 2 28927 6001 5219 2 28898 6161 5191 2 28877 6316 5123 2 28867 6423 5045 2 28848 6556 4980 2 28821 6701 4944 2 28792 6847 4911 2 28760 6969 4928 2 28732 7058 4968 2 28697 7207 4955 2 28652 7358 4994 2 28620 7505 4955 2 28582 7633 4979 2 28539 7779 5000 2 28505 7924 4970 2 28478 8058 4904 2 28464 8168 4805 2 28480 8198 4658 2 28494 8192 4583 2 28495 8226 4511 2 28469 8380 4395 2 28466 8450 4278 2 28490 8438 4134 2 28497 8487 3988 2 28489 8570 3861 2 28451 8710 3831 2 28419 8830 3796 2 28407 8918 3675 2 28404 8982 3538 2 28397 9058 3399 2 28379 9147 3311 2 28354 9261 3204 2 28341 9348 3070 2 28332 9418 2937 2 28306 9526 2831 2 28281 9630 2729 2 28251 9743 2634 2 28223 9844 2566 2 28195 9957 2429 2 28174 10044 2307 2 28165 10073 2288 2 28161 10063 2382 2 28127 10187 2260 2 28154 10131 2177 2 28153 10176 1970 2 28130 10263 1836 2 28117 10316 1731 2 28082 10432 1602 2 28045 10542 1535 2 28014 10631 1488 2 27953 10784 1536 2 27904 10913 1498 2 27875 11005 1382 2 27866 11044 1236 2 27854 11088 1091 2 27820 11183 978 2 27771 11310 930 2 27742 11377 962 2 27804 11232 885 2 27861 11090 874 2 27869 11077 806 2 27855 11117 708 2 27803 11250 638 2 27878 11068 581 2 27866 11103 469 2 27822 11212 460 2 27855 11136 321 2 27807 11256 244 2 27786 11310 218 2 27851 11148 169 2 27809 11254 73 2 27750 11398 59 2 27749 11402 38 2 27810 11252 -4 2 27843 11170 -76 2 27795 11287 -205 2 27747 11402 -289 2 27690 11540 -252 2 27637 11668 -245 2 27580 11802 -245 2 27536 11906 -191 2 27515 11955 -69 2 27476 12043 63 2 27450 12102 202 2 27428 12150 250 2 27431 12147 112 2 27478 12040 7 2 27512 11962 -119 2 27516 11950 -267 2 27588 11783 -291 2 27632 11677 -378 2 27647 11634 -522 2 27642 11638 -678 2 27688 11522 -788 2 27742 11385 -863 2 27790 11264 -903 2 27846 11122 -944 2 27898 10989 -968 2 27951 10850 -1002 2 27996 10727 -1076 2 28005 10700 -1114 2 27983 10759 -1106 2 28037 10610 -1177 2 28075 10496 -1271 2 28084 10466 -1332 2 28060 10527 -1345 2 28108 10392 -1398 2 28111 10376 -1452 2 28095 10412 -1496 2 28157 10243 -1503 2 28157 10235 -1561 2 28140 10261 -1690 2 28167 10166 -1807 2 28199 10063 -1884 2 28244 9927 -1931 2 28268 9887 -1785 2 28301 9762 -1939 2 28264 9858 -1994 2 28322 9680 -2044 2 28350 9587 -2096 2 28398 9426 -2169 2 28437 9296 -2220 2 28480 9154 -2252 2 28518 9028 -2282 2 28566 8881 -2256 2 28615 8735 -2216 2 28662 8587 -2179 2 28702 8465 -2135 2 28746 8318 -2120 2 28748 8289 -2196 2 28706 8406 -2301 2 28689 8448 -2354 2 28739 8273 -2373 2 28716 8324 -2465 2 28749 8202 -2497 2 28717 8286 -2581 2 28732 8216 -2639 2 28717 8255 -2680 2 28743 8145 -2734 2 28704 8248 -2841 2 28661 8365 -2926 2 28628 8434 -3050 2 28592 8522 -3143 2 28568 8605 -3139 2 28565 8551 -3307 2 28517 8671 -3405 2 28476 8794 -3435 2 28432 8922 -3465 2 28463 8771 -3594 2 28503 8616 -3651 2 28517 8531 -3743 2 28515 8496 -3835 2 28571 8316 -3815 2 28601 8186 -3869 2 28638 8040 -3901 2 28676 7898 -3913 2 28713 7752 -3934 2 28740 7618 -4001 2 28773 7471 -4033 2 28803 7328 -4088 2 28840 7173 -4102 2 28851 7103 -4142 2 28823 7202 -4169 2 28852 7042 -4239 2 28873 6912 -4307 2 28899 6768 -4365 2 28928 6620 -4402 2 28959 6479 -4406 2 28990 6338 -4403 2 29023 6180 -4413 2 29029 6109 -4468 2 29042 6037 -4483 2 29075 5892 -4464 2 29108 5736 -4450 2 29144 5606 -4381 2 29173 5472 -4355 2 29199 5324 -4369 2 29201 5265 -4422 2 29186 5315 -4466 2 29225 5147 -4403 2 29252 5018 -4372 2 29286 4865 -4318 2 29312 4723 -4300 2 29342 4578 -4255 2 29364 4441 -4244 2 29371 4302 -4337 2 29347 4329 -4472 2 29352 4195 -4565 2 29351 4091 -4667 2 29349 3996 -4762 2 29352 3844 -4869 2 29345 3774 -4965 2 29352 3650 -5017 2 29353 3536 -5090 2 29348 3424 -5191 2 29349 3298 -5268 2 29350 3166 -5343 2 29361 3010 -5371 2 29375 2868 -5377 2 29385 2717 -5399 2 29392 2578 -5429 2 29388 2463 -5503 2 29400 2317 -5503 2 29403 2177 -5541 2 29401 2055 -5599 2 29392 1923 -5694 2 29382 1801 -5784 2 29372 1680 -5870 2 29377 1524 -5888 2 29363 1409 -5984 2 29340 1333 -6115 2 29322 1240 -6221 2 29298 1152 -6349 2 29271 1086 -6485 2 29249 988 -6597 2 29222 916 -6726 2 29194 844 -6855 2 29172 748 -6961 2 29152 713 -7047 2 29112 762 -7204 2 29090 783 -7292 2 29064 785 -7394 2 29072 939 -7344 2 29082 1075 -7285 2 29093 1210 -7220 2 29106 1348 -7142 2 29130 1437 -7026 2 29138 1573 -6963 2 29130 1726 -6961 2 29124 1868 -6950 2 29119 2021 -6927 2 29104 2165 -6949 2 29088 2311 -6968 2 29079 2463 -6953 2 29080 2600 -6898 2 29085 2733 -6828 2 29094 2856 -6738 2 29114 2941 -6614 2 29129 3041 -6502 2 29135 3162 -6415 2 29151 3247 -6300 2 29170 3318 -6174 2 29181 3421 -6065 2 29184 3548 -5977 2 29203 3606 -5844 2 29234 3590 -5698 2 29252 3658 -5564 2 29264 3738 -5443 2 29272 3824 -5338 2 29270 3957 -5253 2 29255 3998 -5308 2 29258 3874 -5380 2 29258 3825 -5418 2 29242 4021 -5361 2 29228 4167 -5326 2 29212 4314 -5294 2 29210 4417 -5222 2 29208 4541 -5125 2 29188 4691 -5104 2 29176 4833 -5040 2 29205 4814 -4889 2 29217 4859 -4772 2 29199 5008 -4729 2 29177 5154 -4704 2 29149 5304 -4715 2 29122 5427 -4737 2 29086 5568 -4796 2 29051 5696 -4857 2 29017 5846 -4884 2 28980 5989 -4929 2 28940 6123 -4996 2 28902 6256 -5052 2 28866 6390 -5090 2 28836 6539 -5069 2 28800 6683 -5089 2 28766 6820 -5098 2 28738 6942 -5091 2 28701 6996 -5228 2 28668 7019 -5372 2 28652 6960 -5532 2 28691 6798 -5533 2 28728 6652 -5521 2 28737 6569 -5573 2 28706 6562 -5737 2 28676 6570 -5877 2 28649 6549 -6028 2 28642 6493 -6124 2 28637 6405 -6236 2 28627 6308 -6381 2 28622 6221 -6486 2 28635 6086 -6559 2 28631 6033 -6622 2 28660 5840 -6672 2 28681 5686 -6715 2 28645 5720 -6838 2 28615 5771 -6921 2 28634 5622 -6963 2 28661 5497 -6951 2 28623 5520 -7088 2 28589 5484 -7252 2 28571 5406 -7381 2 28562 5311 -7485 2 28535 5253 -7627 2 28542 5153 -7668 2 28588 5025 -7582 2 28615 4878 -7576 2 28641 4726 -7574 2 28658 4563 -7609 2 28670 4481 -7611 2 28618 4538 -7773 2 28576 4649 -7861 2 28534 4759 -7946 2 28488 4817 -8078 2 28437 4879 -8218 2 28412 5000 -8231 2 28416 5123 -8142 2 28415 5162 -8121 2 28397 5034 -8262 2 28358 5020 -8402 2 28349 5167 -8346 2 28352 5248 -8282 2 28322 5171 -8434 2 28326 5268 -8361 2 28286 5279 -8488 2 28280 5371 -8448 2 28238 5485 -8516 2 28198 5495 -8643 2 28166 5432 -8785 2 28107 5507 -8926 2 28053 5569 -9057 2 28003 5659 -9154 2 27950 5719 -9277 2 27892 5810 -9397 2 27838 5881 -9511 2 27792 5981 -9583 2 27751 6074 -9643 2 27714 6222 -9656 2 27683 6380 -9642 2 27653 6489 -9655 2 27603 6606 -9718 2 27573 6759 -9698 2 27558 6897 -9643 2 27533 7021 -9626 2 27499 7173 -9611 2 27471 7331 -9572 2 27451 7467 -9522 2 27429 7601 -9479 2 27414 7737 -9414 2 27388 7877 -9374 2 27388 7982 -9284 2 27391 8101 -9170 2 27383 8221 -9087 2 27376 8327 -9012 2 27390 8421 -8881 2 27404 8511 -8751 2 27411 8591 -8650 2 27421 8709 -8501 2 27411 8818 -8418 2 27418 8913 -8296 2 27416 9018 -8188 2 27413 9124 -8078 2 27398 9169 -8081 2 27360 9306 -8052 2 27364 9389 -7939 2 27365 9480 -7827 2 27348 9610 -7730 2 27328 9720 -7662 2 27271 9858 -7686 2 27217 9995 -7702 2 27162 10125 -7726 2 27096 10245 -7802 2 27038 10315 -7907 2 26966 10424 -8009 2 26909 10555 -8030 2 26852 10663 -8078 2 26816 10734 -8104 2 26771 10746 -8236 2 26710 10809 -8350 2 26651 10904 -8415 2 26579 10982 -8541 2 26533 11006 -8652 2 26471 11049 -8786 2 26430 11097 -8848 2 26396 11157 -8875 2 26382 11095 -8993 2 26372 10998 -9142 2 26336 10976 -9271 2 26272 11041 -9374 2 26274 10937 -9490 2 26351 10796 -9438 2 26396 10656 -9471 2 26420 10536 -9538 2 26437 10421 -9615 2 26379 10409 -9788 2 26322 10533 -9810 2 26304 10644 -9736 2 26278 10765 -9673 2 26205 10888 -9734 2 26189 10901 -9762 2 26143 10918 -9867 2 26065 10976 -10006 2 26015 10992 -10119 2 25953 11020 -10246 2 25878 11097 -10353 2 25815 11148 -10456 2 25753 11154 -10600 2 25724 11203 -10618 2 25692 11167 -10734 2 25622 11220 -10845 2 25549 11298 -10938 2 25493 11377 -10985 2 25480 11442 -10947 2 25450 11375 -11086 2 25392 11536 -11053 2 25373 11655 -10971 2 25298 11767 -11026 2 25296 11734 -11065 2 25330 11630 -11097 2 25335 11499 -11220 2 25334 11419 -11305 2 25279 11445 -11401 2 25225 11499 -11466 2 25185 11544 -11509 2 25132 11574 -11594 2 25100 11571 -11667 2 25013 11634 -11789 2 24963 11625 -11905 2 24898 11644 -12021 2 24827 11661 -12151 2 24747 11707 -12268 2 24649 11823 -12355 2 24621 11874 -12361 2 24607 11905 -12360 2 24516 12004 -12445 2 24442 12036 -12559 2 24339 12123 -12674 2 24260 12196 -12756 2 24178 12278 -12832 2 24128 12369 -12840 2 24115 12440 -12794 2 24037 12489 -12893 2 23960 12494 -13032 2 23878 12605 -13076 2 23795 12676 -13158 2 23731 12771 -13181 2 23669 12819 -13247 2 23625 12921 -13225 2 23585 12906 -13310 2 23557 12900 -13366 2 23499 13041 -13331 2 23460 13142 -13301 2 23506 13176 -13186 2 23379 13263 -13323 2 23325 13348 -13333 2 23269 13491 -13287 2 23222 13471 -13390 2 23237 13427 -13406 2 23164 13532 -13428 2 23074 13644 -13470 2 23010 13739 -13483 2 22895 13858 -13557 2 22816 13980 -13563 2 22775 14082 -13527 2 22770 14103 -13514 2 22687 14125 -13630 2 22593 14209 -13699 2 22492 14259 -13812 2 22472 14398 -13702 2 22473 14433 -13662 2 22371 14490 -13768 2 22342 14591 -13709 2 22265 14665 -13755 2 22207 14677 -13836 2 22175 14791 -13766 2 22242 14780 -13668 2 22083 14913 -13782 2 22063 14955 -13769 2 22113 15007 -13631 2 22121 15103 -13512 2 22184 15121 -13388 2 22300 15052 -13272 2 22331 15105 -13159 2 22360 15133 -13077 2 22234 15168 -13251 2 22141 15249 -13314 2 22036 15322 -13404 2 21937 15381 -13497 2 21851 15437 -13574 2 21817 15570 -13475 2 21842 15646 -13347 2 21852 15736 -13224 2 21892 15792 -13089 2 21896 15866 -12994 2 21969 15875 -12858 2 22045 15880 -12721 2 22050 15979 -12589 2 22014 16017 -12604 2 22025 15893 -12740 2 21953 15901 -12853 2 21869 15930 -12960 2 21845 15852 -13095 2 21783 15831 -13225 2 21732 15789 -13358 2 21662 15806 -13451 2 21650 15927 -13327 2 21657 16005 -13222 2 21644 16106 -13119 2 21677 16180 -12974 2 21615 16301 -12925 2 21574 16422 -12841 2 21541 16536 -12750 2 21505 16650 -12662 2 21461 16767 -12581 2 21417 16888 -12494 2 21436 16959 -12364 2 21474 17011 -12228 2 21489 17090 -12089 2 21490 17149 -12004 2 21396 17257 -12017 2 21292 17362 -12051 2 21177 17463 -12107 2 21086 17533 -12165 2 20981 17630 -12205 2 20917 17705 -12208 2 20851 17695 -12335 2 20748 17800 -12356 2 20666 17881 -12376 2 20530 17943 -12513 2 20454 17975 -12591 2 20329 18033 -12710 2 20282 18009 -12819 2 20191 18080 -12861 2 20097 18204 -12834 2 20155 18256 -12668 2 20229 18244 -12568 2 20293 18269 -12427 2 20332 18325 -12280 2 20355 18390 -12145 2 20452 18359 -12027 2 20540 18298 -11970 2 20669 18200 -11897 2 20771 18118 -11845 2 20851 18112 -11714 2 20876 18171 -11577 2 20802 18289 -11522 2 20718 18397 -11503 2 20680 18506 -11397 2 20739 18516 -11272 2 20804 18530 -11128 2 20828 18581 -10997 2 20806 18673 -10882 2 20732 18785 -10830 2 20627 18894 -10843 2 20526 18961 -10917 2 20489 18918 -11060 2 20387 18951 -11190 2 20322 18970 -11276 2 20189 19094 -11307 2 20083 19191 -11329 2 19977 19259 -11401 2 19872 19312 -11496 2 19762 19366 -11594 2 19656 19453 -11628 2 19522 19554 -11685 2 19420 19631 -11726 2 19342 19635 -11848 2 19271 19630 -11970 2 19271 19539 -12119 2 19331 19442 -12179 2 19444 19346 -12151 2 19552 19264 -12109 2 19675 19171 -12057 2 19763 19080 -12057 2 19744 19003 -12209 2 19880 18892 -12162 2 19973 18813 -12130 2 19829 18871 -12277 2 19716 18933 -12362 2 19601 19023 -12406 2 19490 19084 -12487 2 19377 19140 -12578 2 19271 19186 -12669 2 19174 19217 -12770 2 19081 19220 -12904 2 18976 19264 -12993 2 18975 19159 -13148 2 18913 19122 -13290 2 18886 19062 -13415 2 18980 18941 -13453 2 19086 18832 -13457 2 19085 18771 -13542 2 19078 18743 -13593 2 19198 18703 -13477 2 19316 18581 -13477 2 19368 18515 -13494 2 19339 18450 -13624 2 19304 18391 -13752 2 19195 18442 -13835 2 19136 18394 -13982 2 19035 18393 -14119 2 19059 18326 -14174 2 19124 18178 -14277 2 19161 18091 -14339 2 19200 18017 -14378 2 19287 18028 -14248 2 19375 17944 -14235 2 19401 17802 -14377 2 19458 17684 -14446 2 19474 17591 -14537 2 19593 17459 -14536 2 19705 17343 -14524 2 19779 17228 -14560 2 19804 17119 -14654 2 19870 17033 -14665 2 19863 16948 -14773 2 19766 17000 -14843 2 19655 17045 -14937 2 19618 17024 -15010 2 19548 17102 -15013 2 19467 17159 -15053 2 19355 17196 -15156 2 19265 17189 -15277 2 19159 17257 -15334 2 19062 17252 -15460 2 18936 17347 -15508 2 18850 17445 -15504 2 18749 17577 -15476 2 18721 17666 -15409 2 18658 17796 -15335 2 18580 17917 -15288 2 18516 18040 -15222 2 18473 18155 -15137 2 18455 18262 -15031 2 18440 18365 -14922 2 18438 18462 -14805 2 18420 18566 -14698 2 18391 18674 -14596 2 18378 18772 -14486 2 18405 18848 -14352 2 18423 18927 -14226 2 18420 19012 -14116 2 18327 19128 -14080 2 18229 19216 -14088 2 18110 19281 -14151 2 18002 19312 -14248 2 17877 19384 -14306 2 17754 19454 -14364 2 17632 19540 -14397 2 17512 19603 -14459 2 17415 19679 -14473 2 17327 19800 -14414 2 17270 19907 -14333 2 17154 20008 -14333 2 17036 20097 -14349 2 16913 20174 -14386 2 16800 20214 -14463 2 16683 20314 -14457 2 16559 20355 -14542 2 16452 20440 -14545 2 16325 20535 -14553 2 16264 20544 -14609 2 16240 20520 -14670 2 16176 20528 -14728 2 16226 20418 -14827 2 16138 20391 -14959 2 16075 20356 -15074 2 15930 20394 -15176 2 15812 20432 -15249 2 15680 20499 -15294 2 15549 20558 -15349 2 15420 20625 -15390 2 15290 20708 -15408 2 15169 20788 -15420 2 15063 20878 -15402 2 14942 20968 -15396 2 14813 21040 -15425 2 14690 21129 -15420 2 14565 21213 -15424 2 14439 21298 -15425 2 14307 21372 -15445 2 14178 21454 -15450 2 14050 21534 -15456 2 13925 21619 -15450 2 13811 21711 -15423 2 13697 21802 -15397 2 13588 21902 -15352 2 13469 21990 -15331 2 13338 22069 -15331 2 13222 22162 -15297 2 13102 22251 -15272 2 12968 22327 -15275 2 12836 22401 -15278 2 12718 22485 -15253 2 12621 22585 -15187 2 12550 22664 -15128 2 12448 22764 -15062 2 12343 22870 -14987 2 12280 22963 -14897 2 12205 23037 -14843 2 12144 23145 -14726 2 12065 23238 -14643 2 11955 23327 -14592 2 11850 23427 -14518 2 11743 23507 -14475 2 11611 23582 -14460 2 11502 23664 -14413 2 11466 23725 -14340 2 11442 23801 -14233 2 11363 23892 -14144 2 11382 23959 -14015 2 11364 23980 -13994 2 11258 23991 -14060 2 11217 24064 -13968 2 11249 24117 -13850 2 11297 24184 -13695 2 11283 24262 -13567 2 11306 24328 -13427 2 11374 24345 -13340 2 11490 24338 -13252 2 11582 24325 -13196 2 11676 24228 -13292 2 11797 24142 -13341 2 11833 24150 -13295 2 11749 24223 -13238 2 11947 24142 -13207 2 12035 24157 -13100 2 11896 24256 -13045 2 11881 24313 -12950 2 11833 24357 -12911 2 11965 24292 -12912 2 12066 24221 -12953 2 12122 24240 -12863 2 12013 24335 -12787 2 11929 24418 -12707 2 11929 24462 -12621 2 12056 24452 -12520 2 12142 24466 -12410 2 12172 24520 -12273 2 12033 24600 -12250 2 11896 24646 -12292 2 11761 24707 -12299 2 11625 24765 -12311 2 11489 24816 -12337 2 11353 24870 -12354 2 11211 24934 -12354 2 11068 25005 -12339 2 10949 25076 -12301 2 10810 25145 -12284 2 10680 25197 -12290 2 10531 25255 -12300 2 10390 25312 -12301 2 10248 25369 -12303 2 10123 25424 -12294 2 10008 25501 -12228 2 9870 25561 -12215 2 9725 25607 -12234 2 9590 25670 -12209 2 9459 25733 -12179 2 9314 25779 -12194 2 9170 25808 -12242 2 9044 25817 -12317 2 8913 25819 -12406 2 8810 25817 -12484 2 8665 25825 -12569 2 8592 25800 -12670 2 8533 25775 -12761 2 8408 25826 -12741 2 8297 25805 -12856 2 8187 25795 -12946 2 8043 25815 -12996 2 7950 25788 -13107 2 7863 25842 -13053 2 7718 25909 -13006 2 7596 25909 -13078 2 7500 25878 -13195 2 7430 25854 -13280 2 7267 25855 -13369 2 7217 25796 -13509 2 7205 25764 -13576 2 7363 25753 -13512 2 7443 25704 -13561 2 7338 25680 -13663 2 7184 25712 -13684 2 7054 25706 -13763 2 6899 25759 -13743 2 6788 25758 -13800 2 6653 25756 -13870 2 6503 25766 -13922 2 6450 25829 -13829 2 6572 25846 -13740 2 6605 25873 -13673 2 6518 25946 -13576 2 6407 26011 -13504 2 6280 26073 -13445 2 6138 26122 -13415 2 6002 26174 -13374 2 5891 26241 -13293 2 5749 26295 -13248 2 5653 26363 -13155 2 5508 26414 -13113 2 5370 26435 -13128 2 5236 26438 -13176 2 5093 26456 -13195 2 4981 26442 -13267 2 4912 26423 -13331 2 4785 26440 -13342 2 4891 26352 -13478 2 4964 26296 -13560 2 4947 26230 -13693 2 4933 26163 -13826 2 4777 26206 -13800 2 4648 26262 -13738 2 4521 26315 -13677 2 4400 26362 -13627 2 4235 26403 -13600 2 4135 26408 -13621 2 4096 26491 -13471 2 4029 26564 -13346 2 3959 26620 -13256 2 3801 26645 -13250 2 3663 26646 -13287 2 3548 26614 -13384 2 3529 26592 -13433 2 3699 26592 -13385 2 3828 26540 -13453 2 3877 26468 -13580 2 3946 26401 -13690 2 3983 26338 -13801 2 4064 26275 -13896 2 4130 26214 -13992 2 4261 26178 -14020 2 4430 26135 -14048 2 4580 26088 -14087 2 4670 26023 -14177 2 4798 25970 -14231 2 4918 25909 -14302 2 5056 25861 -14341 2 5179 25800 -14406 2 5311 25742 -14462 2 5402 25669 -14558 2 5536 25598 -14633 2 5651 25547 -14677 2 5790 25494 -14714 2 5909 25442 -14757 2 6068 25422 -14727 2 6213 25385 -14730 2 6298 25355 -14747 2 6334 25271 -14875 2 6451 25192 -14958 2 6573 25134 -15002 2 6679 25085 -15038 2 6788 24991 -15144 2 6870 24909 -15242 2 6945 24827 -15343 2 7010 24742 -15450 2 7072 24657 -15558 2 7113 24570 -15675 2 7146 24484 -15795 2 7176 24395 -15918 2 7196 24309 -16041 2 7221 24221 -16161 2 7254 24132 -16280 2 7286 24042 -16398 2 7320 23952 -16515 2 7342 23862 -16634 2 7330 23789 -16744 2 7359 23686 -16877 2 7391 23593 -16993 2 7441 23498 -17102 2 7455 23407 -17221 2 7425 23323 -17346 2 7230 23411 -17310 2 7109 23481 -17266 2 6972 23546 -17233 2 6853 23625 -17173 2 6755 23712 -17091 2 6699 23794 -17000 2 6642 23877 -16904 2 6583 23950 -16824 2 6378 24004 -16826 2 6227 24031 -16844 2 6149 24036 -16867 2 6127 24137 -16729 2 6090 24227 -16612 2 6002 24311 -16521 2 5875 24374 -16474 2 5740 24430 -16439 2 5601 24436 -16477 2 5461 24437 -16524 2 5327 24507 -16463 2 5332 24588 -16341 2 5349 24666 -16216 2 5308 24752 -16099 2 5219 24831 -16006 2 5121 24906 -15921 2 5002 24970 -15859 2 4902 24989 -15860 2 4919 24894 -16003 2 4787 24944 -15965 2 4767 25031 -15834 2 4814 25087 -15732 2 4832 25155 -15616 2 4803 25241 -15486 2 4697 25307 -15412 2 4631 25380 -15310 2 4761 25412 -15216 2 4864 25382 -15235 2 4911 25459 -15090 2 4841 25538 -14979 2 4742 25609 -14889 2 4614 25672 -14821 2 4500 25734 -14748 2 4413 25804 -14653 2 4358 25882 -14530 2 4261 25950 -14437 2 4140 25974 -14430 2 3993 25983 -14454 2 3888 25952 -14539 2 3808 26017 -14443 2 3640 26063 -14404 2 3540 26082 -14395 2 3593 25981 -14563 2 3556 25952 -14624 2 3429 26017 -14539 2 3308 26075 -14462 2 3174 26104 -14440 2 3018 26129 -14428 2 2874 26127 -14461 2 2737 26124 -14493 2 2634 26057 -14631 2 2599 25995 -14748 2 2505 25986 -14780 2 2426 26075 -14636 2 2323 26117 -14578 2 2176 26169 -14507 2 2045 26208 -14455 2 1951 26258 -14378 2 1841 26303 -14309 2 1753 26344 -14246 2 1608 26402 -14155 2 1473 26430 -14116 2 1324 26463 -14071 2 1170 26505 -14004 2 1060 26534 -13957 2 918 26567 -13905 2 796 26610 -13830 2 708 26646 -13765 2 660 26672 -13717 2 581 26628 -13807 2 430 26610 -13847 2 291 26581 -13905 2 200 26591 -13888 2 115 26650 -13776 2 152 26720 -13639 2 184 26781 -13518 2 263 26823 -13434 2 320 26866 -13345 2 336 26962 -13150 2 372 27024 -13021 2 442 27033 -13002 2 579 27073 -12912 2 630 27123 -12804 2 799 27106 -12831 2 835 27117 -12805 2 896 27153 -12725 2 1051 27132 -12757 2 1134 27126 -12762 2 903 27160 -12709 2 767 27155 -12728 2 670 27172 -12699 2 742 27201 -12631 2 587 27168 -12711 2 496 27126 -12804 2 333 27111 -12840 2 209 27134 -12794 2 86 27168 -12723 2 -26 27215 -12623 2 -100 27268 -12509 2 -124 27327 -12378 2 -47 27384 -12252 2 -96 27438 -12131 2 -195 27467 -12062 2 -303 27461 -12074 2 -249 27397 -12220 2 -316 27334 -12359 2 -395 27295 -12443 2 -545 27301 -12423 2 -684 27317 -12382 2 -832 27292 -12428 2 -908 27240 -12537 2 -951 27178 -12668 2 -1080 27146 -12726 2 -1239 27116 -12774 2 -1344 27070 -12861 2 -1468 27064 -12861 2 -1498 27072 -12839 2 -1571 27048 -12882 2 -1628 27092 -12781 2 -1589 27158 -12645 2 -1691 27220 -12499 2 -1661 27252 -12432 2 -1650 27301 -12327 2 -1621 27328 -12270 2 -1772 27301 -12309 2 -1889 27325 -12239 2 -1873 27352 -12179 2 -2011 27347 -12169 2 -2076 27402 -12033 2 -2109 27437 -11949 2 -1987 27472 -11888 2 -1866 27521 -11794 2 -1751 27565 -11708 2 -1638 27606 -11629 2 -1480 27612 -11635 2 -1356 27615 -11643 2 -1173 27635 -11616 2 -1150 27620 -11654 2 -1230 27560 -11787 2 -1248 27514 -11892 2 -1238 27482 -11967 2 -1152 27501 -11932 2 -1070 27554 -11817 2 -1049 27615 -11676 2 -1033 27679 -11525 2 -957 27712 -11450 2 -855 27771 -11316 2 -726 27804 -11243 2 -588 27839 -11163 2 -477 27867 -11100 2 -372 27896 -11031 2 -251 27937 -10930 2 -136 27977 -10828 2 -54 27995 -10784 2 816 28018 -10693 2 926 28058 -10579 2 1003 28081 -10509 2 1171 28109 -10418 2 1304 28129 -10348 2 1418 28159 -10250 2 1565 28168 -10204 2 1475 28195 -10142 2 1616 28208 -10085 2 1689 28193 -10115 2 1742 28142 -10247 2 1723 28108 -10343 2 1682 28057 -10488 2 1697 28008 -10615 2 1792 27974 -10688 2 1961 27979 -10646 2 2013 28028 -10506 2 2137 28056 -10407 2 2154 28109 -10260 2 2223 28137 -10167 2 2394 28104 -10220 2 2538 28108 -10172 2 2678 28116 -10114 2 2809 28128 -10047 2 2922 28139 -9983 2 3072 28133 -9956 2 3210 28119 -9951 2 3348 28077 -10022 2 3397 28026 -10149 2 3457 27972 -10276 2 3533 27943 -10329 2 3462 28022 -10139 2 3448 28074 -9999 2 3449 28124 -9855 2 3559 28149 -9746 2 3531 28201 -9605 2 3450 28244 -9506 2 3442 28293 -9362 2 3490 28332 -9226 2 3583 28358 -9110 2 3696 28375 -9010 2 3831 28380 -8938 2 3981 28377 -8882 2 4094 28370 -8853 2 4256 28357 -8820 2 4402 28342 -8795 2 4542 28339 -8733 2 4594 28367 -8613 2 4587 28416 -8457 2 4701 28423 -8370 2 4745 28433 -8310 2 4759 28471 -8170 2 4800 28496 -8059 2 4650 28527 -8038 2 4680 28562 -7894 2 4774 28579 -7774 2 4900 28583 -7680 2 5039 28555 -7696 2 5174 28514 -7758 2 5325 28485 -7762 2 5350 28504 -7674 2 5209 28539 -7643 2 5151 28552 -7634 2 5165 28526 -7720 2 5038 28575 -7622 2 5193 28575 -7518 2 5264 28580 -7448 2 5056 28587 -7565 2 5010 28597 -7558 2 5101 28617 -7417 2 5199 28630 -7302 2 5300 28639 -7192 2 5414 28643 -7090 2 5510 28653 -6973 2 5605 28654 -6894 2 5714 28614 -6970 2 5847 28607 -6889 2 5964 28566 -6957 2 5929 28552 -7046 2 6049 28510 -7112 2 6145 28452 -7260 2 6234 28452 -7186 2 6299 28462 -7087 2 6429 28418 -7148 2 6500 28405 -7133 2 6525 28446 -6945 2 6567 28468 -6816 2 6689 28457 -6744 2 6829 28427 -6728 2 6911 28444 -6573 2 6900 28480 -6426 2 6911 28499 -6330 2 7094 28438 -6400 2 7206 28395 -6466 2 7361 28344 -6513 2 7445 28340 -6436 2 7461 28367 -6298 2 7447 28398 -6173 2 7372 28451 -6018 2 7292 28487 -5944 2 7260 28510 -5870 2 7245 28545 -5716 2 7220 28580 -5575 2 7292 28580 -5476 2 7401 28526 -5609 2 7506 28481 -5703 2 7556 28460 -5737 2 7428 28524 -5584 2 7355 28572 -5437 2 7385 28589 -5302 2 7370 28621 -5153 2 7388 28642 -5005 2 7441 28652 -4869 2 7469 28671 -4711 2 7506 28682 -4582 2 7571 28686 -4446 2 7618 28684 -4379 2 7613 28720 -4147 2 7487 28764 -4071 2 7525 28778 -3895 2 7561 28789 -3748 2 7620 28791 -3607 2 7724 28777 -3496 2 7847 28750 -3448 2 7985 28708 -3480 2 8172 28646 -3555 2 8130 28664 -3501 2 7989 28708 -3472 2 7871 28750 -3391 2 7740 28791 -3339 2 7693 28815 -3240 2 7793 28803 -3113 2 7726 28834 -2988 2 7795 28831 -2834 2 7906 28797 -2863 2 7903 28788 -2962 2 8050 28760 -2841 2 8150 28740 -2760 2 8240 28722 -2675 2 8317 28714 -2515 2 8408 28694 -2440 2 8538 28660 -2383 2 8526 28667 -2353 2 8379 28707 -2392 2 8253 28738 -2447 2 8113 28773 -2506 2 8021 28789 -2615 2 7888 28821 -2667 2 7750 28852 -2740 2 7622 28884 -2765 2 7483 28913 -2834 2 7352 28937 -2927 2 7217 28966 -2983 2 7077 28995 -3034 2 6922 29033 -3025 2 6854 29062 -2905 2 6802 29076 -2879 2 6800 29066 -2984 2 6673 29103 -2912 2 6600 29131 -2793 2 6520 29163 -2651 2 6438 29193 -2511 2 6467 29198 -2375 2 6518 29199 -2226 2 6609 29185 -2131 2 6655 29184 -2007 2 6468 29227 -1984 2 6470 29237 -1826 2 6438 29251 -1714 2 6261 29286 -1770 2 6201 29309 -1584 2 6284 29298 -1453 2 6419 29273 -1376 2 6567 29243 -1315 2 6702 29213 -1302 2 6844 29177 -1359 2 6888 29165 -1403 2 6909 29168 -1219 2 6972 29157 -1127 2 7119 29117 -1234 2 7263 29082 -1219 2 7465 29028 -1284 2 7392 29049 -1230 2 7269 29081 -1204 2 7120 29118 -1198 2 7088 29131 -1068 2 7194 29110 -941 2 7245 29101 -811 2 7218 29109 -747 2 7159 29126 -656 2 7192 29121 -521 2 7269 29103 -426 2 7377 29077 -296 2 7432 29064 -161 2 7480 29053 -14 2 7546 29035 114 2 7649 29008 218 2 7734 28984 352 2 7881 28943 416 2 7900 28937 484 2 7915 28932 539 2 8044 28898 434 2 8070 28890 465 2 8095 28882 535 2 8231 28846 423 2 8360 28809 378 2 8463 28777 481 2 8543 28752 601 2 8675 28714 520 2 8696 28707 523 2 8553 28748 614 2 8435 28785 530 2 8331 28816 493 2 8368 28801 686 2 8369 28797 834 2 8381 28789 986 2 8364 28788 1139 2 8367 28780 1293 2 8422 28759 1407 2 8558 28717 1440 2 8696 28677 1410 2 8839 28632 1444 2 8969 28594 1393 2 9053 28574 1259 2 9194 28531 1213 2 9293 28503 1098 2 9432 28459 1068 2 9565 28412 1130 2 9691 28369 1134 2 9846 28317 1102 2 9987 28267 1111 2 10054 28238 1240 2 9837 28316 1192 2 9746 28346 1241 2 9893 28290 1338 2 9968 28263 1362 2 9760 28337 1316 2 9617 28387 1302 2 9509 28427 1216 2 9387 28471 1129 2 9318 28490 1224 2 9298 28489 1377 2 9154 28531 1472 2 9063 28557 1541 2 8958 28584 1651 2 8902 28593 1793 2 8933 28574 1934 2 9017 28546 1958 2 9123 28512 1968 2 9025 28533 2099 2 9055 28514 2233 2 9203 28466 2236 2 9320 28435 2147 2 9398 28418 2030 2 9520 28382 1956 2 9589 28360 1942 2 9451 28391 2157 2 9391 28401 2276 2 9313 28417 2398 2 9198 28455 2394 2 9047 28505 2376 2 8923 28549 2305 2 8799 28592 2251 2 8655 28637 2237 2 8591 28651 2304 2 8770 28594 2334 2 8895 28550 2401 2 8947 28522 2538 2 9010 28491 2664 2 9136 28442 2759 2 9280 28398 2732 2 9425 28351 2720 2 9569 28305 2694 2 9691 28257 2762 2 9798 28211 2857 2 9929 28158 2921 2 10065 28109 2932 2 10201 28057 2960 2 10290 28029 2912 2 10326 28031 2760 2 10310 28051 2612 2 10396 28032 2482 2 10500 28002 2380 2 10611 27965 2312 2 10751 27912 2311 2 10871 27864 2324 2 10975 27814 2431 2 11104 27765 2416 2 11177 27746 2283 2 11218 27733 2246 2 11179 27734 2425 2 11050 27778 2507 2 10914 27835 2467 2 10785 27888 2440 2 10659 27935 2450 2 10517 27985 2503 2 10454 27998 2615 2 10462 27980 2764 2 10507 27949 2907 2 10643 27892 2966 2 10785 27839 2946 2 10923 27782 2969 2 11025 27732 3062 2 11107 27686 3183 2 11233 27627 3249 2 11311 27582 3364 2 11354 27547 3504 2 11411 27508 3623 2 11485 27462 3731 2 11396 27481 3861 2 11350 27479 4008 2 11262 27498 4127 2 11149 27529 4226 2 11056 27575 4167 2 11128 27567 4030 2 11230 27539 3938 2 11241 27557 3777 2 11145 27606 3703 2 11061 27657 3569 2 10967 27708 3465 2 10888 27754 3341 2 10781 27805 3263 2 10649 27861 3217 2 10545 27912 3117 2 10402 27959 3175 2 10270 28003 3223 2 10132 28057 3184 2 10005 28108 3139 2 9867 28162 3085 2 9725 28215 3059 2 9604 28262 3001 2 9478 28311 2942 2 9339 28361 2906 2 9204 28402 2931 2 9058 28447 2955 2 8951 28491 2855 2 8836 28535 2769 2 8712 28580 2695 2 8564 28629 2655 2 8439 28660 2721 2 8356 28674 2829 2 8308 28673 2976 2 8266 28672 3099 2 8382 28624 3229 2 8509 28577 3305 2 8633 28531 3384 2 8745 28486 3477 2 8819 28447 3601 2 8860 28416 3747 2 8955 28373 3846 2 9075 28332 3863 2 9200 28293 3856 2 9323 28243 3926 2 9433 28198 3984 2 9544 28145 4092 2 9622 28122 4071 2 9744 28098 3943 2 9887 28046 3962 2 10033 28000 3914 2 10106 27981 3868 2 10234 27920 3969 2 10300 27877 4096 2 10140 27925 4171 2 9992 27970 4226 2 9872 27999 4314 2 9752 28028 4395 2 9630 28053 4502 2 9490 28095 4541 2 9368 28121 4629 2 9262 28139 4736 2 9175 28146 4860 2 9074 28159 4975 2 9054 28143 5097 2 9109 28105 5207 2 9257 28054 5225 2 9381 28011 5233 2 9463 27955 5382 2 9473 27929 5496 2 9535 27888 5600 2 9416 27921 5637 2 9303 27976 5547 2 9210 28003 5569 2 9214 27971 5718 2 9210 27939 5881 2 9150 27931 6012 2 9065 27934 6124 2 9030 27913 6271 2 9071 27866 6420 2 8994 27864 6533 2 8907 27884 6571 2 8817 27940 6451 2 8729 27988 6361 2 8721 28005 6297 2 8668 27985 6459 2 8658 27954 6606 2 8713 27920 6675 2 8699 27905 6756 2 8625 27898 6878 2 8581 27876 7022 2 8579 27833 7193 2 8565 27804 7321 2 8546 27770 7470 2 8505 27745 7608 2 8531 27707 7717 2 8616 27649 7828 2 8669 27598 7948 2 8599 27579 8091 2 8531 27581 8155 2 8372 27625 8172 2 8237 27667 8166 2 8126 27714 8118 2 8112 27760 7973 2 8189 27778 7832 2 8192 27804 7736 2 8064 27853 7692 2 7914 27902 7671 2 7773 27926 7728 2 7673 27922 7842 2 7583 27919 7938 2 7805 27836 8014 2 7867 27792 8105 2 7941 27737 8223 2 8031 27668 8365 2 8173 27627 8365 2 8290 27566 8447 2 8356 27512 8559 2 8420 27453 8686 2 8459 27415 8766 2 8345 27439 8801 2 8185 27494 8780 2 8069 27501 8865 2 8048 27451 9037 2 8018 27413 9178 2 7974 27380 9314 2 7956 27336 9457 2 7971 27286 9589 2 8096 27228 9650 2 8230 27173 9689 2 8317 27108 9797 2 8209 27101 9908 2 8038 27131 9965 2 7916 27139 10041 2 7755 27191 10025 2 7598 27223 10059 2 7584 27169 10215 2 7684 27115 10282 2 7834 27059 10317 2 7970 27042 10258 2 8091 26966 10362 2 8029 26931 10501 2 7886 26949 10563 2 7748 26987 10567 2 7608 27034 10549 2 7469 27054 10597 2 7335 27118 10528 2 7252 27179 10427 2 7144 27236 10352 2 7067 27288 10267 2 7032 27354 10115 2 6935 27407 10037 2 6782 27452 10020 2 6643 27487 10016 2 6521 27530 9978 2 6376 27578 9939 2 6245 27628 9884 2 6210 27645 9859 2 6347 27623 9833 2 6519 27571 9866 2 6639 27555 9830 2 6765 27532 9810 2 6928 27501 9782 2 7072 27479 9741 2 7209 27467 9675 2 7347 27448 9623 2 7488 27425 9582 2 7610 27422 9494 2 7699 27439 9371 2 7761 27468 9236 2 7788 27507 9093 2 7780 27557 8950 2 7744 27611 8813 2 7647 27665 8727 2 7529 27723 8647 2 7400 27768 8611 2 7276 27803 8606 2 7143 27836 8610 2 6979 27870 8636 2 6872 27890 8656 2 6684 27944 8629 2 6538 27978 8629 2 6388 28012 8632 2 6243 28042 8642 2 6116 28050 8705 2 5971 28064 8760 2 5886 28053 8852 2 5854 28039 8919 2 5748 28084 8846 2 5611 28104 8870 2 5569 28130 8813 2 5642 28141 8732 2 5474 28163 8769 2 5421 28136 8887 2 5263 28151 8935 2 5195 28145 8993 2 5107 28161 8994 2 5004 28195 8944 2 4936 28213 8925 2 5125 28209 8832 2 5188 28243 8686 2 5100 28278 8623 2 4969 28303 8615 2 4810 28329 8623 2 4749 28302 8744 2 4775 28261 8862 2 4790 28233 8943 2 4690 28292 8807 2 4651 28335 8690 2 4603 28370 8600 2 4511 28357 8692 2 4535 28307 8840 2 4488 28285 8933 2 4385 28336 8822 2 4355 28282 9009 2 4351 28237 9150 2 4308 28227 9202 2 4264 28284 9046 2 4261 28339 8874 2 4148 28348 8897 2 4102 28319 9012 2 4082 28277 9152 2 4031 28234 9307 2 4023 28197 9421 2 3881 28224 9400 2 3743 28234 9425 2 3746 28213 9488 2 3845 28186 9526 2 3846 28162 9597 2 3713 28170 9625 2 3662 28136 9744 2 3682 28097 9849 2 3633 28083 9906 2 3614 28146 9734 2 3551 28164 9704 2 3554 28112 9852 2 3527 28106 9881 2 3446 28144 9801 2 3445 28097 9933 2 3486 28069 9999 2 3386 28081 9999 2 3329 28067 10059 2 3251 28017 10220 2 3270 27967 10352 2 3160 27936 10470 2 3197 27904 10542 2 3318 27891 10539 2 3263 27874 10600 2 3144 27869 10651 2 3166 27837 10726 2 3158 27807 10807 2 3030 27841 10756 2 3017 27807 10848 2 2949 27769 10963 2 3053 27744 10998 2 3031 27706 11099 2 2934 27698 11145 2 2944 27667 11220 2 3040 27652 11231 2 2890 27626 11333 2 2801 27585 11455 2 2772 27536 11579 2 2767 27477 11721 2 2869 27452 11755 2 2727 27417 11868 2 2716 27375 11969 2 2699 27314 12110 2 2731 27249 12250 2 2666 27200 12371 2 2550 27175 12451 2 2538 27153 12500 2 2612 27157 12476 2 2580 27092 12625 2 2493 27070 12689 2 2386 27051 12750 2 2312 26998 12875 2 2282 26944 12992 2 2262 26897 13094 2 2365 26857 13157 2 2486 26895 13057 2 2497 26940 12962 2 2580 26955 12914 2 2575 26903 13023 2 2501 26854 13138 2 2376 26817 13237 2 2298 26838 13209 2 2193 26862 13177 2 2128 26826 13261 2 2011 26772 13387 2 1999 26729 13475 2 2002 26709 13514 2 1909 26726 13493 2 1949 26690 13560 2 1762 26722 13522 2 1694 26687 13599 2 1836 26668 13618 2 1880 26662 13625 2 1773 26631 13698 2 1603 26636 13709 2 1565 26607 13770 2 1703 26572 13821 2 1722 26542 13877 2 1583 26572 13836 2 1557 26550 13881 2 1478 26532 13924 2 1468 26512 13963 2 1349 26517 13965 2 1276 26502 14000 2 1327 26468 14060 2 1462 26459 14064 2 1550 26446 14079 2 1346 26452 14087 2 1288 26398 14194 2 1329 26336 14305 2 1317 26276 14416 2 1482 26279 14394 2 1623 26288 14364 2 1704 26297 14338 2 1825 26302 14313 2 1871 26312 14290 2 1806 26241 14427 2 1693 26256 14414 2 1528 26262 14422 2 1391 26252 14453 2 1320 26213 14530 2 1364 26158 14626 2 1420 26106 14713 2 1360 26055 14808 2 1436 26047 14816 2 1468 26040 14825 2 1526 26010 14871 2 1617 26084 14731 2 1750 26098 14691 2 1649 26040 14806 2 1533 25966 14947 2 1555 25930 15008 2 1591 25921 15020 2 1463 25882 15099 2 1418 25820 15210 2 1514 25816 15207 2 1603 25840 15157 2 1672 25856 15121 2 1645 25788 15240 2 1637 25715 15365 2 1689 25701 15382 2 1526 25696 15408 2 1515 25616 15541 2 1628 25560 15622 2 1792 25519 15670 2 1885 25475 15732 2 2005 25448 15760 2 2144 25460 15722 2 2258 25492 15654 2 2371 25548 15546 2 2462 25623 15408 2 2533 25673 15313 2 2618 25721 15217 2 2747 25744 15155 2 2763 25823 15018 2 2742 25883 14918 2 2787 25922 14842 2 2830 25820 15010 2 2930 25760 15095 2 3016 25718 15149 2 3038 25627 15298 2 3115 25545 15419 2 3217 25506 15463 2 3247 25404 15623 2 3299 25336 15723 2 3378 25260 15828 2 3459 25185 15929 2 3559 25113 16021 2 3666 25031 16124 2 3646 24951 16253 2 3689 24874 16361 2 3786 24796 16456 2 3817 24705 16586 2 3969 24682 16584 2 4108 24697 16529 2 4193 24734 16451 2 4147 24818 16335 2 4229 24884 16214 2 4322 24918 16138 2 4462 24920 16096 2 4582 24927 16052 2 4609 25021 15897 2 4642 25092 15775 2 4632 25177 15642 2 4615 25259 15513 2 4593 25336 15395 2 4557 25411 15282 2 4557 25482 15163 2 4515 25560 15043 2 4431 25611 14981 2 4413 25619 14973 2 4571 25630 14906 2 4663 25674 14802 2 4722 25717 14708 2 4831 25767 14584 2 4827 25810 14509 2 4661 25786 14607 2 4526 25804 14618 2 4382 25834 14608 2 4295 25851 14604 2 4462 25863 14532 2 4581 25863 14495 2 4583 25894 14440 2 4732 25820 14524 2 4813 25849 14446 2 4887 25912 14306 2 4857 25975 14203 2 4720 26039 14131 2 4602 26095 14066 2 4472 26131 14043 2 4356 26173 14001 2 4292 26248 13879 2 4251 26322 13751 2 4222 26397 13616 2 4232 26446 13517 2 4217 26526 13363 2 4177 26595 13239 2 4253 26641 13121 2 4246 26698 13008 2 4315 26739 12900 2 4386 26786 12778 2 4471 26840 12634 2 4564 26876 12523 2 4639 26907 12429 2 4687 26968 12278 2 4714 27028 12136 2 4721 27082 12013 2 4623 27137 11926 2 4634 27199 11780 2 4601 27262 11645 2 4650 27307 11519 2 4649 27326 11475 2 4692 27337 11430 2 4737 27368 11338 2 4873 27360 11300 2 5015 27362 11232 2 5136 27355 11194 2 5304 27299 11253 2 5373 27236 11372 2 5427 27171 11501 2 5325 27142 11617 2 5306 27083 11763 2 5274 27029 11901 2 5239 26975 12039 2 5189 26925 12170 2 5132 26884 12284 2 5098 26829 12419 2 5046 26780 12544 2 4985 26750 12633 2 4964 26685 12778 2 4988 26619 12906 2 5066 26560 12996 2 5124 26484 13127 2 5222 26414 13231 2 5261 26356 13329 2 5296 26270 13484 2 5325 26203 13603 2 5420 26133 13701 2 5546 26101 13711 2 5707 26058 13727 2 5825 26030 13729 2 5913 25966 13814 2 5924 25940 13857 2 6004 25978 13751 2 6160 25987 13664 2 6249 26015 13571 2 6350 26036 13483 2 6475 26067 13363 2 6562 26093 13269 2 6653 26107 13198 2 6796 26113 13112 2 6911 26120 13038 2 7047 26132 12941 2 7179 26056 13020 2 7319 26027 13001 2 7453 26007 12965 2 7515 25962 13020 2 7325 25971 13110 2 7250 25933 13226 2 7150 25908 13329 2 7137 25841 13465 2 7006 25833 13548 2 6861 25849 13593 2 6715 25870 13625 2 6578 25876 13680 2 6471 25852 13777 2 6354 25843 13848 2 6249 25810 13958 2 6151 25769 14075 2 6172 25703 14186 2 6245 25635 14278 2 6342 25547 14392 2 6500 25522 14366 2 6566 25441 14479 2 6601 25362 14601 2 6669 25281 14710 2 6685 25207 14831 2 6596 25159 14951 2 6453 25188 14964 2 6344 25261 14887 2 6210 25322 14840 2 6103 25358 14823 2 5979 25321 14937 2 5931 25257 15063 2 5947 25177 15191 2 5913 25106 15320 2 5944 25013 15461 2 5974 24940 15566 2 6035 24857 15676 2 6101 24774 15781 2 6175 24687 15887 2 6209 24609 15994 2 6182 24549 16098 2 6075 24587 16080 2 6122 24674 15928 2 6106 24726 15853 2 6072 24607 16051 2 5981 24562 16154 2 5895 24526 16239 2 5884 24440 16372 2 5797 24388 16481 2 5657 24381 16540 2 5535 24438 16497 2 5506 24495 16422 2 5288 24516 16461 2 5158 24495 16535 2 5046 24455 16628 2 4935 24417 16717 2 4872 24361 16817 2 4724 24329 16905 2 4595 24304 16977 2 4469 24272 17055 2 4337 24257 17110 2 4250 24266 17120 2 4440 24208 17154 2 4404 24177 17207 2 4264 24218 17185 2 4161 24299 17095 2 4028 24337 17074 2 3889 24388 17032 2 3795 24384 17059 2 3659 24320 17181 2 3531 24282 17261 2 3440 24260 17309 2 3332 24297 17279 2 3319 24378 17167 2 3120 24391 17185 2 3016 24446 17127 2 2926 24514 17044 2 2876 24554 16996 2 2851 24643 16871 2 2852 24734 16736 2 2894 24798 16634 2 2978 24858 16529 2 3038 24926 16416 2 3134 24977 16319 2 3039 25022 16269 2 2937 25055 16236 2 2891 25163 16077 2 2959 25235 15952 2 2926 25319 15824 2 2897 25347 15785 2 2765 25303 15878 2 2699 25232 16002 2 2579 25199 16074 2 2440 25178 16128 2 2369 25100 16260 2 2441 25075 16287 2 2532 25160 16142 2 2630 25169 16112 2 2720 25159 16113 2 2650 25066 16268 2 2632 25049 16297 2 2540 25078 16268 2 2431 25036 16348 2 2355 24998 16418 2 2368 24944 16497 2 2400 24854 16628 2 2405 24756 16773 2 2489 24717 16819 2 2561 24618 16953 2 2601 24535 17067 2 2676 24459 17164 2 2668 24395 17256 2 2687 24347 17321 2 2750 24268 17421 2 2887 24210 17480 2 2946 24166 17531 2 2736 24224 17484 2 2632 24198 17536 2 2607 24115 17654 2 2505 24138 17637 2 2376 24177 17602 2 2230 24150 17657 2 2234 24070 17766 2 2187 24059 17787 2 2060 24098 17750 2 1913 24086 17782 2 1773 24058 17835 2 1680 23995 17929 2 1553 23941 18012 2 1479 23892 18083 2 1461 23801 18204 2 1415 23716 18318 2 1325 23638 18426 2 1257 23573 18513 2 1273 23528 18570 2 1320 23492 18611 2 1203 23471 18646 2 1331 23433 18685 2 1101 23437 18694 2 966 23396 18753 2 838 23347 18820 2 695 23320 18859 2 556 23279 18915 2 524 23186 19030 2 530 23088 19149 2 495 23028 19221 2 372 22964 19301 2 228 22935 19338 2 93 22888 19394 2 81 22798 19500 2 -71 22746 19560 2 -220 22761 19542 2 -375 22776 19522 2 -461 22860 19422 2 -623 22853 19426 2 -571 22739 19561 2 -539 22648 19667 2 -530 22534 19797 2 -691 22509 19821 2 -824 22513 19811 2 -963 22503 19816 2 -1074 22577 19726 2 -1225 22559 19738 2 -1361 22533 19758 2 -1522 22517 19766 2 -1594 22444 19843 2 -1537 22381 19918 2 -1590 22294 20011 2 -1453 22244 20078 2 -1316 22225 20107 2 -1154 22193 20153 2 -1054 22148 20208 2 -935 22129 20235 2 -844 22054 20320 2 -711 22017 20365 2 -741 21900 20490 2 -674 21806 20593 2 -589 21741 20664 2 -443 21680 20731 2 -399 21576 20840 2 -408 21482 20937 2 -305 21393 21030 2 -253 21294 21131 2 -230 21237 21188 2 -345 21379 21043 2 -416 21376 21045 2 -438 21267 21155 2 -457 21160 21261 2 -443 21082 21339 2 -483 20946 21472 2 -511 20839 21575 2 -543 20733 21676 2 -617 20634 21768 2 -755 20592 21803 2 -901 20592 21798 2 -1044 20625 21761 2 -1186 20609 21769 2 -1337 20643 21727 2 -1476 20640 21721 2 -1648 20618 21730 2 -1793 20627 21709 2 -1938 20651 21674 2 -2076 20674 21640 2 -2224 20697 21603 2 -2383 20684 21599 2 -2530 20680 21585 2 -2678 20675 21573 2 -2819 20725 21506 2 -2947 20740 21475 2 -3086 20698 21496 2 -3148 20619 21563 2 -3359 20574 21573 2 -3482 20518 21608 2 -3514 20430 21686 2 -3437 20341 21781 2 -3384 20265 21860 2 -3386 20172 21946 2 -3431 20046 22054 2 -3433 19944 22146 2 -3431 19829 22249 2 -3409 19721 22348 2 -3436 19606 22446 2 -3444 19552 22491 2 -3527 19366 22639 2 -3573 19268 22715 2 -3639 19160 22796 2 -3722 19058 22868 2 -3786 18974 22927 2 -3830 18855 23018 2 -3811 18762 23097 2 -3685 18815 23075 2 -3624 18854 23052 2 -3746 18723 23139 2 -3699 18660 23197 2 -3590 18650 23223 2 -3628 18498 23338 2 -3629 18377 23433 2 -3648 18263 23519 2 -3697 18146 23602 2 -3679 18079 23657 2 -3510 18094 23671 2 -3357 18069 23711 2 -3224 18075 23725 2 -3082 18129 23703 2 -2925 18142 23713 2 -2841 18123 23738 2 -2720 18037 23818 2 -2650 17970 23876 2 -2620 17835 23980 2 -2541 17721 24073 2 -2414 17657 24133 2 -2286 17690 24121 2 -2194 17791 24056 2 -2054 17841 24031 2 -1916 17880 24014 2 -1793 17936 23981 2 -1642 17947 23984 2 -1491 17939 24000 2 -1343 17950 24000 2 -1191 17937 24018 2 -1057 17973 23997 2 -898 17969 24006 2 -792 18064 23939 2 -723 18176 23856 2 -609 18254 23800 2 -468 18289 23776 2 -335 18326 23750 2 -296 18441 23661 2 -238 18560 23569 2 -148 18648 23500 2 -17 18713 23448 2 44 18799 23379 2 -78 18901 23297 2 -121 19012 23206 2 -108 19123 23115 2 -35 19225 23031 2 52 19318 22952 2 145 19409 22875 2 226 19509 22789 2 303 19569 22737 2 391 19690 22631 2 525 19732 22591 2 672 19765 22559 2 816 19797 22525 2 926 19873 22455 2 1058 19929 22399 2 1182 19988 22340 2 1255 20078 22255 2 1255 20189 22155 2 1199 20302 22054 2 1176 20414 21952 2 1210 20505 21865 2 1330 20578 21789 2 1450 20647 21717 2 1553 20669 21688 2 1721 20621 21721 2 1835 20629 21704 2 1950 20623 21700 2 2078 20550 21757 2 2231 20504 21786 2 2372 20498 21776 2 2516 20552 21709 2 2598 20632 21623 2 2710 20701 21543 2 2831 20751 21480 2 2976 20782 21431 2 3075 20851 21350 2 3155 20935 21255 2 3276 20992 21180 2 3425 20967 21182 2 3559 20916 21210 2 3695 20866 21236 2 3825 20806 21271 2 3877 20701 21364 2 3947 20602 21447 2 4002 20496 21538 2 4071 20421 21597 2 4193 20346 21644 2 4295 20247 21717 2 4436 20203 21730 2 4552 20113 21789 2 4679 20044 21826 2 4784 19956 21883 2 4910 19873 21930 2 5045 19815 21952 2 5168 19787 21949 2 5315 19772 21927 2 5441 19702 21960 2 5546 19614 22012 2 5678 19544 22040 2 5833 19520 22021 2 5907 19403 22104 2 6020 19323 22145 2 6155 19297 22130 2 6262 19218 22169 2 6331 19108 22244 2 6413 19002 22311 2 6473 18888 22391 2 6499 18784 22471 2 6421 18707 22557 2 6398 18593 22658 2 6372 18494 22746 2 6487 18438 22759 2 6570 18503 22682 2 6638 18596 22586 2 6691 18687 22495 2 6690 18799 22402 2 6818 18847 22323 2 6867 18912 22253 2 6816 19034 22164 2 6688 19112 22136 2 6563 19183 22112 2 6571 19300 22008 2 6610 19403 21905 2 6696 19479 21811 2 6800 19446 21809 2 6964 19401 21797 2 7078 19330 21823 2 7167 19237 21877 2 7264 19249 21834 2 7254 19367 21732 2 7141 19461 21686 2 7018 19539 21655 2 6874 19596 21650 2 6741 19661 21633 2 6602 19720 21623 2 6459 19762 21627 2 6317 19811 21624 2 6176 19890 21593 2 6190 20015 21473 2 6018 20042 21497 2 5873 20043 21536 2 5731 20084 21536 2 5607 20153 21504 2 5480 20230 21464 2 5365 20314 21414 2 5285 20415 21337 2 5223 20522 21250 2 5147 20626 21168 2 5045 20700 21120 2 4908 20765 21089 2 4775 20828 21057 2 4649 20897 21017 2 4568 20994 20938 2 4530 21103 20837 2 4564 21194 20736 2 4475 21311 20635 2 4535 21397 20533 2 4663 21427 20473 2 4772 21478 20394 2 4916 21475 20363 2 4953 21407 20425 2 4965 21303 20531 2 5035 21212 20608 2 5140 21176 20620 2 5194 21263 20516 2 5276 21322 20434 2 5413 21248 20474 2 5469 21149 20563 2 5541 21052 20642 2 5664 20975 20688 2 5665 20924 20739 2 5783 20802 20829 2 5917 20730 20863 2 6024 20657 20904 2 6175 20653 20865 2 6328 20604 20866 2 6458 20532 20898 2 6594 20458 20928 2 6625 20426 20950 2 6503 20447 20968 2 6716 20382 20963 2 6855 20327 20972 2 6999 20254 20995 2 7102 20219 20994 2 7250 20128 21031 2 7362 20042 21074 2 7500 19965 21098 2 7490 19869 21193 2 7525 19757 21284 2 7547 19647 21378 2 7565 19514 21494 2 7598 19423 21565 2 7738 19326 21601 2 7852 19245 21633 2 7935 19141 21695 2 8023 19053 21740 2 8152 18959 21774 2 8287 18893 21780 2 8356 18853 21788 2 8333 18774 21866 2 8448 18664 21916 2 8537 18626 21913 2 8663 18608 21879 2 8822 18625 21801 2 8964 18622 21745 2 9094 18593 21717 2 9213 18508 21739 2 8985 18532 21814 2 8847 18582 21828 2 8728 18574 21883 2 8608 18525 21971 2 8566 18415 22079 2 8677 18313 22121 2 8799 18210 22158 2 8818 18083 22254 2 8938 17994 22278 2 9051 18027 22206 2 9153 17918 22253 2 9216 17869 22265 2 9305 17945 22167 2 9424 17853 22191 2 9461 17866 22165 2 9404 17983 22095 2 9324 18104 22030 2 9233 18214 21978 2 9258 18272 21919 2 9392 18209 21914 2 9439 18281 21834 2 9318 18370 21811 2 9297 18443 21758 2 9441 18464 21678 2 9569 18394 21682 2 9656 18385 21651 2 9605 18531 21548 2 9486 18608 21535 2 9350 18673 21538 2 9229 18736 21536 2 9078 18791 21552 2 9017 18833 21541 2 9080 18916 21441 2 9071 19001 21370 2 9156 18963 21368 2 9023 19116 21288 2 8922 19219 21237 2 8816 19319 21191 2 8789 19444 21087 2 8857 19493 21014 2 8991 19400 21043 2 9103 19308 21079 2 9178 19291 21063 2 9142 19381 20995 2 9276 19302 21009 2 9317 19313 20981 2 9250 19409 20922 2 9363 19402 20878 2 9194 19518 20845 2 9205 19584 20779 2 9330 19607 20701 2 9426 19646 20621 2 9551 19651 20558 2 9656 19664 20496 2 9805 19629 20458 2 9954 19600 20415 2 10070 19524 20430 2 10210 19535 20351 2 10238 19494 20375 2 10135 19426 20491 2 10170 19354 20543 2 10266 19466 20389 2 10364 19523 20284 2 10439 19593 20178 2 10495 19675 20069 2 10623 19688 19988 2 10750 19700 19909 2 10862 19682 19865 2 10957 19744 19752 2 10812 19815 19760 2 10671 19867 19785 2 10549 19945 19772 2 10477 20050 19704 2 10372 20156 19651 2 10254 20242 19624 2 10249 20317 19549 2 10292 20394 19447 2 10255 20514 19339 2 10294 20603 19224 2 10396 20644 19124 2 10363 20766 19010 2 10331 20877 18906 2 10301 20977 18811 2 10304 21072 18703 2 10326 21156 18596 2 10486 21161 18500 2 10473 21269 18383 2 10430 21373 18287 2 10392 21468 18198 2 10464 21493 18127 2 10546 21593 17959 2 10573 21683 17834 2 10584 21771 17720 2 10695 21804 17613 2 10771 21835 17528 2 10859 21860 17441 2 10800 21950 17365 2 10779 21976 17345 2 10877 21864 17426 2 10985 21793 17447 2 11054 21777 17423 2 10874 21773 17541 2 10851 21759 17572 2 10965 21694 17582 2 11123 21627 17566 2 11255 21622 17488 2 11380 21632 17394 2 11514 21599 17347 2 11561 21533 17398 2 11462 21488 17518 2 11382 21433 17637 2 11370 21354 17740 2 11552 21297 17692 2 11686 21253 17656 2 11764 21151 17726 2 11801 21047 17826 2 11949 20988 17797 2 12038 21032 17684 2 12078 21111 17563 2 12179 21144 17453 2 12258 21185 17348 2 12323 21241 17233 2 12467 21218 17158 2 12559 21250 17050 2 12517 21358 16945 2 12358 21365 17052 2 12268 21332 17160 2 12136 21387 17185 2 12018 21477 17156 2 11915 21575 17105 2 11887 21665 17010 2 11957 21685 16935 2 12037 21774 16763 2 12129 21815 16644 2 12213 21834 16557 2 12320 21847 16459 2 12405 21908 16315 2 12467 21960 16197 2 12592 21967 16090 2 12678 21997 15982 2 12750 22011 15904 2 12904 22002 15793 2 12900 21940 15882 2 12820 21896 16006 2 12779 21839 16117 2 12665 21812 16243 2 12652 21773 16306 2 12767 21710 16299 2 12912 21641 16277 2 12920 21608 16315 2 12871 21566 16409 2 12839 21547 16458 2 12835 21412 16637 2 12865 21336 16711 2 12746 21325 16817 2 12636 21333 16889 2 12662 21258 16963 2 12824 21204 16910 2 12944 21118 16925 2 13078 21087 16862 2 13205 21023 16843 2 13338 20971 16802 2 13470 20926 16753 2 13601 20855 16735 2 13732 20779 16724 2 13860 20697 16719 2 13990 20622 16703 2 14127 20550 16676 2 14252 20500 16632 2 14383 20457 16572 2 14508 20382 16556 2 14631 20309 16538 2 14725 20200 16587 2 14824 20092 16630 2 14896 19979 16702 2 14890 19885 16819 2 14853 19811 16939 2 14780 19759 17063 2 14710 19705 17185 2 14621 19662 17310 2 14499 19676 17397 2 14367 19709 17468 2 14255 19701 17569 2 14157 19668 17685 2 14051 19654 17784 2 13915 19683 17859 2 13800 19714 17914 2 13668 19736 17990 2 13542 19799 18017 2 13423 19803 18101 2 13309 19828 18158 2 13176 19942 18131 2 13068 19938 18212 2 12937 19969 18272 2 12826 20070 18239 2 12738 20075 18296 2 12626 20055 18395 2 12498 20062 18475 2 12368 20069 18555 2 12241 20071 18636 2 12140 20032 18745 2 12034 19997 18849 2 11952 19945 18956 2 11872 19883 19071 2 11787 19827 19183 2 11741 19748 19291 2 11629 19713 19394 2 11493 19735 19453 2 11363 19748 19516 2 11232 19743 19598 2 11096 19761 19657 2 10989 19740 19738 2 11054 19641 19800 2 11174 19594 19779 2 11260 19572 19752 2 11083 19544 19880 2 11046 19467 19975 2 10920 19437 20074 2 10788 19440 20142 2 10663 19454 20195 2 10523 19428 20294 2 10403 19454 20330 2 10282 19429 20416 2 10208 19352 20526 2 10156 19262 20636 2 10174 19147 20733 2 10237 19073 20770 2 10371 19100 20679 2 10458 19065 20667 2 10452 18970 20758 2 10572 18843 20813 2 10573 18731 20913 2 10607 18645 20973 2 10449 18683 21018 2 10491 18567 21100 2 10669 18512 21059 2 10813 18448 21042 2 10837 18329 21133 2 10927 18219 21182 2 11022 18132 21207 2 11018 18054 21276 2 11158 18056 21201 2 11286 18067 21124 2 11313 18033 21138 2 11247 17973 21225 2 11157 17939 21300 2 11341 17930 21210 2 11476 17968 21106 2 11627 17916 21067 2 11718 17861 21064 2 11827 17756 21091 2 11966 17709 21053 2 12077 17719 20981 2 12201 17746 20886 2 12257 17801 20806 2 12237 17920 20715 2 12279 17994 20626 2 12415 17984 20553 2 12548 17947 20505 2 12687 17890 20469 2 12820 17831 20438 2 12937 17733 20449 2 13067 17664 20427 2 13192 17665 20345 2 13302 17690 20252 2 13418 17705 20162 2 13509 17757 20055 2 13557 17853 19936 2 13618 17934 19822 2 13721 17960 19728 2 13854 17905 19685 2 13983 17881 19615 2 14025 17938 19533 2 14143 17988 19401 2 14201 17874 19464 2 14153 17779 19585 2 14234 17656 19638 2 14247 17542 19730 2 14287 17429 19802 2 14378 17307 19843 2 14414 17187 19921 2 14489 17065 19971 2 14485 16966 20058 2 14461 16867 20159 2 14473 16745 20252 2 14469 16631 20349 2 14460 16517 20447 2 14461 16404 20538 2 14463 16279 20635 2 14464 16165 20724 2 14484 16040 20807 2 14493 15917 20895 2 14487 15800 20988 2 14460 15691 21088 2 14408 15597 21193 2 14322 15533 21298 2 14208 15507 21393 2 14078 15499 21485 2 13981 15495 21551 2 13892 15488 21613 2 13737 15510 21696 2 13787 15343 21784 2 13821 15232 21839 2 -14284 23878 -11217 0 -14366 23773 -11334 2 -14381 23798 -11262 2 -14441 23767 -11252 2 -14520 23748 -11190 2 -14511 23858 -10965 2 -14557 23797 -11037 2 -14711 23712 -11015 2 -14671 23719 -11053 2 -14617 23683 -11201 2 -14616 23636 -11300 2 -14738 23517 -11390 2 -14835 23548 -11200 2 -14810 23527 -11277 2 -14813 23454 -11423 2 -14904 23423 -11368 2 -14893 23387 -11457 2 -15052 23290 -11445 2 -15122 23286 -11363 2 -15216 23288 -11232 2 -15334 23232 -11187 2 -15377 23283 -11020 2 -15417 23237 -11063 2 -15383 23183 -11222 2 -15458 23146 -11195 2 -15517 23165 -11073 2 -15610 23149 -10975 2 -15550 23248 -10849 2 -15571 23237 -10844 2 -15664 23121 -10957 2 -15739 23126 -10837 2 -15757 23102 -10865 2 -15832 23001 -10969 2 -15940 22926 -10968 2 -16029 22923 -10845 2 -15974 23008 -10744 2 -16006 22989 -10738 2 -16129 22884 -10780 2 -16136 22857 -10826 2 -16179 22810 -10861 2 -16260 22827 -10702 2 -16376 22767 -10653 2 -16416 22710 -10713 2 -16521 22644 -10691 2 -16648 22565 -10662 2 -16753 22470 -10697 2 -16877 22364 -10725 2 -16975 22290 -10724 2 -17063 22178 -10816 2 -17155 22072 -10887 2 -17137 21993 -11073 2 -17108 22051 -11002 2 -17068 22129 -10909 2 -16988 22222 -10844 2 -16970 22215 -10886 2 -17015 22101 -11047 2 -16975 22142 -11027 2 -16945 22222 -10912 2 -16849 22317 -10865 2 -16754 22343 -10959 2 -16663 22350 -11081 2 -16562 22369 -11195 2 -16425 22412 -11311 2 -16477 22329 -11398 2 -16595 22237 -11407 2 -16712 22144 -11417 2 -16820 22048 -11446 2 -16963 21931 -11458 2 -17098 21801 -11506 2 -17148 21722 -11581 2 -17305 21666 -11451 2 -17258 21650 -11551 2 -17287 21584 -11631 2 -17380 21479 -11689 2 -17463 21381 -11743 2 -17547 21269 -11820 2 -17622 21164 -11898 2 -17713 21049 -11966 2 -17783 20950 -12036 2 -17864 20841 -12104 2 -17943 20734 -12171 2 -18015 20615 -12268 2 -18056 20521 -12363 2 -18121 20409 -12453 2 -18222 20303 -12479 2 -18309 20191 -12534 2 -18419 20087 -12540 2 -18517 19979 -12569 2 -18621 19869 -12588 2 -18696 19752 -12663 2 -18780 19626 -12733 2 -18805 19550 -12813 2 -18880 19424 -12895 2 -18995 19329 -12868 2 -19110 19239 -12833 2 -19213 19128 -12845 2 -19293 19009 -12901 2 -19390 18892 -12926 2 -19493 18794 -12916 2 -19608 18703 -12873 2 -19769 18574 -12814 2 -19827 18497 -12835 2 -19941 18426 -12761 2 -19948 18482 -12669 2 -20015 18509 -12521 2 -20105 18502 -12387 2 -20104 18492 -12405 2 -20020 18492 -12539 2 -19998 18440 -12651 2 -20129 18305 -12639 2 -20057 18332 -12713 2 -20113 18231 -12771 2 -20210 18116 -12782 2 -20320 18044 -12708 2 -20420 17970 -12653 2 -20462 17866 -12733 2 -20562 17744 -12742 2 -20675 17651 -12688 2 -20781 17549 -12657 2 -20884 17462 -12607 2 -20999 17364 -12552 2 -21099 17266 -12520 2 -21185 17145 -12539 2 -21276 17020 -12557 2 -21368 16980 -12453 2 -21452 16964 -12329 2 -21537 16946 -12206 2 -21651 16865 -12116 2 -21742 16806 -12035 2 -21822 16792 -11910 2 -21922 16702 -11852 2 -21997 16662 -11769 2 -22106 16587 -11671 2 -22206 16508 -11591 2 -22307 16408 -11541 2 -22395 16286 -11542 2 -22472 16183 -11538 2 -22576 16048 -11523 2 -22675 15935 -11486 2 -22779 15817 -11443 2 -22853 15700 -11456 2 -22951 15594 -11405 2 -23043 15470 -11389 2 -23136 15368 -11337 2 -23237 15218 -11334 2 -23311 15138 -11289 2 -23396 15000 -11296 2 -23484 14883 -11269 2 -23576 14802 -11183 2 -23666 14735 -11082 2 -23757 14659 -10987 2 -23851 14557 -10920 2 -23939 14466 -10848 2 -24027 14372 -10778 2 -24098 14242 -10792 2 -24159 14105 -10836 2 -24221 13981 -10857 2 -24199 13977 -10911 2 -24145 13987 -11019 2 -24062 14004 -11177 2 -24097 13936 -11185 2 -24187 13851 -11098 2 -24275 13743 -11037 2 -24358 13679 -10936 2 -24442 13610 -10833 2 -24537 13526 -10723 2 -24599 13539 -10564 2 -24680 13441 -10500 2 -24768 13352 -10405 2 -24847 13290 -10296 2 -24926 13196 -10226 2 -25041 13014 -10177 2 -25081 12944 -10169 2 -25137 12812 -10199 2 -25193 12665 -10244 2 -25251 12580 -10206 2 -25343 12471 -10109 2 -25432 12374 -10004 2 -25501 12306 -9913 2 -25578 12228 -9811 2 -25656 12134 -9724 2 -25733 12045 -9629 2 -25807 11959 -9538 2 -25880 11836 -9494 2 -25955 11697 -9463 2 -25996 11704 -9340 2 -25999 11795 -9216 2 -25961 11924 -9156 2 -25886 12033 -9226 2 -25811 12153 -9280 2 -25745 12245 -9341 2 -25662 12311 -9481 2 -25614 12324 -9595 2 -25540 12430 -9654 2 -25484 12566 -9626 2 -25416 12690 -9644 2 -25338 12805 -9697 2 -25260 12928 -9737 2 -25177 13041 -9802 2 -25107 13169 -9810 2 -25033 13302 -9820 2 -24959 13422 -9842 2 -24884 13493 -9936 2 -24829 13549 -9998 2 -24751 13669 -10028 2 -24667 13769 -10097 2 -24579 13888 -10148 2 -24494 13974 -10235 2 -24418 14100 -10245 2 -24335 14233 -10258 2 -24256 14316 -10330 2 -24160 14444 -10376 2 -24078 14524 -10455 2 -23986 14645 -10498 2 -23895 14748 -10559 2 -23804 14836 -10641 2 -23714 14919 -10728 2 -23620 15021 -10792 2 -23539 15143 -10797 2 -23465 15273 -10776 2 -23382 15404 -10769 2 -23296 15517 -10794 2 -23224 15648 -10759 2 -23121 15818 -10733 2 -23163 15806 -10661 2 -23253 15741 -10560 2 -23344 15699 -10421 2 -23389 15703 -10312 2 -23482 15610 -10244 2 -23570 15561 -10114 2 -23641 15482 -10071 2 -23707 15356 -10108 2 -23795 15239 -10079 2 -23882 15125 -10045 2 -23968 14992 -10038 2 -24055 14878 -10001 2 -24144 14763 -9956 2 -24222 14666 -9911 2 -24312 14535 -9882 2 -24401 14434 -9810 2 -24492 14321 -9750 2 -24577 14238 -9657 2 -24665 14127 -9596 2 -24754 14049 -9479 2 -24814 14026 -9356 2 -24876 13922 -9347 2 -24961 13781 -9330 2 -25041 13694 -9242 2 -25123 13628 -9116 2 -25208 13503 -9069 2 -25266 13479 -8942 2 -25364 13354 -8852 2 -25407 13270 -8855 2 -25438 13136 -8964 2 -25516 12999 -8941 2 -25568 12999 -8791 2 -25586 12957 -8803 2 -25620 12915 -8764 2 -25683 12850 -8674 2 -25800 12733 -8500 2 -25858 12644 -8454 2 -25903 12574 -8421 2 -26008 12438 -8299 2 -26045 12383 -8266 2 -26117 12300 -8164 2 -26188 12214 -8061 2 -26261 12114 -7976 2 -26333 12001 -7909 2 -26406 11894 -7827 2 -26474 11787 -7759 2 -26552 11677 -7658 2 -26615 11587 -7575 2 -26682 11475 -7511 2 -26746 11338 -7490 2 -26805 11202 -7484 2 -26874 11076 -7424 2 -26941 10971 -7337 2 -26998 10818 -7355 2 -27019 10689 -7463 2 -27072 10586 -7417 2 -27077 10495 -7531 2 -27102 10397 -7573 2 -27164 10264 -7533 2 -27229 10144 -7462 2 -27292 10037 -7375 2 -27358 9924 -7286 2 -27410 9858 -7177 2 -27465 9804 -7039 2 -27520 9735 -6920 2 -27576 9659 -6804 2 -27634 9556 -6714 2 -27693 9442 -6628 2 -27744 9383 -6497 2 -27792 9335 -6363 2 -27837 9292 -6226 2 -27880 9255 -6087 2 -27912 9252 -5945 2 -27959 9187 -5821 2 -28013 9084 -5722 2 -28062 9005 -5607 2 -28112 8922 -5489 2 -28156 8859 -5360 2 -28197 8812 -5223 2 -28238 8759 -5087 2 -28282 8700 -4944 2 -28324 8628 -4828 2 -28357 8601 -4682 2 -28389 8571 -4537 2 -28424 8531 -4395 2 -28469 8438 -4279 2 -28512 8380 -4107 2 -28545 8320 -3994 2 -28580 8253 -3878 2 -28605 8236 -3728 2 -28632 8209 -3582 2 -28667 8143 -3448 2 -28696 8103 -3299 2 -28710 8112 -3151 2 -28710 8164 -3012 2 -28709 8218 -2870 2 -28709 8269 -2725 2 -28698 8349 -2597 2 -28693 8405 -2463 2 -28700 8412 -2359 2 -28726 8357 -2236 2 -28756 8298 -2064 2 -28731 8360 -2154 2 -28738 8356 -2069 2 -28770 8274 -1952 2 -28805 8179 -1832 2 -28838 8088 -1716 2 -28871 7994 -1604 2 -28914 7866 -1446 2 -28936 7794 -1392 2 -28969 7688 -1291 2 -29001 7584 -1187 2 -29031 7488 -1076 2 -29058 7396 -959 2 -29082 7315 -835 2 -29102 7250 -701 2 -29114 7217 -555 2 -29115 7220 -403 2 -29121 7206 -254 2 -29134 7153 -114 2 -29150 7090 22 2 -29167 7019 146 2 -29171 6999 303 2 -29179 6955 446 2 -29195 6869 683 2 -29193 6872 755 2 -29197 6840 860 2 -29192 6838 1035 2 -29165 6937 1140 2 -29162 6925 1279 2 -29197 6760 1353 2 -29205 6746 1245 2 -29226 6651 1259 2 -29242 6561 1356 2 -29258 6469 1462 2 -29271 6377 1590 2 -29289 6269 1687 2 -29310 6147 1772 2 -29325 6044 1881 2 -29336 5952 1998 2 -29348 5854 2112 2 -29373 5705 2164 2 -29394 5577 2214 2 -29417 5466 2178 2 -29444 5336 2143 2 -29463 5196 2217 2 -29464 5133 2345 2 -29469 5036 2488 2 -29447 5107 2603 2 -29430 5265 2479 2 -29423 5267 2558 2 -29426 5186 2685 2 -29442 5054 2757 2 -29449 4964 2847 2 -29443 4915 2995 2 -29441 4843 3129 2 -29443 4751 3247 2 -29460 4611 3298 2 -29484 4475 3270 2 -29480 4390 3418 2 -29463 4498 3417 2 -29453 4494 3509 2 -29465 4376 3563 2 -29472 4247 3655 2 -29464 4270 3694 2 -29440 4332 3808 2 -29422 4337 3944 2 -29411 4292 4068 2 -29393 4249 4241 2 -29396 4145 4325 2 -29400 4028 4403 2 -29370 4056 4577 2 -29371 3936 4672 2 -29381 3793 4728 2 -29358 3780 4883 2 -29327 3854 5009 2 -29295 3928 5137 2 -29289 4069 5059 2 -29291 4180 4955 2 -29273 4307 4955 2 -29240 4361 5097 2 -29201 4461 5232 2 -29172 4585 5290 2 -29140 4665 5395 2 -29093 4725 5593 2 -29089 4666 5662 2 -29076 4576 5803 2 -29071 4435 5934 2 -29048 4416 6061 2 -29032 4300 6219 2 -29056 4323 6088 2 -29095 4194 5990 2 -29108 4046 6032 2 -29108 3925 6109 2 -29102 3810 6208 2 -29091 3703 6323 2 -29095 3582 6377 2 -29085 3471 6484 2 -29099 3311 6503 2 -29114 3182 6500 2 -29112 3052 6572 2 -29143 2916 6496 2 -29148 2800 6524 2 -29160 2645 6536 2 -29167 2483 6568 2 -29181 2342 6557 2 -29196 2156 6555 2 -29185 2058 6633 2 -29187 1953 6658 2 -29213 1818 6579 2 -29237 1706 6501 2 -29267 1556 6406 2 -29283 1445 6359 2 -29306 1352 6273 2 -29336 1317 6135 2 -29369 1278 5984 2 -29391 1164 5899 2 -29395 994 5914 2 -29431 893 5748 2 -29425 733 5801 2 -29442 622 5727 2 -29469 569 5589 2 -29502 504 5418 2 -29523 478 5306 2 -29547 385 5181 2 -29546 215 5196 2 -29550 70 5179 2 -29564 -54 5095 2 -29582 -164 4987 2 -29578 -315 5002 2 -29593 -453 4904 2 -29614 -533 4767 2 -29606 -688 4799 2 -29604 -838 4783 2 -29594 -992 4818 2 -29600 -1132 4747 2 -29593 -1223 4768 2 -29569 -1299 4897 2 -29541 -1393 5038 2 -29519 -1296 5191 2 -29506 -1276 5268 2 -29511 -1112 5279 2 -29508 -1125 5290 2 -29498 -1281 5312 2 -29492 -1416 5314 2 -29493 -1560 5264 2 -29499 -1691 5189 2 -29519 -1760 5055 2 -29533 -1849 4936 2 -29548 -1940 4814 2 -29556 -2052 4716 2 -29564 -2165 4615 2 -29568 -2287 4530 2 -29558 -2439 4514 2 -29532 -2591 4596 2 -29520 -2730 4592 2 -29494 -2849 4691 2 -29474 -2993 4728 2 -29483 -3079 4613 2 -29464 -3208 4645 2 -29435 -3291 4771 2 -29405 -3361 4903 2 -29375 -3431 5034 2 -29344 -3514 5156 2 -29314 -3633 5243 2 -29284 -3753 5329 2 -29255 -3891 5385 2 -29225 -4026 5447 2 -29193 -4149 5527 2 -29158 -4251 5631 2 -29126 -4381 5701 2 -29092 -4510 5774 2 -29061 -4655 5815 2 -29028 -4788 5870 2 -28993 -4914 5937 2 -28958 -5057 5989 2 -28924 -5195 6032 2 -28890 -5331 6081 2 -28851 -5458 6150 2 -28811 -5585 6224 2 -28772 -5716 6286 2 -28737 -5860 6312 2 -28691 -5962 6425 2 -28648 -6082 6503 2 -28609 -6236 6529 2 -28567 -6350 6602 2 -28520 -6466 6692 2 -28476 -6594 6756 2 -28431 -6721 6820 2 -28385 -6845 6886 2 -28338 -6970 6956 2 -28306 -7132 6922 2 -28291 -7228 6884 2 -28243 -7364 6934 2 -28193 -7484 7011 2 -28142 -7605 7083 2 -28090 -7690 7199 2 -28037 -7794 7292 2 -27982 -7905 7383 2 -27932 -7999 7473 2 -27878 -8067 7597 2 -27824 -8138 7719 2 -27770 -8209 7837 2 -27716 -8284 7951 2 -27657 -8366 8067 2 -27604 -8413 8200 2 -27549 -8479 8318 2 -27489 -8545 8447 2 -27432 -8600 8573 2 -27374 -8660 8699 2 -27312 -8756 8796 2 -27250 -8835 8909 2 -27188 -8897 9035 2 -27127 -8990 9126 2 -27071 -9123 9161 2 -27003 -9210 9275 2 -26938 -9299 9376 2 -26870 -9386 9480 2 -26802 -9489 9571 2 -26755 -9636 9557 2 -26702 -9779 9560 2 -26649 -9920 9562 2 -26591 -10059 9577 2 -26536 -10198 9583 2 -26487 -10341 9566 2 -26445 -10479 9531 2 -26395 -10626 9508 2 -26337 -10764 9513 2 -26276 -10903 9523 2 -26232 -11037 9491 2 -26188 -11177 9446 2 -26145 -11314 9405 2 -26096 -11455 9368 2 -26049 -11592 9332 2 -26013 -11729 9260 2 -26009 -11807 9173 2 -25947 -11945 9169 2 -25885 -12056 9198 2 -25842 -12187 9147 2 -25786 -12328 9116 2 -25733 -12465 9080 2 -25671 -12600 9070 2 -25601 -12732 9083 2 -25546 -12866 9047 2 -25522 -12976 8957 2 -25462 -13113 8929 2 -25396 -13251 8915 2 -25342 -13378 8878 2 -25291 -13512 8821 2 -25239 -13646 8761 2 -25195 -13763 8705 2 -25129 -13900 8677 2 -25095 -14015 8593 2 -25038 -14144 8545 2 -24979 -14276 8499 2 -24935 -14396 8426 2 -24895 -14519 8334 2 -24819 -14648 8335 2 -24735 -14773 8363 2 -24664 -14903 8343 2 -24607 -15026 8289 2 -24581 -15126 8185 2 -24531 -15244 8114 2 -24456 -15375 8094 2 -24378 -15504 8084 2 -24296 -15633 8081 2 -24212 -15763 8081 2 -24136 -15886 8067 2 -24055 -16016 8054 2 -23977 -16135 8047 2 -23914 -16256 7992 2 -23863 -16374 7903 2 -23787 -16499 7872 2 -23706 -16624 7853 2 -23663 -16732 7753 2 -23606 -16849 7675 2 -23532 -16970 7631 2 -23460 -17094 7578 2 -23396 -17212 7509 2 -23350 -17315 7415 2 -23299 -17424 7318 2 -23227 -17541 7268 2 -23172 -17651 7176 2 -23094 -17773 7126 2 -23029 -17895 7030 2 -22987 -17977 6960 2 -22900 -18107 6908 2 -22911 -18148 6763 2 -22840 -18258 6707 2 -22752 -18374 6690 2 -22652 -18486 6720 2 -22567 -18605 6678 2 -22457 -18742 6666 2 -22374 -18834 6684 2 -22269 -18952 6703 2 -22182 -19062 6676 2 -22109 -19173 6602 2 -22067 -19251 6516 2 -21997 -19361 6426 2 -21908 -19477 6376 2 -21830 -19588 6305 2 -21749 -19696 6250 2 -21642 -19812 6255 2 -21544 -19903 6304 2 -21497 -19950 6314 2 -21428 -19988 6426 2 -21461 -19918 6536 2 -21441 -19903 6645 2 -21401 -19896 6791 2 -21362 -19948 6762 2 -21341 -20022 6610 2 -21253 -20091 6681 2 -21151 -20196 6690 2 -21183 -20184 6624 2 -21130 -20250 6591 2 -21102 -20294 6548 2 -21008 -20406 6501 2 -20933 -20495 6460 2 -20863 -20601 6352 2 -20737 -20724 6365 2 -20687 -20792 6307 2 -20598 -20902 6231 2 -20470 -20993 6349 2 -20422 -21029 6384 2 -20348 -21125 6300 2 -20326 -21187 6161 2 -20288 -21253 6059 2 -20168 -21347 6129 2 -20187 -21353 6046 2 -20095 -21458 5979 2 -20034 -21535 5908 2 -19931 -21647 5846 2 -19935 -21626 5908 2 -19910 -21653 5897 2 -19836 -21756 5763 2 -19926 -21679 5744 2 -19977 -21666 5614 2 -19998 -21629 5678 2 -20078 -21549 5703 2 -20122 -21539 5581 2 -20078 -21610 5468 2 -20037 -21675 5357 2 -20007 -21732 5239 2 -19899 -21856 5132 2 -19925 -21826 5160 2 -19936 -21780 5309 2 -19903 -21806 5327 2 -19794 -21877 5438 2 -19762 -21875 5561 2 -19616 -21996 5601 2 -19585 -22056 5474 2 -19462 -22159 5495 2 -19481 -22166 5401 2 -19433 -22211 5387 2 -19381 -22225 5518 2 -19397 -22177 5650 2 -19362 -22202 5674 2 -19262 -22274 5731 2 -19260 -22280 5713 2 -19195 -22338 5706 2 -19238 -22327 5605 2 -19281 -22325 5462 2 -19325 -22307 5381 2 -19299 -22335 5359 2 -19173 -22419 5457 2 -19087 -22505 5404 2 -19028 -22572 5333 2 -18926 -22670 5278 2 -18793 -22783 5270 2 -18864 -22695 5395 2 -18791 -22757 5383 2 -18658 -22860 5411 2 -18685 -22848 5372 2 -18672 -22880 5275 2 -18578 -22951 5301 2 -18502 -23020 5268 2 -18530 -23024 5150 2 -18471 -23076 5132 2 -18365 -23140 5221 2 -18258 -23228 5203 2 -18284 -23175 5351 2 -18223 -23229 5322 2 -18173 -23298 5190 2 -18063 -23376 5224 2 -17941 -23467 5235 2 -17849 -23540 5223 2 -17719 -23631 5254 2 -17771 -23578 5319 2 -17705 -23625 5326 2 -17757 -23572 5392 2 -17734 -23565 5494 2 -17846 -23491 5449 2 -17808 -23504 5518 2 -17674 -23594 5562 2 -17585 -23672 5517 2 -17473 -23768 5458 2 -17504 -23742 5468 2 -17617 -23654 5490 2 -17605 -23676 5430 2 -17603 -23694 5361 2 -17662 -23683 5213 2 -17620 -23722 5179 2 -17485 -23828 5149 2 -17464 -23816 5275 2 -17437 -23833 5285 2 -17352 -23916 5189 2 -17259 -23979 5209 2 -17301 -23928 5303 2 -17395 -23843 5375 2 -17388 -23820 5500 2 -17312 -23828 5704 2 -17310 -23854 5602 2 -17305 -23896 5433 2 -17296 -23928 5319 2 -17181 -24020 5281 2 -17058 -24094 5336 2 -17136 -24017 5433 2 -17159 -23983 5509 2 -17166 -23947 5645 2 -17186 -23897 5794 2 -17104 -23950 5816 2 -17060 -24013 5688 2 -16974 -24102 5567 2 -17000 -24080 5579 2 -17049 -24062 5509 2 -17043 -24089 5409 2 -16911 -24168 5470 2 -16823 -24207 5569 2 -16754 -24222 5708 2 -16825 -24149 5807 2 -16941 -24059 5844 2 -17045 -23967 5918 2 -17144 -23877 6001 2 -17139 -23845 6138 2 -17138 -23807 6286 2 -17158 -23760 6409 2 -17172 -23715 6534 2 -17077 -23737 6705 2 -17189 -23653 6714 2 -17314 -23568 6691 2 -17424 -23518 6580 2 -17425 -23503 6631 2 -17473 -23448 6702 2 -17621 -23340 6690 2 -17676 -23295 6703 2 -17767 -23203 6778 2 -17845 -23116 6871 2 -17872 -23047 7030 2 -17974 -22982 6984 2 -18009 -22943 7022 2 -18003 -22936 7060 2 -17884 -23010 7119 2 -17877 -22971 7264 2 -17955 -22882 7352 2 -18076 -22766 7414 2 -18148 -22691 7469 2 -18205 -22608 7579 2 -18247 -22533 7702 2 -18261 -22474 7839 2 -18273 -22414 7980 2 -18299 -22343 8121 2 -18385 -22255 8167 2 -18420 -22206 8221 2 -18481 -22118 8322 2 -18587 -22016 8354 2 -18681 -21970 8267 2 -18752 -21959 8135 2 -18852 -21908 8040 2 -18964 -21834 7976 2 -19078 -21758 7914 2 -19191 -21659 7910 2 -19277 -21560 7973 2 -19336 -21469 8075 2 -19392 -21377 8183 2 -19425 -21300 8305 2 -19412 -21259 8440 2 -19399 -21209 8594 2 -19335 -21211 8732 2 -19406 -21125 8782 2 -19450 -21030 8913 2 -19521 -20931 8990 2 -19610 -20826 9040 2 -19713 -20717 9066 2 -19763 -20621 9175 2 -19797 -20537 9291 2 -19778 -20479 9456 2 -19832 -20436 9436 2 -19954 -20358 9348 2 -19967 -20278 9493 2 -19876 -20325 9583 2 -19774 -20405 9624 2 -19741 -20368 9769 2 -19817 -20259 9843 2 -19923 -20149 9854 2 -19990 -20156 9702 2 -19939 -20234 9645 2 -20020 -20207 9533 2 -20122 -20145 9448 2 -20228 -20056 9412 2 -20313 -19944 9467 2 -20410 -19836 9486 2 -20514 -19724 9496 2 -20586 -19605 9584 2 -20554 -19599 9667 2 -20455 -19646 9779 2 -20359 -19691 9889 2 -20261 -19741 9989 2 -20191 -19744 10125 2 -20134 -19731 10262 2 -20109 -19683 10401 2 -20119 -19586 10565 2 -20190 -19502 10585 2 -20296 -19383 10602 2 -20365 -19267 10679 2 -20387 -19192 10772 2 -20494 -19041 10837 2 -20574 -18970 10809 2 -20674 -18836 10852 2 -20601 -18855 10960 2 -20512 -18878 11085 2 -20441 -18876 11220 2 -20374 -18868 11353 2 -20313 -18850 11492 2 -20254 -18829 11629 2 -20194 -18808 11768 2 -20140 -18778 11906 2 -20084 -18751 12043 2 -20038 -18711 12182 2 -19989 -18673 12320 2 -19952 -18622 12456 2 -19925 -18561 12590 2 -19947 -18466 12693 2 -19985 -18359 12788 2 -19990 -18268 12910 2 -20013 -18165 13019 2 -20035 -18062 13129 2 -20083 -17950 13208 2 -20182 -17811 13246 2 -20268 -17772 13167 2 -20384 -17688 13102 2 -20478 -17572 13109 2 -20513 -17460 13204 2 -20568 -17352 13262 2 -20677 -17255 13218 2 -20786 -17182 13143 2 -20891 -17122 13053 2 -20998 -17060 12964 2 -21099 -16959 12931 2 -21140 -16864 12989 2 -21215 -16742 13024 2 -21304 -16620 13035 2 -21359 -16494 13106 2 -21387 -16386 13196 2 -21397 -16297 13288 2 -21484 -16159 13316 2 -21464 -16173 13331 2 -21378 -16298 13317 2 -21366 -16395 13218 2 -21334 -16504 13133 2 -21276 -16626 13073 2 -21192 -16748 13054 2 -21085 -16846 13100 2 -20977 -16941 13152 2 -20894 -16975 13239 2 -20817 -16970 13366 2 -20719 -17021 13454 2 -20613 -17087 13533 2 -20508 -17136 13630 2 -20419 -17160 13733 2 -20357 -17118 13877 2 -20259 -17138 13994 2 -20155 -17174 14101 2 -20087 -17151 14224 2 -20044 -17065 14389 2 -20002 -17034 14483 2 -19984 -16945 14613 2 -19994 -16839 14720 2 -20014 -16729 14817 2 -20010 -16634 14930 2 -19990 -16548 15052 2 -19971 -16460 15173 2 -19977 -16355 15279 2 -20003 -16237 15370 2 -20038 -16115 15453 2 -20052 -15980 15574 2 -20103 -15891 15600 2 -20148 -15744 15690 2 -20165 -15639 15773 2 -20133 -15561 15891 2 -20117 -15466 16004 2 -20131 -15337 16110 2 -20157 -15214 16193 2 -20218 -15092 16231 2 -20176 -15108 16268 2 -20042 -15155 16390 2 -19989 -15248 16369 2 -19962 -15367 16290 2 -19977 -15470 16174 2 -19979 -15562 16083 2 -19973 -15671 15983 2 -19996 -15744 15884 2 -20051 -15873 15684 2 -20012 -15848 15759 2 -19966 -15779 15886 2 -19935 -15695 16008 2 -19913 -15603 16125 2 -19899 -15504 16238 2 -19897 -15396 16343 2 -19898 -15285 16445 2 -19905 -15170 16542 2 -19929 -15047 16626 2 -19948 -14924 16714 2 -19956 -14807 16809 2 -19951 -14696 16911 2 -19938 -14590 17018 2 -19911 -14495 17131 2 -19868 -14413 17249 2 -19847 -14299 17368 2 -19843 -14200 17453 2 -19877 -14065 17524 2 -19932 -13934 17566 2 -19980 -13802 17616 2 -20013 -13683 17671 2 -20093 -13530 17697 2 -20150 -13398 17733 2 -20227 -13251 17756 2 -20253 -13099 17839 2 -20235 -12995 17935 2 -20318 -12911 17902 2 -20296 -12859 17965 2 -20230 -12836 18055 2 -20175 -12749 18178 2 -20183 -12672 18222 2 -20130 -12572 18350 2 -20063 -12509 18466 2 -20002 -12425 18589 2 -19970 -12328 18688 2 -19904 -12255 18806 2 -19821 -12179 18942 2 -19763 -12123 19039 2 -19669 -12095 19153 2 -19568 -12085 19262 2 -19517 -11986 19376 2 -19456 -11920 19477 2 -19355 -11887 19598 2 -19373 -11826 19617 2 -19361 -11729 19687 2 -19276 -11720 19776 2 -19134 -11723 19911 2 -19042 -11746 19986 2 -18933 -11720 20104 2 -18929 -11617 20168 2 -18876 -11657 20194 2 -18770 -11707 20264 2 -18664 -11694 20369 2 -18529 -11698 20490 2 -18493 -11609 20573 2 -18512 -11477 20630 2 -18455 -11381 20734 2 -18364 -11327 20844 2 -18275 -11271 20952 2 -18267 -11162 21017 2 -18318 -11020 21047 2 -18324 -10884 21113 2 -18309 -10755 21192 2 -18264 -10654 21282 2 -18210 -10553 21379 2 -18200 -10410 21457 2 -18174 -10288 21537 2 -18155 -10166 21612 2 -18094 -10067 21708 2 -18083 -9933 21779 2 -18124 -9790 21810 2 -18162 -9646 21842 2 -18180 -9505 21889 2 -18173 -9368 21954 2 -18128 -9250 22041 2 -18059 -9151 22140 2 -18083 -9012 22176 2 -18114 -8866 22210 2 -18118 -8726 22262 2 -18125 -8582 22312 2 -18123 -8441 22368 2 -18116 -8302 22425 2 -18128 -8159 22468 2 -18178 -8014 22480 2 -18218 -7869 22499 2 -18253 -7715 22523 2 -18288 -7578 22542 2 -18291 -7431 22588 2 -18312 -7278 22621 2 -18354 -7149 22628 2 -18377 -7020 22650 2 -18349 -6881 22715 2 -18341 -6673 22783 2 -18295 -6590 22844 2 -18198 -6701 22889 2 -18111 -6681 22965 2 -18048 -6569 23046 2 -18000 -6447 23118 2 -17948 -6326 23192 2 -17907 -6196 23258 2 -17868 -6022 23334 2 -17850 -5895 23380 2 -17795 -5784 23450 2 -17733 -5691 23520 2 -17666 -5580 23596 2 -17572 -5500 23685 2 -17484 -5418 23768 2 -17425 -5300 23838 2 -17355 -5191 23913 2 -17311 -5048 23976 2 -17218 -4963 24060 2 -17150 -4850 24132 2 -17091 -4727 24198 2 -17053 -4592 24251 2 -17022 -4453 24298 2 -16998 -4311 24341 2 -16979 -4169 24379 2 -16994 -4003 24396 2 -16986 -3892 24420 2 -17011 -3706 24431 2 -17042 -3588 24428 2 -17077 -3439 24424 2 -17132 -3274 24408 2 -17161 -3151 24404 2 -17201 -3006 24395 2 -17247 -2862 24379 2 -17319 -2732 24343 2 -17432 -2668 24269 2 -17556 -2649 24182 2 -17677 -2666 24092 2 -17800 -2665 24001 2 -17912 -2620 23923 2 -18029 -2573 23839 2 -18123 -2476 23779 2 -18234 -2412 23700 2 -18328 -2314 23638 2 -18426 -2219 23570 2 -18512 -2106 23513 2 -18602 -1986 23452 2 -18701 -1917 23379 2 -18800 -1829 23307 2 -18900 -1746 23233 2 -19003 -1670 23153 2 -19116 -1597 23066 2 -19214 -1524 22989 2 -19322 -1482 22901 2 -19440 -1470 22802 2 -19555 -1493 22702 2 -19670 -1510 22602 2 -19775 -1537 22507 2 -19892 -1510 22406 2 -20010 -1451 22305 2 -20115 -1470 22208 2 -20225 -1428 22112 2 -20322 -1359 22026 2 -20424 -1297 21936 2 -20534 -1251 21836 2 -20633 -1298 21739 2 -20734 -1333 21641 2 -20878 -1442 21495 2 -20848 -1316 21532 2 -20918 -1311 21464 2 -20958 -1408 21420 2 -20987 -1556 21381 2 -21068 -1678 21292 2 -21072 -1642 21290 2 -21062 -1501 21311 2 -21039 -1352 21343 2 -20992 -1213 21397 2 -21076 -1214 21315 2 -21072 -1156 21323 2 -21034 -1020 21366 2 -21110 -906 21297 2 -21190 -805 21221 2 -21307 -838 21102 2 -21370 -735 21042 2 -21462 -665 20950 2 -21542 -630 20870 2 -21633 -568 20777 2 -21713 -546 20694 2 -21820 -484 20582 2 -21911 -420 20487 2 -22007 -363 20385 2 -22099 -360 20285 2 -22208 -364 20166 2 -22311 -392 20052 2 -22369 -543 19983 2 -22409 -653 19935 2 -22440 -793 19895 2 -22511 -796 19815 2 -22589 -891 19721 2 -22663 -980 19633 2 -22724 -1087 19556 2 -22759 -1227 19507 2 -22808 -1369 19440 2 -22816 -1324 19434 2 -22789 -1178 19475 2 -22800 -996 19472 2 -22908 -1030 19343 2 -22993 -972 19246 2 -23093 -1039 19122 2 -23175 -963 19027 2 -23210 -842 18989 2 -23249 -703 18947 2 -23267 -565 18929 2 -23302 -505 18888 2 -23377 -605 18792 2 -23449 -680 18700 2 -23538 -753 18584 2 -23619 -830 18478 2 -23709 -845 18363 2 -23817 -826 18222 2 -23802 -785 18244 2 -23716 -724 18358 2 -23626 -697 18474 2 -23572 -573 18548 2 -23543 -438 18588 2 -23497 -302 18649 2 -23443 -194 18719 2 -23399 -56 18775 2 -23320 31 18873 2 -23239 112 18972 2 -23173 225 19051 2 -23119 352 19115 2 -23053 463 19192 2 -22979 561 19279 2 -22941 686 19320 2 -22951 834 19302 2 -23022 925 19213 2 -23117 962 19097 2 -23196 1097 18993 2 -23204 1227 18975 2 -23233 1358 18931 2 -23259 1506 18888 2 -23286 1652 18843 2 -23294 1802 18818 2 -23306 1972 18787 2 -23319 2099 18757 2 -23395 2241 18645 2 -23412 2125 18638 2 -23441 2146 18598 2 -23474 2246 18546 2 -23536 2350 18454 2 -23578 2460 18386 2 -23652 2538 18280 2 -23711 2644 18187 2 -23775 2743 18089 2 -23837 2844 17991 2 -23922 2884 17873 2 -24005 2925 17753 2 -24083 2995 17636 2 -24175 2882 17529 2 -24162 2957 17535 2 -24189 3060 17480 2 -24274 3092 17356 2 -24358 3119 17233 2 -24450 3128 17100 2 -24445 3076 17117 2 -24457 3062 17102 2 -24529 3099 16992 2 -24613 3122 16866 2 -24706 3047 16743 2 -24768 3049 16650 2 -24846 3091 16527 2 -24925 3113 16402 2 -25011 3122 16270 2 -25084 2950 16189 2 -25079 3021 16183 2 -25068 3168 16172 2 -25120 3284 16068 2 -25169 3346 15979 2 -25217 3451 15881 2 -25271 3547 15772 2 -25347 3586 15643 2 -25435 3422 15535 2 -25431 3513 15522 2 -25391 3656 15554 2 -25367 3806 15557 2 -25397 3945 15473 2 -25435 4042 15386 2 -25479 4146 15285 2 -25528 4237 15178 2 -25603 4314 15030 2 -25652 4359 14933 2 -25698 4455 14825 2 -25768 4496 14690 2 -25840 4464 14572 2 -25918 4471 14432 2 -25980 4415 14337 2 -26073 4452 14156 2 -26025 4486 14233 2 -25970 4576 14304 2 -25919 4737 14345 2 -25859 4837 14419 2 -25864 4952 14372 2 -25922 4999 14250 2 -25983 5110 14098 2 -26051 5073 13986 2 -26126 5140 13821 2 -26169 5134 13742 2 -26193 5264 13645 2 -26277 5247 13490 2 -26238 5290 13550 2 -26270 5416 13438 2 -26224 5494 13496 2 -26155 5489 13631 2 -26042 5553 13820 2 -26087 5570 13727 2 -26156 5587 13589 2 -26225 5582 13458 2 -26297 5574 13319 2 -26366 5552 13192 2 -26439 5549 13046 2 -26535 5524 12859 2 -26480 5478 12992 2 -26525 5444 12915 2 -26603 5396 12773 2 -26662 5331 12677 2 -26720 5275 12579 2 -26795 5246 12431 2 -26850 5280 12297 2 -26915 5334 12129 2 -26947 5374 12041 2 -26966 5491 11945 2 -27013 5532 11819 2 -27075 5530 11678 2 -27136 5521 11540 2 -27198 5494 11405 2 -27259 5478 11266 2 -27322 5456 11124 2 -27374 5474 10985 2 -27383 5600 10899 2 -27369 5707 10880 2 -27376 5838 10792 2 -27410 5920 10660 2 -27455 5960 10522 2 -27502 5985 10383 2 -27557 5986 10237 2 -27562 6109 10149 2 -27546 6254 10106 2 -27571 6316 9996 2 -27625 6212 9913 2 -27639 6078 9956 2 -27587 6029 10129 2 -27634 5977 10031 2 -27681 5912 9941 2 -27738 5860 9810 2 -27795 5830 9668 2 -27851 5766 9545 2 -27915 5698 9397 2 -27956 5583 9342 2 -27973 5435 9378 2 -27971 5307 9459 2 -27965 5179 9548 2 -27972 5043 9599 2 -28002 4886 9592 2 -28051 4770 9506 2 -28105 4721 9373 2 -28124 4806 9272 2 -28125 4916 9208 2 -28132 4994 9145 2 -28120 5147 9098 2 -28074 5279 9166 2 -28024 5398 9247 2 -27981 5522 9305 2 -27965 5689 9253 2 -27959 5783 9211 2 -27961 5906 9126 2 -27930 6036 9138 2 -27873 6082 9281 2 -27819 6150 9395 2 -27764 6273 9476 2 -27759 6407 9401 2 -27806 6455 9228 2 -27861 6381 9115 2 -27906 6336 9004 2 -27956 6197 8947 2 -28010 6124 8828 2 -28063 6067 8697 2 -28116 5981 8584 2 -28169 5893 8473 2 -28216 5864 8334 2 -28257 5873 8188 2 -28295 5886 8045 2 -28337 5756 7993 2 -28393 5623 7887 2 -28377 5690 7896 2 -28374 5722 7886 2 -28405 5768 7738 2 -28447 5713 7624 2 -28497 5609 7512 2 -28549 5496 7399 2 -28590 5353 7347 2 -28609 5239 7355 2 -28644 5080 7328 2 -28676 4929 7306 2 -28713 4898 7182 2 -28753 4802 7084 2 -28793 4675 7006 2 -28836 4582 6893 2 -28885 4479 6754 2 -28897 4338 6793 2 -28919 4179 6801 2 -28928 4217 6736 2 -28930 4327 6659 2 -28939 4438 6546 2 -28948 4537 6435 2 -28958 4629 6325 2 -28963 4742 6219 2 -28976 4823 6092 2 -28996 4878 5951 2 -29019 4913 5810 2 -29046 4939 5653 2 -29064 4974 5526 2 -29091 4992 5366 2 -29129 4903 5243 2 -29158 4842 5137 2 -29194 4774 4994 2 -29225 4728 4854 2 -29258 4649 4730 2 -29288 4593 4594 2 -29313 4582 4444 2 -29324 4711 4235 2 -29342 4664 4160 2 -29352 4727 4018 2 -29343 4827 3961 2 -29334 4951 3872 2 -29337 5035 3743 2 -29333 5133 3636 2 -29327 5236 3538 2 -29318 5354 3433 2 -29305 5478 3350 2 -29287 5611 3287 2 -29274 5724 3207 2 -29251 5870 3148 2 -29219 6000 3206 2 -29190 6134 3208 2 -29162 6269 3204 2 -29132 6394 3230 2 -29092 6571 3241 2 -29106 6497 3263 2 -29103 6489 3306 2 -29066 6653 3303 2 -29034 6798 3286 2 -29001 6945 3276 2 -28963 7088 3299 2 -28924 7230 3336 2 -28884 7352 3414 2 -28847 7488 3432 2 -28816 7636 3367 2 -28795 7703 3395 2 -28768 7802 3400 2 -28758 7901 3245 2 -28770 7916 3099 2 -28758 7992 3021 2 -28734 8088 2993 2 -28725 8183 2814 2 -28734 8182 2721 2 -28729 8248 2575 2 -28746 8231 2433 2 -28762 8219 2282 2 -28762 8257 2143 2 -28773 8247 2017 2 -28805 8174 1861 2 -28816 8165 1715 2 -28828 8154 1565 2 -28831 8173 1414 2 -28833 8193 1249 2 -28833 8212 1102 2 -28858 8141 977 2 -28856 8161 846 2 -28853 8185 713 2 -28838 8247 574 2 -28796 8387 674 2 -28753 8520 803 2 -28731 8592 843 2 -28688 8730 877 2 -28646 8870 857 2 -28598 9021 879 2 -28555 9157 887 2 -28509 9293 934 2 -28465 9430 910 2 -28451 9480 834 2 -28396 9635 919 2 -28418 9565 974 2 -28460 9430 1047 2 -28451 9453 1096 2 -28402 9593 1133 2 -28352 9734 1179 2 -28296 9894 1198 2 -28246 10034 1207 2 -28196 10174 1224 2 -28166 10251 1251 2 -28115 10388 1280 2 -28068 10504 1363 2 -28025 10604 1468 2 -27975 10725 1545 2 -27924 10853 1564 2 -27878 10979 1506 2 -27872 11015 1346 2 -27890 10981 1242 2 -27886 11008 1099 2 -27880 11039 920 2 -27889 11026 798 2 -27907 10989 654 2 -27928 10944 513 2 -27940 10920 365 2 -27948 10902 215 2 -27960 10874 68 2 -27982 10816 -69 2 -28025 10703 -182 2 -28068 10589 -223 2 -28121 10447 -236 2 -28175 10302 -238 2 -28218 10183 -289 2 -28261 10059 -350 2 -28309 9922 -389 2 -28341 9824 -502 2 -28374 9719 -666 2 -28410 9617 -642 2 -28442 9514 -737 2 -28438 9512 -910 2 -28413 9579 -979 2 -28396 9610 -1134 2 -28409 9552 -1307 2 -28416 9515 -1414 2 -28422 9474 -1558 2 -28412 9462 -1801 2 -28421 9421 -1867 2 -28421 9394 -1998 2 -28423 9355 -2144 2 -28404 9383 -2278 2 -28357 9501 -2372 2 -28323 9569 -2500 2 -28293 9622 -2632 2 -28274 9631 -2794 2 -28249 9673 -2898 2 -28192 9812 -2984 2 -28145 9918 -3077 2 -28094 10046 -3131 2 -28039 10186 -3172 2 -27987 10303 -3254 2 -27936 10411 -3345 2 -27885 10517 -3440 2 -27831 10636 -3513 2 -27774 10764 -3568 2 -27716 10895 -3620 2 -27662 11012 -3680 2 -27578 11200 -3740 2 -27602 11156 -3697 2 -27686 10977 -3604 2 -27654 11061 -3592 2 -27599 11166 -3689 2 -27540 11292 -3750 2 -27479 11430 -3772 2 -27423 11562 -3779 2 -27375 11692 -3726 2 -27309 11846 -3723 2 -27235 12022 -3703 2 -27194 12116 -3700 2 -27132 12263 -3673 2 -27073 12401 -3646 2 -27016 12536 -3606 2 -26959 12670 -3562 2 -26907 12797 -3499 2 -26859 12919 -3421 2 -26802 13050 -3369 2 -26740 13172 -3386 2 -26669 13300 -3447 2 -26608 13415 -3477 2 -26532 13557 -3505 2 -26475 13676 -3472 2 -26415 13768 -3561 2 -26419 13777 -3498 2 -26393 13850 -3403 2 -26323 13981 -3411 2 -26309 14018 -3369 2 -26271 14110 -3278 2 -26249 14170 -3190 2 -26211 14270 -3059 2 -26161 14377 -2980 2 -26183 14367 -2833 2 -26190 14380 -2706 2 -26174 14425 -2621 2 -26155 14482 -2483 2 -26109 14586 -2364 2 -26057 14696 -2250 2 -25990 14810 -2271 2 -25959 14874 -2209 2 -26004 14809 -2122 2 -26033 14757 -2123 2 -26040 14746 -2114 2 -26017 14805 -1975 2 -26002 14851 -1819 2 -25955 14941 -1769 2 -25974 14912 -1720 2 -25993 14898 -1553 2 -26008 14887 -1405 2 -26044 14836 -1268 2 -26070 14802 -1124 2 -26052 14844 -973 2 -26023 14902 -864 2 -26058 14846 -737 2 -26093 14792 -614 2 -26140 14710 -555 2 -26177 14646 -517 2 -26198 14612 -379 2 -26171 14664 -247 2 -26190 14631 -109 2 -26131 14738 -43 2 -26135 14730 79 2 -26171 14665 200 2 -26221 14573 317 2 -26192 14621 420 2 -26144 14710 308 2 -26107 14777 174 2 -26057 14865 200 2 -26000 14963 277 2 -25981 14998 219 2 -25966 15025 119 2 -25959 15037 15 2 -25954 15046 -153 2 -25892 15153 -106 2 -25909 15124 34 2 -25933 15082 176 2 -25897 15141 309 2 -25872 15180 469 2 -25877 15166 598 2 -25874 15165 749 2 -25819 15251 884 2 -25878 15147 958 2 -25900 15107 996 2 -25864 15158 1143 2 -25833 15202 1259 2 -25824 15210 1336 2 -25828 15189 1482 2 -25813 15197 1658 2 -25841 15137 1767 2 -25860 15080 1968 2 -25900 15002 2027 2 -25956 14894 2113 2 -25947 14883 2286 2 -25916 14918 2407 2 -25865 14985 2538 2 -25822 15040 2655 2 -25834 14992 2804 2 -25873 14902 2916 2 -25922 14799 3010 2 -25968 14696 3115 2 -25997 14617 3239 2 -26039 14521 3335 2 -26097 14408 3368 2 -26180 14260 3356 2 -26251 14137 3325 2 -26322 14004 3323 2 -26308 14016 3381 2 -26296 14017 3472 2 -26382 13868 3413 2 -26429 13770 3450 2 -26488 13638 3522 2 -26502 13577 3647 2 -26551 13454 3751 2 -26590 13368 3779 2 -26651 13228 3839 2 -26693 13121 3916 2 -26708 13047 4060 2 -26752 12931 4139 2 -26802 12802 4214 2 -26812 12749 4308 2 -26774 12775 4466 2 -26730 12842 4539 2 -26661 12975 4565 2 -26597 13086 4623 2 -26525 13228 4630 2 -26453 13369 4638 2 -26387 13501 4634 2 -26329 13626 4592 2 -26286 13735 4517 2 -26220 13880 4457 2 -26164 14005 4393 2 -26111 14126 4322 2 -26055 14250 4254 2 -25989 14385 4203 2 -25982 14385 4243 2 -26028 14283 4307 2 -26094 14155 4331 2 -26120 14099 4354 2 -26022 14289 4322 2 -25964 14411 4265 2 -25913 14529 4176 2 -25861 14643 4098 2 -25802 14765 4030 2 -25740 14890 3968 2 -25675 15014 3921 2 -25606 15143 3878 2 -25538 15268 3834 2 -25446 15426 3809 2 -25386 15518 3838 2 -25309 15637 3868 2 -25233 15749 3910 2 -25160 15848 3977 2 -25077 15958 4063 2 -25005 16072 4052 2 -25001 16067 4097 2 -24977 16088 4165 2 -24927 16137 4270 2 -24849 16220 4407 2 -24791 16279 4515 2 -24721 16358 4614 2 -24640 16459 4687 2 -24559 16561 4750 2 -24478 16656 4835 2 -24408 16724 4959 2 -24371 16735 5099 2 -24308 16795 5198 2 -24227 16895 5254 2 -24136 16992 5361 2 -24075 17060 5417 2 -24027 17085 5551 2 -23932 17154 5744 2 -23928 17213 5583 2 -23905 17222 5652 2 -23833 17311 5687 2 -23807 17396 5532 2 -23797 17405 5547 2 -23767 17396 5701 2 -23749 17371 5851 2 -23665 17450 5955 2 -23578 17559 5980 2 -23611 17544 5892 2 -23597 17575 5856 2 -23592 17616 5753 2 -23591 17656 5632 2 -23586 17679 5581 2 -23523 17707 5755 2 -23483 17718 5884 2 -23441 17772 5887 2 -23381 17866 5841 2 -23373 17864 5880 2 -23448 17747 5938 2 -23529 17609 6026 2 -23509 17638 6018 2 -23443 17751 5942 2 -23368 17869 5887 2 -23294 17990 5812 2 -23313 18014 5657 2 -23284 18090 5532 2 -23266 18169 5345 2 -23253 18165 5415 2 -23262 18094 5611 2 -23197 18206 5519 2 -23184 18197 5600 2 -23125 18261 5636 2 -23093 18337 5522 2 -23018 18483 5342 2 -23042 18431 5419 2 -23078 18343 5562 2 -23011 18412 5610 2 -22968 18502 5487 2 -22954 18565 5333 2 -22933 18629 5200 2 -22815 18768 5220 2 -22889 18676 5225 2 -22920 18602 5352 2 -22935 18531 5527 2 -22854 18648 5470 2 -22798 18717 5471 2 -22692 18852 5446 2 -22624 18937 5435 2 -22551 19013 5474 2 -22457 19086 5605 2 -22495 19037 5618 2 -22599 18931 5561 2 -22690 18823 5554 2 -22737 18749 5614 2 -22797 18681 5594 2 -22839 18600 5693 2 -22867 18544 5763 2 -22929 18449 5820 2 -23015 18344 5812 2 -23146 18184 5796 2 -23082 18246 5859 2 -23004 18325 5918 2 -22904 18437 5955 2 -22804 18545 6006 2 -22707 18650 6049 2 -22635 18749 6013 2 -22561 18869 5913 2 -22484 18982 5846 2 -22408 19095 5768 2 -22318 19188 5806 2 -22263 19234 5867 2 -22411 19083 5793 2 -22458 18990 5916 2 -22488 18905 6073 2 -22389 18990 6171 2 -22304 19070 6232 2 -22151 19225 6302 2 -22111 19265 6322 2 -22014 19377 6319 2 -21956 19463 6253 2 -21883 19554 6226 2 -21724 19720 6259 2 -21805 19624 6278 2 -21786 19630 6328 2 -21696 19699 6420 2 -21613 19749 6545 2 -21543 19787 6662 2 -21483 19799 6816 2 -21431 19810 6949 2 -21371 19822 7096 2 -21240 19941 7156 2 -21223 19920 7263 2 -21161 19933 7409 2 -21118 19926 7547 2 -21027 19996 7619 2 -20987 20038 7618 2 -21079 19985 7502 2 -21024 20085 7389 2 -20967 20195 7250 2 -20852 20301 7285 2 -20787 20383 7239 2 -20672 20498 7247 2 -20551 20602 7296 2 -20447 20690 7337 2 -20337 20768 7421 2 -20289 20802 7459 2 -20261 20810 7514 2 -20186 20840 7630 2 -20094 20905 7694 2 -19973 21013 7715 2 -19976 20983 7789 2 -19914 21009 7877 2 -19860 21012 8005 2 -19780 21051 8099 2 -19695 21088 8209 2 -19586 21162 8280 2 -19506 21256 8228 2 -19478 21265 8272 2 -19438 21249 8403 2 -19312 21313 8532 2 -19282 21305 8620 2 -19189 21343 8733 2 -19084 21399 8827 2 -18977 21451 8930 2 -18856 21558 8928 2 -18864 21523 8997 2 -18868 21494 9057 2 -19046 21372 8971 2 -19014 21357 9074 2 -18948 21358 9210 2 -18876 21349 9377 2 -18914 21327 9351 2 -19044 21258 9244 2 -19051 21295 9143 2 -19118 21281 9036 2 -19221 21228 8939 2 -19380 21134 8819 2 -19445 21089 8784 2 -19549 21029 8695 2 -19652 20934 8692 2 -19748 20831 8723 2 -19789 20752 8816 2 -19809 20675 8952 2 -19727 20707 9058 2 -19632 20756 9153 2 -19524 20830 9216 2 -19401 20920 9271 2 -19319 20983 9301 2 -19220 21055 9341 2 -19197 21030 9445 2 -19114 21070 9525 2 -19012 21109 9642 2 -18919 21134 9767 2 -18827 21176 9856 2 -18715 21222 9969 2 -18622 21261 10058 2 -18499 21305 10192 2 -18477 21362 10112 2 -18441 21447 9997 2 -18461 21490 9867 2 -18491 21501 9787 2 -18596 21455 9687 2 -18624 21477 9587 2 -18688 21503 9402 2 -18722 21530 9270 2 -18700 21601 9149 2 -18695 21652 9038 2 -18712 21699 8891 2 -18632 21809 8787 2 -18564 21897 8711 2 -18524 21977 8594 2 -18390 22085 8606 2 -18267 22189 8601 2 -18265 22229 8502 2 -18373 22187 8375 2 -18368 22228 8279 2 -18367 22278 8144 2 -18414 22302 7973 2 -18382 22321 7992 2 -18303 22342 8115 2 -18261 22330 8240 2 -18228 22304 8384 2 -18118 22354 8486 2 -18006 22419 8554 2 -17886 22486 8628 2 -17804 22581 8549 2 -17743 22663 8460 2 -17754 22708 8316 2 -17797 22726 8172 2 -17864 22722 8038 2 -17938 22709 7907 2 -18027 22679 7791 2 -18126 22637 7683 2 -18220 22599 7570 2 -18318 22555 7464 2 -18416 22510 7358 2 -18522 22452 7268 2 -18625 22397 7175 2 -18740 22324 7101 2 -18852 22251 7034 2 -18968 22168 6985 2 -19081 22090 6925 2 -19195 22008 6870 2 -19304 21936 6794 2 -19419 21880 6647 2 -19366 21925 6653 2 -19262 21990 6741 2 -19141 22081 6788 2 -19033 22150 6863 2 -18916 22233 6920 2 -18803 22331 6911 2 -18787 22388 6771 2 -18813 22431 6552 2 -18789 22429 6626 2 -18773 22398 6774 2 -18761 22362 6926 2 -18653 22424 7017 2 -18535 22510 7055 2 -18421 22586 7110 2 -18290 22663 7204 2 -18206 22704 7283 2 -18114 22743 7393 2 -18028 22770 7517 2 -17908 22862 7527 2 -17795 22943 7545 2 -17656 23022 7632 2 -17579 23055 7710 2 -17509 23068 7830 2 -17428 23081 7973 2 -17370 23076 8111 2 -17301 23080 8247 2 -17238 23078 8384 2 -17178 23072 8521 2 -17114 23071 8651 2 -17039 23078 8778 2 -16983 23069 8909 2 -16931 23037 9090 2 -16887 23034 9180 2 -16788 23054 9310 2 -16714 23059 9429 2 -16638 23066 9547 2 -16530 23112 9622 2 -16396 23184 9678 2 -16267 23249 9739 2 -16152 23324 9751 2 -16020 23395 9799 2 -15921 23419 9904 2 -15797 23459 10006 2 -15716 23463 10124 2 -15625 23484 10216 2 -15493 23548 10269 2 -15373 23597 10338 2 -15229 23679 10362 2 -15155 23764 10276 2 -15169 23817 10133 2 -15102 23837 10185 2 -15015 23913 10137 2 -14935 23981 10093 2 -14838 24056 10057 2 -14803 24132 9925 2 -14824 24180 9776 2 -14980 24142 9632 2 -14885 24212 9604 2 -14821 24289 9507 2 -14833 24329 9385 2 -14913 24334 9243 2 -14925 24303 9307 2 -14955 24292 9286 2 -15065 24265 9181 2 -15192 24206 9126 2 -15299 24159 9071 2 -15427 24114 8975 2 -15552 24055 8917 2 -15533 24079 8884 2 -15479 24176 8713 2 -15426 24163 8844 2 -15308 24213 8910 2 -15207 24235 9022 2 -15036 24297 9140 2 -15134 24286 9006 2 -15064 24308 9065 2 -14958 24335 9167 2 -14851 24374 9240 2 -14697 24423 9354 2 -14676 24483 9230 2 -14728 24505 9089 2 -14771 24532 8946 2 -14738 24604 8800 2 -14890 24546 8704 2 -14811 24594 8704 2 -14797 24634 8616 2 -14891 24623 8482 2 -14791 24706 8416 2 -14720 24782 8316 2 -14731 24821 8181 2 -14707 24883 8033 2 -14678 24948 7883 2 -14606 25022 7782 2 -14553 25097 7637 2 -14566 25078 7678 2 -14507 25080 7781 2 -14347 25162 7812 2 -14310 25225 7675 2 -14284 25288 7514 2 -14199 25329 7537 2 -14105 25411 7439 2 -14084 25451 7341 2 -14133 25463 7206 2 -14080 25488 7222 2 -13988 25542 7207 2 -14040 25552 7069 2 -14023 25572 7032 2 -13867 25646 7071 2 -13808 25707 6964 2 -13836 25723 6847 2 -13776 25761 6824 2 -13713 25818 6736 2 -13644 25875 6659 2 -13542 25958 6541 2 -13534 25982 6462 2 -13514 26002 6425 2 -13440 26051 6379 2 -13551 26009 6315 2 -13681 25940 6320 2 -13827 25852 6363 2 -13926 25804 6341 2 -14022 25746 6366 2 -14071 25718 6373 2 -14166 25677 6324 2 -14316 25579 6383 2 -14282 25606 6354 2 -14265 25647 6225 2 -14412 25576 6177 2 -14522 25534 6091 2 -14674 25461 6033 2 -14624 25508 5958 2 -14545 25568 5891 2 -14602 25547 5842 2 -14734 25471 5845 2 -14894 25410 5699 2 -14833 25436 5746 2 -14724 25479 5834 2 -14581 25564 5821 2 -14487 25634 5748 2 -14450 25684 5615 2 -14513 25677 5483 2 -14630 25637 5355 2 -14543 25688 5352 2 -14462 25720 5418 2 -14351 25790 5376 2 -14251 25864 5288 2 -14133 25938 5243 2 -14118 25971 5117 2 -14154 25985 4945 2 -14145 25985 4972 2 -14100 25983 5109 2 -14016 26012 5188 2 -13888 26094 5123 2 -13759 26163 5119 2 -13634 26229 5112 2 -13697 26213 5027 2 -13677 26249 4889 2 -13706 26261 4745 2 -13708 26287 4589 2 -13619 26350 4494 2 -13553 26398 4408 2 -13493 26449 4287 2 -13453 26484 4193 2 -13386 26536 4082 2 -13329 26586 3943 2 -13376 26580 3823 2 -13494 26536 3706 2 -13493 26556 3569 2 -13537 26551 3433 2 -13499 26591 3270 2 -13485 26616 3121 2 -13513 26618 2983 2 -13628 26570 2883 2 -13762 26500 2893 2 -13884 26428 2962 2 -13974 26369 3061 2 -14115 26294 3065 2 -14241 26230 3029 2 -14316 26182 3092 2 -14426 26112 3165 2 -14562 26031 3217 2 -14643 25976 3289 2 -14790 25895 3271 2 -14907 25834 3224 2 -15013 25776 3192 2 -15140 25711 3121 2 -15256 25645 3098 2 -15328 25594 3166 2 -15389 25540 3300 2 -15443 25489 3438 2 -15515 25429 3555 2 -15611 25358 3646 2 -15717 25281 3721 2 -15831 25201 3783 2 -15952 25118 3823 2 -16075 25035 3853 2 -16200 24952 3870 2 -16326 24873 3846 2 -16458 24796 3777 2 -16564 24734 3723 2 -16675 24673 3633 2 -16774 24620 3534 2 -16865 24573 3425 2 -16946 24534 3303 2 -17046 24486 3139 2 -17127 24427 3163 2 -17234 24338 3260 2 -17309 24275 3334 2 -17422 24188 3377 2 -17527 24109 3406 2 -17657 24006 3454 2 -17760 23921 3515 2 -17869 23832 3570 2 -17971 23742 3654 2 -18082 23661 3629 2 -18195 23585 3563 2 -18366 23445 3614 2 -18332 23487 3511 2 -18336 23498 3410 2 -18450 23417 3355 2 -18599 23284 3452 2 -18558 23327 3389 2 -18498 23391 3267 2 -18498 23412 3120 2 -18603 23344 2996 2 -18581 23362 2997 2 -18470 23438 3089 2 -18359 23530 3044 2 -18280 23605 2942 2 -18226 23661 2822 2 -18186 23710 2659 2 -18126 23755 2672 2 -18019 23847 2581 2 -17934 23922 2478 2 -17831 24003 2425 2 -17717 24086 2442 2 -17600 24174 2419 2 -17482 24262 2394 2 -17385 24339 2319 2 -17257 24430 2318 2 -17129 24518 2335 2 -17012 24604 2282 2 -17002 24626 2125 2 -17000 24642 1945 2 -16999 24649 1866 2 -17000 24659 1714 2 -17023 24653 1565 2 -17090 24616 1409 2 -17030 24657 1419 2 -16938 24726 1326 2 -16874 24775 1201 2 -16838 24806 1057 2 -16795 24841 914 2 -16761 24870 755 2 -16686 24923 669 2 -16582 24994 577 2 -16508 25045 453 2 -16423 25103 334 2 -16383 25131 197 2 -16347 25155 50 2 -16282 25197 -84 2 -16232 25228 -219 2 -16243 25220 -366 2 -16287 25189 -506 2 -16327 25158 -706 2 -16217 25230 -696 2 -16093 25308 -708 2 -15970 25385 -757 2 -15843 25463 -784 2 -15722 25537 -827 2 -15576 25625 -872 2 -15525 25651 -1003 2 -15557 25626 -1135 2 -15696 25539 -1174 2 -15687 25544 -1185 2 -15559 25624 -1157 2 -15492 25662 -1217 2 -15380 25725 -1295 2 -15256 25800 -1264 2 -15129 25875 -1267 2 -14991 25955 -1257 2 -14870 26027 -1224 2 -14730 26107 -1198 2 -14619 26173 -1128 2 -14496 26244 -1048 2 -14375 26312 -1001 2 -14261 26377 -950 2 -14150 26439 -851 2 -14065 26486 -800 2 -13964 26542 -729 2 -13953 26549 -664 2 -13858 26600 -637 2 -13810 26627 -531 2 -13747 26660 -541 2 -13687 26691 -507 2 -13700 26687 -346 2 -13635 26721 -205 2 -13529 26776 -164 2 -13424 26828 -216 2 -13352 26863 -346 2 -13315 26878 -514 2 -13232 26917 -604 2 -13186 26936 -765 2 -13107 26972 -840 2 -13104 26975 -791 2 -13183 26940 -661 2 -13242 26914 -500 2 -13277 26899 -369 2 -13336 26872 -241 2 -13318 26881 -105 2 -13200 26940 -13 2 -13099 26989 19 2 -13130 26974 132 2 -13146 26965 258 2 -13096 26988 390 2 -12993 27036 468 2 -12866 27096 533 2 -12756 27146 597 2 -12615 27211 657 2 -12538 27249 561 2 -12540 27250 417 2 -12525 27259 263 2 -12447 27296 149 2 -12341 27344 55 2 -12273 27374 -76 2 -12254 27382 -243 2 -12231 27393 -219 2 -12256 27382 -30 2 -12249 27385 82 2 -12349 27340 253 2 -12410 27311 321 2 -12499 27269 437 2 -12487 27271 594 2 -12384 27316 688 2 -12263 27369 765 2 -12135 27423 842 2 -11976 27496 727 2 -11916 27518 875 2 -11977 27488 986 2 -12019 27464 1131 2 -12022 27457 1254 2 -11983 27472 1300 2 -11852 27533 1215 2 -11714 27597 1077 2 -11749 27578 1187 2 -11808 27550 1255 2 -11924 27496 1340 2 -11878 27510 1449 2 -11785 27544 1563 2 -11670 27589 1628 2 -11569 27626 1722 2 -11417 27688 1746 2 -11298 27740 1691 2 -11202 27785 1584 2 -11067 27842 1527 2 -10958 27890 1446 2 -10902 27909 1500 2 -10836 27928 1622 2 -10702 27982 1575 2 -10582 28027 1589 2 -10503 28064 1451 2 -10426 28100 1302 2 -10385 28113 1347 2 -10335 28132 1324 2 -10341 28137 1174 2 -10296 28159 1028 2 -10318 28157 858 2 -10419 28120 824 2 -10546 28073 843 2 -10673 28021 946 2 -10800 27973 927 2 -10889 27942 827 2 -11037 27884 816 2 -11181 27827 786 2 -11303 27780 722 2 -11478 27709 692 2 -11595 27663 566 2 -11508 27701 477 2 -11396 27749 383 2 -11265 27803 327 2 -11112 27864 353 2 -11021 27899 416 2 -10880 27955 385 2 -10764 28001 306 2 -10653 28044 176 2 -10734 28014 69 2 -10888 27954 46 2 -11050 27891 -26 2 -10974 27921 -101 2 -10831 27976 -97 2 -10635 28051 -188 2 -10549 28084 -110 2 -10478 28110 -208 2 -10467 28113 -310 2 -10413 28131 -457 2 -10325 28164 -431 2 -10168 28222 -363 2 -10052 28263 -368 2 -9932 28305 -423 2 -9807 28347 -499 2 -9649 28402 -491 2 -9521 28444 -546 2 -9389 28485 -658 2 -9319 28507 -733 2 -9296 28512 -811 2 -9421 28467 -928 2 -9535 28428 -955 2 -9611 28398 -1082 2 -9734 28355 -1114 2 -9894 28302 -1059 2 -10004 28260 -1129 2 -10140 28211 -1151 2 -10282 28162 -1080 2 -10371 28133 -972 2 -10426 28117 -848 2 -10497 28095 -698 2 -10580 28065 -660 2 -10581 28064 -694 2 -10548 28075 -727 2 -10655 28033 -785 2 -10786 27981 -854 2 -10773 27989 -735 2 -10905 27940 -687 2 -11001 27900 -771 2 -11109 27854 -862 2 -11166 27827 -1005 2 -11249 27790 -1093 2 -11374 27739 -1091 2 -11515 27682 -1067 2 -11659 27621 -1081 2 -11700 27599 -1173 2 -11795 27558 -1199 2 -11681 27604 -1251 2 -11643 27626 -1116 2 -11530 27671 -1176 2 -11402 27720 -1256 2 -11284 27770 -1224 2 -11103 27845 -1175 2 -11123 27833 -1271 2 -11054 27859 -1298 2 -10922 27903 -1450 2 -10953 27885 -1572 2 -11001 27862 -1645 2 -11150 27804 -1609 2 -11169 27804 -1479 2 -11298 27754 -1438 2 -11265 27760 -1569 2 -11119 27814 -1652 2 -11186 27785 -1690 2 -11216 27765 -1817 2 -11157 27780 -1954 2 -11134 27777 -2118 2 -11147 27761 -2259 2 -11104 27766 -2399 2 -11010 27792 -2525 2 -10895 27829 -2619 2 -10857 27828 -2785 2 -10732 27869 -2857 2 -10617 27906 -2927 2 -10475 27960 -2921 2 -10373 27988 -3013 2 -10388 27966 -3162 2 -10400 27944 -3312 2 -10412 27922 -3458 2 -10550 27861 -3529 2 -10593 27861 -3401 2 -10587 27880 -3257 2 -10567 27909 -3070 2 -10642 27875 -3117 2 -10684 27847 -3221 2 -10693 27821 -3411 2 -10801 27769 -3493 2 -10955 27709 -3489 2 -11107 27650 -3482 2 -11215 27600 -3532 2 -11389 27521 -3586 2 -11321 27544 -3626 2 -11137 27612 -3684 2 -11087 27643 -3599 2 -10905 27708 -3656 2 -10867 27713 -3730 2 -10728 27760 -3779 2 -10609 27795 -3856 2 -10570 27795 -3967 2 -10574 27771 -4121 2 -10542 27761 -4266 2 -10506 27751 -4415 2 -10438 27756 -4547 2 -10354 27765 -4678 2 -10227 27790 -4810 2 -10113 27847 -4722 2 -10127 27864 -4587 2 -10080 27896 -4496 2 -9938 27943 -4519 2 -9806 27980 -4581 2 -9698 27994 -4720 2 -9677 27983 -4830 2 -9590 27994 -4935 2 -9474 28014 -5048 2 -9342 28046 -5115 2 -9229 28065 -5215 2 -9117 28083 -5314 2 -8977 28119 -5358 2 -8846 28148 -5425 2 -8748 28156 -5540 2 -8710 28144 -5662 2 -8792 28091 -5793 2 -8730 28084 -5925 2 -8588 28141 -5857 2 -8453 28195 -5798 2 -8413 28196 -5849 2 -8495 28146 -5967 2 -8584 28093 -6092 2 -8505 28094 -6195 2 -8358 28137 -6201 2 -8223 28186 -6161 2 -8082 28234 -6125 2 -7912 28279 -6141 2 -7981 28243 -6218 2 -8036 28196 -6356 2 -8045 28159 -6506 2 -7973 28153 -6623 2 -7953 28124 -6766 2 -8019 28064 -6936 2 -7933 28088 -6939 2 -7880 28070 -7070 2 -7878 28038 -7199 2 -7941 27989 -7317 2 -7917 27970 -7418 2 -7847 28016 -7317 2 -7835 28055 -7180 2 -7819 28097 -7029 2 -7868 28117 -6893 2 -7893 28141 -6767 2 -7860 28204 -6540 2 -7761 28211 -6628 2 -7748 28179 -6775 2 -7704 28147 -6955 2 -7674 28132 -7050 2 -7679 28093 -7201 2 -7639 28066 -7343 2 -7643 28025 -7496 2 -7753 27970 -7588 2 -7708 27975 -7615 2 -7623 27969 -7721 2 -7515 27980 -7787 2 -7390 27990 -7869 2 -7252 28011 -7924 2 -7078 28049 -7948 2 -6958 28076 -7959 2 -6802 28111 -7970 2 -6685 28120 -8037 2 -6550 28128 -8120 2 -6415 28150 -8150 2 -6270 28180 -8159 2 -6118 28206 -8185 2 -6013 28201 -8281 2 -5913 28189 -8392 2 -5777 28206 -8429 2 -5631 28223 -8472 2 -5507 28224 -8550 2 -5356 28244 -8577 2 -5216 28263 -8603 2 -5069 28279 -8636 2 -4945 28273 -8727 2 -4830 28267 -8813 2 -4670 28287 -8833 2 -4548 28333 -8751 2 -4412 28349 -8769 2 -4288 28336 -8869 2 -4127 28371 -8834 2 -4040 28342 -8965 2 -3985 28375 -8888 2 -3846 28417 -8812 2 -3773 28392 -8924 2 -3731 28354 -9062 2 -3627 28334 -9166 2 -3494 28331 -9227 2 -3445 28297 -9350 2 -3486 28257 -9454 2 -3420 28273 -9431 2 -3314 28258 -9513 2 -3174 28232 -9638 2 -3108 28217 -9702 2 -3071 28175 -9836 2 -3044 28129 -9974 2 -3055 28076 -10119 2 -3014 28032 -10254 2 -2925 27998 -10370 2 -2790 27986 -10441 2 -2642 27983 -10487 2 -2595 27954 -10575 2 -2575 27894 -10736 2 -2625 27871 -10785 2 -2761 27836 -10842 2 -2901 27803 -10889 2 -3021 27768 -10946 2 -3159 27721 -11025 2 -3240 27665 -11142 2 -3349 27629 -11198 2 -3509 27626 -11157 2 -3667 27608 -11151 2 -3735 27541 -11294 2 -3852 27535 -11270 2 -4010 27522 -11245 2 -3943 27493 -11340 2 -3803 27510 -11347 2 -3598 27573 -11259 2 -3658 27539 -11322 2 -3837 27469 -11433 2 -3795 27421 -11562 2 -3650 27418 -11617 2 -3509 27424 -11646 2 -3353 27447 -11638 2 -3324 27520 -11472 2 -3182 27525 -11500 2 -3075 27497 -11595 2 -2988 27457 -11714 2 -2918 27436 -11779 2 -2791 27412 -11866 2 -2695 27375 -11973 2 -2590 27343 -12069 2 -2610 27309 -12142 2 -2802 27273 -12179 2 -2949 27258 -12179 2 -2887 27231 -12252 2 -2937 27185 -12342 2 -3001 27138 -12431 2 -3114 27093 -12501 2 -3265 27076 -12498 2 -3389 27076 -12466 2 -3516 27094 -12391 2 -3710 27086 -12352 2 -3810 27069 -12360 2 -3878 27082 -12309 2 -3969 27129 -12176 2 -4086 27157 -12074 2 -4194 27134 -12089 2 -4155 27072 -12241 2 -4241 27018 -12330 2 -4320 26954 -12442 2 -4354 26891 -12566 2 -4282 26845 -12690 2 -4123 26842 -12747 2 -4046 26811 -12837 2 -3979 26761 -12961 2 -3838 26749 -13030 2 -3714 26787 -12987 2 -3634 26748 -13089 2 -3608 26674 -13247 2 -3651 26611 -13360 2 -3542 26599 -13415 2 -3487 26539 -13548 2 -3479 26464 -13695 2 -3433 26411 -13807 2 -3481 26358 -13896 2 -3604 26284 -14006 2 -3661 26311 -13940 2 -3722 26371 -13810 2 -3726 26363 -13824 2 -3689 26299 -13956 2 -3766 26245 -14037 2 -3903 26209 -14067 2 -4065 26218 -14002 2 -4126 26176 -14063 2 -4012 26157 -14132 2 -3852 26203 -14091 2 -3766 26142 -14226 2 -3833 26088 -14308 2 -3962 26039 -14363 2 -4091 25972 -14447 2 -4210 25930 -14489 2 -4348 25940 -14429 2 -4464 25973 -14334 2 -4468 26038 -14215 2 -4502 26129 -14036 2 -4496 26086 -14118 2 -4544 26028 -14209 2 -4634 25951 -14321 2 -4731 25880 -14417 2 -4742 25808 -14542 2 -4795 25749 -14629 2 -4838 25714 -14676 2 -4855 25629 -14819 2 -4957 25617 -14805 2 -5029 25666 -14696 2 -5160 25710 -14573 2 -5307 25679 -14575 2 -5419 25675 -14541 2 -5616 25583 -14628 2 -5612 25670 -14477 2 -5707 25719 -14351 2 -5688 25702 -14389 2 -5765 25629 -14488 2 -5885 25634 -14432 2 -5989 25669 -14327 2 -6052 25722 -14203 2 -6062 25716 -14210 2 -6067 25644 -14339 2 -6016 25580 -14474 2 -6073 25500 -14590 2 -6060 25425 -14725 2 -6129 25329 -14862 2 -6135 25305 -14900 2 -6029 25270 -15003 2 -5962 25213 -15125 2 -5929 25119 -15294 2 -5847 25085 -15381 2 -5758 25048 -15474 2 -5662 24999 -15589 2 -5599 24937 -15710 2 -5640 24841 -15847 2 -5554 24818 -15913 2 -5424 24862 -15889 2 -5299 24846 -15956 2 -5200 24802 -16058 2 -5117 24727 -16199 2 -5075 24669 -16300 2 -4984 24629 -16388 2 -4948 24558 -16505 2 -4992 24577 -16463 2 -5129 24604 -16381 2 -5256 24602 -16344 2 -5313 24654 -16247 2 -5350 24738 -16106 2 -5443 24716 -16109 2 -5584 24721 -16053 2 -5674 24748 -15979 2 -5771 24800 -15863 2 -5872 24780 -15857 2 -5904 24799 -15816 2 -5977 24839 -15726 2 -6104 24888 -15600 2 -6147 24933 -15510 2 -6121 24996 -15418 2 -6207 25036 -15320 2 -6303 25084 -15201 2 -6398 25125 -15094 2 -6477 25169 -14985 2 -6487 25238 -14865 2 -6537 25300 -14737 2 -6606 25342 -14634 2 -6680 25390 -14516 2 -6751 25446 -14384 2 -6842 25477 -14287 2 -6861 25531 -14181 2 -6892 25598 -14045 2 -6961 25659 -13897 2 -6886 25714 -13833 2 -6721 25748 -13851 2 -6708 25825 -13714 2 -6756 25890 -13567 2 -6823 25921 -13474 2 -6881 25967 -13355 2 -6791 26040 -13259 2 -6832 26050 -13218 2 -6879 26107 -13080 2 -6915 26171 -12932 2 -6932 26230 -12803 2 -7007 26272 -12677 2 -7089 26310 -12551 2 -7249 26341 -12395 2 -7237 26300 -12488 2 -7414 26227 -12538 2 -7325 26224 -12595 2 -7187 26234 -12653 2 -7099 26200 -12774 2 -7053 26151 -12898 2 -7114 26073 -13023 2 -7113 26006 -13156 2 -7121 25934 -13294 2 -7268 25900 -13280 2 -7287 25854 -13360 2 -7210 25809 -13487 2 -7310 25770 -13508 2 -7418 25787 -13417 2 -7499 25859 -13231 2 -7562 25877 -13161 2 -7605 25928 -13035 2 -7666 25979 -12897 2 -7815 25972 -12821 2 -7843 26028 -12690 2 -7822 26095 -12565 2 -7753 26111 -12574 2 -7719 26124 -12568 2 -7672 26170 -12501 2 -7648 26226 -12398 2 -7685 26275 -12270 2 -7712 26248 -12310 2 -7804 26228 -12295 2 -7906 26232 -12222 2 -7995 26265 -12092 2 -8007 26238 -12144 2 -8118 26181 -12193 2 -8260 26140 -12185 2 -8393 26087 -12207 2 -8480 26133 -12048 2 -8528 26087 -12113 2 -8663 26034 -12131 2 -8794 25993 -12126 2 -8924 25994 -12028 2 -9033 26005 -11921 2 -9163 25996 -11843 2 -9340 25982 -11734 2 -9443 25937 -11752 2 -9583 25908 -11701 2 -9689 25914 -11601 2 -9728 25966 -11450 2 -9846 25950 -11388 2 -9837 25924 -11453 2 -9826 25878 -11566 2 -9929 25824 -11600 2 -10043 25792 -11573 2 -10197 25751 -11529 2 -10339 25702 -11511 2 -10502 25629 -11527 2 -10611 25581 -11532 2 -10787 25530 -11483 2 -10853 25540 -11398 2 -10866 25578 -11299 2 -10736 25634 -11297 2 -10607 25677 -11321 2 -10578 25705 -11286 2 -10717 25684 -11202 2 -10797 25669 -11159 2 -10951 25568 -11241 2 -11086 25524 -11207 2 -11101 25549 -11136 2 -10986 25628 -11068 2 -10826 25735 -10977 2 -10751 25798 -10902 2 -10786 25782 -10906 2 -10903 25706 -10969 2 -11018 25640 -11009 2 -11159 25559 -11054 2 -11302 25544 -10944 2 -11418 25473 -10990 2 -11554 25414 -10984 2 -11681 25335 -11033 2 -11763 25268 -11097 2 -11828 25218 -11142 2 -11971 25162 -11116 2 -12119 25092 -11115 2 -12225 25031 -11134 2 -12422 24945 -11111 2 -12460 24882 -11209 2 -12559 24774 -11336 2 -12570 24811 -11243 2 -12607 24874 -11062 2 -12711 24823 -11057 2 -12824 24745 -11100 2 -12955 24646 -11169 2 -12994 24598 -11230 2 -13084 24529 -11276 2 -13136 24551 -11166 2 -13100 24629 -11037 2 -13021 24706 -10957 2 -12927 24788 -10883 2 -12904 24809 -10862 2 -13035 24703 -10947 2 -13123 24614 -11043 2 -13145 24618 -11008 2 -13069 24710 -10891 2 -13107 24702 -10865 2 -13190 24594 -11006 2 -13208 24549 -11086 2 -13264 24474 -11185 2 -13349 24406 -11232 2 -13289 24418 -11276 2 -13364 24358 -11318 2 -13492 24337 -11212 2 -13506 24302 -11268 2 -13513 24256 -11359 2 -13639 24185 -11360 2 -13793 24108 -11339 2 -13791 24153 -11244 2 -13773 24230 -11100 2 -13829 24215 -11064 2 -13920 24125 -11144 2 -14083 24079 -11041 2 -14034 24088 -11083 2 -13916 24116 -11170 2 -13924 24085 -11226 2 -14060 24007 -11223 2 -14214 23920 -11216 2 10146 -28113 2593 0 10082 -28127 2692 2 10002 -28145 2798 2 9908 -28166 2916 2 9791 -28198 3005 2 9649 -28247 2996 2 9524 -28289 3001 2 9396 -28324 3073 2 9245 -28371 3096 2 9099 -28421 3078 2 8966 -28467 3043 2 8815 -28512 3057 2 8686 -28544 3131 2 8552 -28578 3185 2 8452 -28596 3293 2 8467 -28573 3446 2 8553 -28535 3547 2 8719 -28482 3569 2 8833 -28444 3595 2 8973 -28405 3559 2 9108 -28368 3508 2 9251 -28321 3514 2 9396 -28266 3572 2 9272 -28298 3639 2 9300 -28275 3749 2 9385 -28234 3844 2 9533 -28184 3845 2 9579 -28184 3729 2 9705 -28146 3689 2 9803 -28101 3774 2 9901 -28074 3720 2 9988 -28043 3720 2 10105 -27995 3765 2 10240 -27945 3775 2 10363 -27900 3771 2 10468 -27847 3869 2 10608 -27784 3938 2 10569 -27783 4048 2 10505 -27787 4185 2 10472 -27777 4333 2 10430 -27770 4477 2 10391 -27761 4625 2 10353 -27749 4773 2 10316 -27738 4919 2 10288 -27722 5067 2 10201 -27732 5187 2 10131 -27735 5304 2 10089 -27720 5460 2 10057 -27705 5593 2 10013 -27692 5734 2 9933 -27694 5864 2 9928 -27670 5981 2 9921 -27641 6129 2 9889 -27620 6272 2 9854 -27599 6419 2 9941 -27559 6455 2 10037 -27519 6477 2 10018 -27489 6633 2 10029 -27451 6773 2 10060 -27404 6914 2 10017 -27383 7058 2 9934 -27380 7187 2 9848 -27379 7309 2 9735 -27392 7411 2 9624 -27403 7515 2 9482 -27441 7555 2 9345 -27477 7596 2 9207 -27512 7636 2 9091 -27571 7562 2 9035 -27625 7432 2 8973 -27652 7406 2 8924 -27629 7549 2 8872 -27610 7680 2 8728 -27637 7745 2 8702 -27685 7604 2 8613 -27719 7582 2 8475 -27747 7632 2 8383 -27748 7733 2 8457 -27697 7832 2 8408 -27675 7963 2 8281 -27725 7921 2 8140 -27758 7953 2 8016 -27771 8033 2 7867 -27808 8050 2 7737 -27823 8124 2 7605 -27837 8201 2 7458 -27879 8192 2 7314 -27905 8236 2 7171 -27934 8263 2 7024 -27967 8278 2 6886 -28005 8264 2 6776 -28066 8149 2 6671 -28115 8065 2 6478 -28164 8052 2 6516 -28123 8162 2 6415 -28154 8137 2 6343 -28131 8270 2 6470 -28084 8332 2 6419 -28074 8406 2 6258 -28123 8363 2 6225 -28095 8480 2 6268 -28055 8580 2 6212 -28025 8718 2 6193 -27983 8864 2 6229 -27930 9006 2 6143 -27914 9114 2 5998 -27951 9098 2 5901 -28003 9001 2 5773 -28054 8925 2 5627 -28092 8899 2 5478 -28121 8898 2 5330 -28151 8896 2 5189 -28158 8956 2 5048 -28168 9004 2 4899 -28192 9012 2 4749 -28212 9031 2 4608 -28219 9080 2 4458 -28237 9098 2 4311 -28251 9126 2 4162 -28267 9145 2 4013 -28282 9167 2 3871 -28285 9217 2 3759 -28266 9322 2 3626 -28260 9393 2 3510 -28242 9489 2 3398 -28222 9590 2 3273 -28207 9676 2 3152 -28191 9763 2 2993 -28210 9760 2 2843 -28229 9750 2 2692 -28241 9756 2 2557 -28232 9820 2 2425 -28228 9864 2 2269 -28242 9861 2 2151 -28277 9788 2 2037 -28314 9703 2 1884 -28310 9745 2 1796 -28276 9860 2 1715 -28239 9981 2 1603 -28207 10089 2 1568 -28233 10021 2 1492 -28266 9939 2 1377 -28228 10065 2 1260 -28259 9992 2 1150 -28293 9909 2 998 -28299 9908 2 846 -28306 9902 2 699 -28319 9877 2 554 -28335 9840 2 410 -28351 9800 2 278 -28377 9730 2 139 -28398 9671 2 30 -28431 9574 2 -69 -28467 9466 2 -159 -28431 9574 2 -286 -28436 9557 2 -382 -28416 9612 2 -499 -28411 9621 2 -646 -28419 9589 2 -796 -28420 9575 2 -945 -28434 9519 2 -1028 -28406 9595 2 -970 -28364 9724 2 -990 -28322 9842 2 -1116 -28335 9793 2 -1202 -28372 9673 2 -1256 -28416 9537 2 -1241 -28469 9381 2 -1376 -28490 9296 2 -1458 -28441 9433 2 -1528 -28395 9559 2 -1647 -28359 9647 2 -1728 -28378 9577 2 -1750 -28424 9434 2 -1819 -28467 9290 2 -1959 -28429 9379 2 -2002 -28462 9269 2 -1888 -28499 9178 2 -1817 -28543 9056 2 -1847 -28585 8916 2 -1918 -28620 8787 2 -2015 -28649 8671 2 -2153 -28658 8606 2 -2130 -28683 8529 2 -2137 -28715 8419 2 -2273 -28722 8361 2 -2377 -28746 8248 2 -2391 -28797 8065 2 -2370 -28825 7969 2 -2312 -28846 7911 2 -2180 -28837 7979 2 -2053 -28822 8065 2 -2026 -28850 7973 2 -2123 -28873 7863 2 -2190 -28903 7733 2 -2269 -28930 7608 2 -2316 -28962 7474 2 -2321 -28999 7326 2 -2352 -29032 7185 2 -2304 -29072 7035 2 -2440 -29082 6951 2 -2544 -29092 6868 2 -2655 -29102 6783 2 -2780 -29106 6717 2 -2900 -29114 6630 2 -3017 -29124 6533 2 -3107 -29144 6401 2 -3176 -29160 6294 2 -3269 -29175 6173 2 -3336 -29196 6041 2 -3374 -29221 5897 2 -3429 -29242 5756 2 -3460 -29267 5608 2 -3537 -29283 5477 2 -3564 -29307 5330 2 -3561 -29334 5181 2 -3557 -29360 5032 2 -3535 -29388 4884 2 -3480 -29417 4747 2 -3377 -29446 4641 2 -3227 -29464 4635 2 -3082 -29484 4604 2 -2948 -29491 4650 2 -2868 -29478 4779 2 -2790 -29464 4907 2 -2658 -29454 5042 2 -2642 -29468 4966 2 -2674 -29489 4819 2 -2670 -29515 4664 2 -2508 -29536 4622 2 -2415 -29560 4514 2 -2447 -29578 4376 2 -2543 -29588 4252 2 -2608 -29601 4118 2 -2698 -29610 3996 2 -2767 -29621 3862 2 -2846 -29630 3734 2 -2890 -29644 3588 2 -2947 -29655 3449 2 -2969 -29670 3302 2 -2910 -29691 3159 2 -2971 -29698 3030 2 -3095 -29694 2944 2 -3185 -29697 2824 2 -3242 -29703 2685 2 -3278 -29712 2539 2 -3299 -29722 2390 2 -3269 -29737 2242 2 -3198 -29754 2109 2 -3123 -29773 1946 2 -3228 -29763 1943 2 -3362 -29744 1997 2 -3507 -29730 1954 2 -3651 -29716 1902 2 -3793 -29702 1852 2 -3933 -29687 1798 2 -4074 -29671 1743 2 -4210 -29656 1675 2 -4334 -29643 1589 2 -4434 -29634 1475 2 -4549 -29621 1378 2 -4675 -29605 1292 2 -4819 -29584 1259 2 -4964 -29562 1210 2 -5090 -29548 999 2 -5080 -29546 1102 2 -5142 -29530 1234 2 -5270 -29505 1300 2 -5411 -29481 1270 2 -5468 -29476 1138 2 -5507 -29474 987 2 -5400 -29496 904 2 -5436 -29491 857 2 -5578 -29466 801 2 -5687 -29448 707 2 -5834 -29419 676 2 -5990 -29389 642 2 -6021 -29380 734 2 -5885 -29406 813 2 -5773 -29425 912 2 -5719 -29431 1053 2 -5738 -29422 1203 2 -5846 -29397 1288 2 -5979 -29372 1231 2 -6067 -29359 1107 2 -6174 -29341 978 2 -6288 -29317 992 2 -6264 -29318 1112 2 -6180 -29330 1241 2 -6120 -29337 1379 2 -6043 -29346 1508 2 -5960 -29357 1632 2 -6010 -29338 1776 2 -6129 -29307 1874 2 -6243 -29288 1795 2 -6290 -29287 1647 2 -6413 -29265 1570 2 -6549 -29237 1516 2 -6692 -29207 1474 2 -6834 -29176 1437 2 -6973 -29144 1426 2 -7089 -29110 1534 2 -7029 -29118 1661 2 -6890 -29149 1693 2 -6761 -29175 1757 2 -6691 -29183 1891 2 -6630 -29188 2030 2 -6569 -29191 2169 2 -6515 -29192 2316 2 -6606 -29162 2431 2 -6642 -29143 2567 2 -6645 -29129 2715 2 -6640 -29115 2867 2 -6661 -29096 3015 2 -6691 -29073 3160 2 -6721 -29050 3309 2 -6827 -29019 3359 2 -6923 -28986 3445 2 -7035 -28945 3561 2 -6940 -28962 3609 2 -6946 -28949 3702 2 -7063 -28910 3787 2 -7153 -28874 3892 2 -7247 -28842 3954 2 -7287 -28825 4005 2 -7348 -28794 4115 2 -7478 -28764 4086 2 -7609 -28727 4104 2 -7543 -28731 4201 2 -7518 -28722 4304 2 -7627 -28683 4374 2 -7783 -28644 4353 2 -7903 -28618 4308 2 -7957 -28587 4411 2 -8081 -28546 4456 2 -8196 -28535 4308 2 -8234 -28515 4369 2 -8205 -28500 4520 2 -8314 -28469 4517 2 -8376 -28444 4560 2 -8440 -28408 4663 2 -8586 -28357 4705 2 -8697 -28334 4640 2 -8769 -28301 4707 2 -8903 -28262 4692 2 -8999 -28218 4772 2 -9155 -28168 4769 2 -9284 -28114 4837 2 -9418 -28073 4816 2 -9552 -28034 4778 2 -9702 -27974 4832 2 -9819 -27932 4835 2 -9846 -27896 4987 2 -9899 -27885 4943 2 -9905 -27911 4784 2 -9792 -27955 4754 2 -9812 -27959 4696 2 -9894 -27950 4575 2 -10019 -27902 4596 2 -10103 -27852 4713 2 -10185 -27830 4666 2 -10332 -27767 4716 2 -10452 -27715 4760 2 -10491 -27677 4892 2 -10591 -27621 4989 2 -10614 -27580 5166 2 -10732 -27519 5248 2 -10803 -27467 5371 2 -10601 -27527 5467 2 -10715 -27467 5547 2 -10622 -27474 5686 2 -10602 -27455 5817 2 -10623 -27416 5959 2 -10696 -27402 5892 2 -10714 -27427 5740 2 -10856 -27383 5683 2 -10944 -27318 5826 2 -11041 -27273 5857 2 -11092 -27227 5970 2 -11110 -27185 6127 2 -11152 -27137 6260 2 -11190 -27090 6398 2 -11172 -27061 6548 2 -11086 -27070 6656 2 -11126 -27035 6731 2 -11223 -26969 6833 2 -11270 -26917 6962 2 -11272 -26877 7113 2 -11216 -26859 7265 2 -11311 -26800 7337 2 -11396 -26792 7233 2 -11403 -26827 7089 2 -11431 -26857 6933 2 -11406 -26905 6786 2 -11421 -26930 6658 2 -11445 -26952 6526 2 -11450 -26986 6375 2 -11377 -27045 6255 2 -11354 -27085 6122 2 -11351 -27124 5953 2 -11330 -27157 5842 2 -11292 -27201 5711 2 -11346 -27210 5559 2 -11220 -27277 5483 2 -11150 -27320 5414 2 -11097 -27365 5294 2 -11050 -27403 5196 2 -11049 -27427 5066 2 -11001 -27470 4938 2 -10926 -27521 4819 2 -10841 -27571 4722 2 -10791 -27610 4607 2 -10775 -27638 4476 2 -10630 -27707 4398 2 -10538 -27721 4528 2 -10457 -27759 4482 2 -10365 -27808 4392 2 -10230 -27863 4362 2 -10125 -27913 4286 2 -10005 -27969 4204 2 -9882 -28009 4221 2 -9781 -28060 4119 2 -9812 -28070 3974 2 -9817 -28085 3856 2 -9673 -28138 3833 2 -9546 -28189 3773 2 -9405 -28235 3788 2 -9263 -28283 3781 2 -9122 -28331 3761 2 -8983 -28379 3734 2 -8854 -28428 3666 2 -8712 -28475 3646 2 -8568 -28518 3648 2 -8434 -28565 3593 2 -8316 -28608 3528 2 -8221 -28649 3410 2 -8173 -28679 3277 2 -8133 -28706 3129 2 -8124 -28725 2979 2 -8149 -28733 2831 2 -8147 -28748 2685 2 -8152 -28760 2529 2 -8121 -28781 2384 2 -8123 -28793 2232 2 -8138 -28800 2089 2 -8129 -28813 1932 2 -8215 -28789 1930 2 -8292 -28771 1861 2 -8276 -28786 1694 2 -8373 -28761 1645 2 -8504 -28726 1577 2 -8603 -28702 1470 2 -8548 -28722 1413 2 -8455 -28752 1346 2 -8326 -28792 1297 2 -8242 -28821 1202 2 -8277 -28816 1077 2 -8357 -28797 949 2 -8395 -28790 809 2 -8463 -28774 670 2 -8647 -28720 628 2 -8617 -28731 519 2 -8640 -28726 388 2 -8680 -28716 254 2 -8866 -28660 171 2 -8754 -28694 93 2 -8684 -28716 -25 2 -8629 -28732 -159 2 -8669 -28719 -316 2 -8665 -28718 -463 2 -8616 -28730 -602 2 -8622 -28725 -752 2 -8582 -28732 -900 2 -8578 -28728 -1047 2 -8627 -28708 -1200 2 -8676 -28688 -1320 2 -8634 -28693 -1468 2 -8595 -28697 -1612 2 -8567 -28696 -1777 2 -8597 -28679 -1893 2 -8667 -28651 -2003 2 -8557 -28680 -2057 2 -8427 -28724 -1985 2 -8401 -28740 -1847 2 -8426 -28742 -1700 2 -8439 -28747 -1547 2 -8369 -28775 -1405 2 -8291 -28795 -1449 2 -8255 -28798 -1596 2 -8279 -28782 -1745 2 -8226 -28789 -1874 2 -8116 -28826 -1797 2 -8059 -28849 -1673 2 -7916 -28893 -1599 2 -7889 -28907 -1464 2 -7763 -28943 -1432 2 -7688 -28966 -1364 2 -7590 -28995 -1288 2 -7508 -29012 -1396 2 -7480 -29012 -1541 2 -7548 -28987 -1668 2 -7524 -28983 -1829 2 -7475 -28987 -1973 2 -7389 -29000 -2101 2 -7282 -29019 -2206 2 -7255 -29014 -2350 2 -7267 -28999 -2504 2 -7183 -29005 -2670 2 -7310 -28967 -2733 2 -7458 -28931 -2718 2 -7601 -28887 -2790 2 -7620 -28867 -2934 2 -7511 -28893 -2965 2 -7375 -28933 -2911 2 -7266 -28956 -2961 2 -7280 -28939 -3084 2 -7369 -28908 -3167 2 -7492 -28869 -3234 2 -7579 -28834 -3341 2 -7502 -28843 -3438 2 -7347 -28889 -3384 2 -7243 -28905 -3472 2 -7149 -28914 -3586 2 -7141 -28896 -3743 2 -7049 -28909 -3816 2 -6939 -28926 -3893 2 -6838 -28934 -4007 2 -6743 -28940 -4127 2 -6676 -28935 -4262 2 -6581 -28940 -4376 2 -6516 -28934 -4516 2 -6435 -28931 -4644 2 -6350 -28930 -4770 2 -6241 -28937 -4871 2 -6111 -28951 -4947 2 -6008 -28954 -5055 2 -5929 -28948 -5186 2 -5842 -28943 -5309 2 -5713 -28953 -5396 2 -5695 -28927 -5552 2 -5599 -28924 -5660 2 -5448 -28943 -5713 2 -5304 -28974 -5690 2 -5165 -28988 -5747 2 -5032 -28994 -5831 2 -4886 -29026 -5800 2 -4746 -29044 -5824 2 -4628 -29044 -5919 2 -4501 -29056 -5958 2 -4345 -29072 -5996 2 -4211 -29094 -5982 2 -4068 -29104 -6036 2 -3987 -29149 -5871 2 -3883 -29146 -5952 2 -3805 -29127 -6095 2 -3640 -29149 -6090 2 -3670 -29167 -5983 2 -3800 -29164 -5917 2 -3857 -29183 -5784 2 -3851 -29211 -5647 2 -3772 -29237 -5566 2 -3675 -29269 -5459 2 -3587 -29269 -5520 2 -3427 -29287 -5525 2 -3286 -29306 -5511 2 -3188 -29307 -5562 2 -3146 -29283 -5711 2 -3042 -29279 -5787 2 -2965 -29274 -5853 2 -2913 -29252 -5988 2 -2800 -29243 -6083 2 -2675 -29259 -6064 2 -2557 -29255 -6134 2 -2468 -29282 -6037 2 -2391 -29313 -5920 2 -2350 -29343 -5784 2 -2422 -29368 -5628 2 -2566 -29362 -5593 2 -2687 -29364 -5524 2 -2618 -29394 -5400 2 -2457 -29408 -5397 2 -2420 -29429 -5297 2 -2465 -29451 -5155 2 -2557 -29463 -5038 2 -2639 -29476 -4917 2 -2699 -29494 -4778 2 -2778 -29507 -4647 2 -2847 -29521 -4515 2 -2882 -29540 -4368 2 -2855 -29564 -4220 2 -2795 -29589 -4086 2 -2660 -29610 -4022 2 -2522 -29629 -3967 2 -2389 -29652 -3880 2 -2263 -29659 -3904 2 -2192 -29646 -4036 2 -2096 -29638 -4148 2 -1979 -29632 -4244 2 -1828 -29644 -4232 2 -1844 -29659 -4116 2 -1908 -29675 -3971 2 -1822 -29696 -3848 2 -1799 -29717 -3700 2 -1821 -29734 -3546 2 -1814 -29752 -3398 2 -1708 -29770 -3290 2 -1616 -29788 -3172 2 -1550 -29806 -3036 2 -1475 -29822 -2907 2 -1419 -29838 -2770 2 -1410 -29852 -2619 2 -1442 -29863 -2471 2 -1514 -29870 -2338 2 -1600 -29876 -2212 2 -1684 -29880 -2086 2 -1698 -29888 -1953 2 -1575 -29896 -1935 2 -1486 -29892 -2065 2 -1361 -29891 -2162 2 -1204 -29902 -2100 2 -1090 -29901 -2181 2 -933 -29903 -2217 2 -813 -29900 -2313 2 -728 -29892 -2434 2 -636 -29884 -2552 2 -561 -29876 -2670 2 -453 -29867 -2788 2 -325 -29861 -2868 2 -172 -29860 -2892 2 -49 -29855 -2945 2 66 -29845 -3046 2 198 -29837 -3120 2 333 -29828 -3187 2 446 -29820 -3254 2 531 -29807 -3353 2 684 -29801 -3381 2 722 -29793 -3444 2 767 -29777 -3566 2 856 -29764 -3656 2 965 -29748 -3762 2 1077 -29733 -3846 2 1158 -29717 -3946 2 1262 -29697 -4062 2 1413 -29676 -4164 2 1433 -29654 -4313 2 1544 -29635 -4400 2 1597 -29613 -4533 2 1650 -29591 -4656 2 1782 -29583 -4655 2 1853 -29567 -4728 2 1789 -29544 -4891 2 1831 -29521 -5013 2 1830 -29494 -5171 2 1896 -29467 -5303 2 1844 -29448 -5423 2 1736 -29436 -5521 2 1648 -29418 -5644 2 1542 -29406 -5736 2 1361 -29406 -5780 2 1414 -29394 -5832 2 1547 -29364 -5949 2 1647 -29351 -5983 2 1729 -29314 -6140 2 1811 -29294 -6213 2 1874 -29261 -6345 2 1989 -29233 -6440 2 2024 -29212 -6525 2 2055 -29180 -6655 2 2116 -29143 -6797 2 2143 -29110 -6929 2 2159 -29078 -7059 2 2221 -29042 -7187 2 2297 -29003 -7317 2 2221 -28980 -7431 2 2188 -28944 -7580 2 2080 -28933 -7653 2 2054 -28905 -7764 2 2128 -28864 -7896 2 2018 -28851 -7972 2 2027 -28826 -8060 2 1942 -28794 -8195 2 1852 -28763 -8322 2 1749 -28769 -8324 2 1650 -28761 -8370 2 1625 -28721 -8512 2 1569 -28687 -8638 2 1537 -28640 -8797 2 1546 -28595 -8941 2 1586 -28556 -9057 2 1512 -28526 -9164 2 1498 -28486 -9291 2 1604 -28447 -9393 2 1757 -28437 -9394 2 1883 -28404 -9469 2 2026 -28371 -9537 2 2110 -28329 -9643 2 2273 -28314 -9652 2 2409 -28306 -9640 2 2555 -28291 -9649 2 2709 -28279 -9641 2 2832 -28292 -9568 2 2972 -28257 -9629 2 3119 -28245 -9618 2 3261 -28232 -9610 2 3403 -28206 -9636 2 3509 -28166 -9713 2 3641 -28128 -9775 2 3784 -28099 -9803 2 3919 -28065 -9847 2 4113 -28029 -9874 2 4210 -28041 -9796 2 4334 -28045 -9732 2 4484 -28029 -9709 2 4643 -27992 -9740 2 4689 -27944 -9855 2 4845 -27899 -9908 2 4830 -27935 -9814 2 4804 -27988 -9676 2 4951 -27977 -9633 2 5069 -27977 -9569 2 5207 -27985 -9471 2 5327 -27914 -9614 2 5465 -27903 -9569 2 5610 -27882 -9546 2 5756 -27876 -9478 2 5869 -27826 -9553 2 5984 -27794 -9575 2 6071 -27826 -9427 2 6142 -27801 -9453 2 6290 -27755 -9490 2 6461 -27734 -9438 2 6521 -27679 -9558 2 6605 -27634 -9629 2 6717 -27645 -9521 2 6851 -27625 -9481 2 6998 -27596 -9461 2 7105 -27611 -9335 2 7252 -27579 -9319 2 7383 -27571 -9237 2 7513 -27560 -9164 2 7644 -27544 -9104 2 7785 -27523 -9048 2 7910 -27515 -8963 2 8049 -27494 -8905 2 8182 -27476 -8840 2 8293 -27474 -8741 2 8437 -27448 -8684 2 8590 -27419 -8628 2 8677 -27366 -8707 2 8749 -27304 -8828 2 8869 -27243 -8898 2 8992 -27196 -8919 2 9071 -27198 -8831 2 8985 -27263 -8717 2 8879 -27326 -8629 2 8754 -27385 -8570 2 8712 -27435 -8452 2 8843 -27423 -8353 2 8919 -27437 -8224 2 9000 -27448 -8100 2 9087 -27455 -7979 2 9192 -27452 -7868 2 9224 -27482 -7723 2 9193 -27532 -7582 2 9119 -27588 -7468 2 9079 -27635 -7341 2 9191 -27624 -7240 2 9312 -27606 -7155 2 9449 -27570 -7114 2 9580 -27508 -7180 2 9721 -27473 -7122 2 9746 -27505 -6964 2 9703 -27554 -6828 2 9798 -27536 -6765 2 9893 -27524 -6677 2 9910 -27553 -6527 2 9984 -27546 -6446 2 10103 -27528 -6335 2 10130 -27553 -6183 2 10147 -27578 -6039 2 10211 -27585 -5898 2 10255 -27599 -5758 2 10328 -27600 -5618 2 10380 -27608 -5482 2 10490 -27587 -5375 2 10630 -27538 -5356 2 10766 -27493 -5312 2 10844 -27486 -5187 2 10869 -27506 -5028 2 10998 -27459 -5006 2 11137 -27410 -4966 2 11276 -27362 -4916 2 11335 -27358 -4801 2 11342 -27381 -4653 2 11374 -27392 -4505 2 11368 -27419 -4357 2 11267 -27474 -4267 2 11191 -27522 -4163 2 11174 -27550 -4019 2 11190 -27568 -3844 2 11294 -27539 -3750 2 11418 -27499 -3665 2 11476 -27494 -3521 2 11549 -27479 -3392 2 11627 -27462 -3265 2 11715 -27439 -3141 2 11797 -27417 -3019 2 11856 -27406 -2884 2 11923 -27391 -2751 2 11953 -27392 -2604 2 11947 -27409 -2456 2 11929 -27429 -2309 2 11839 -27478 -2195 2 11774 -27516 -2066 2 11669 -27570 -1936 2 11735 -27547 -1850 2 11817 -27519 -1748 2 11788 -27541 -1586 2 11831 -27530 -1450 2 11823 -27542 -1295 2 11832 -27545 -1138 2 11886 -27527 -997 2 11866 -27541 -847 2 11896 -27532 -699 2 11894 -27536 -544 2 11932 -27522 -400 2 11932 -27524 -246 2 11894 -27541 -101 2 11864 -27554 45 2 11851 -27559 210 2 11969 -27508 259 2 12128 -27437 329 2 12070 -27462 383 2 11923 -27526 399 2 11806 -27575 475 2 11720 -27610 595 2 11677 -27624 737 2 11614 -27647 866 2 11604 -27646 1019 2 11592 -27645 1168 2 11571 -27647 1318 2 11484 -27677 1446 2 11477 -27673 1580 2 11339 -27726 1644 2 11260 -27756 1679 2 11162 -27788 1794 2 11103 -27803 1932 2 11022 -27826 2059 2 10920 -27858 2163 2 10795 -27901 2239 2 10661 -27949 2275 2 10524 -28003 2256 2 10409 -28040 2325 2 10312 -28066 2441 2 10217 -28092 2536 2 14413 -10720 -24028 0 14519 -10656 -23993 2 14560 -10511 -24032 2 14605 -10390 -24057 2 14723 -10328 -24012 2 14831 -10269 -23970 2 14961 -10204 -23917 2 15082 -10141 -23868 2 15207 -9985 -23855 2 15312 -9969 -23794 2 15428 -9901 -23748 2 15562 -9858 -23678 2 15685 -9782 -23628 2 15763 -9661 -23626 2 15800 -9525 -23657 2 15902 -9415 -23632 2 15930 -9279 -23667 2 15933 -9140 -23719 2 15974 -9003 -23744 2 16045 -8868 -23747 2 16116 -8736 -23748 2 16222 -8627 -23715 2 16316 -8508 -23694 2 16339 -8371 -23727 2 16388 -8227 -23744 2 16438 -8085 -23757 2 16476 -7934 -23782 2 16501 -7802 -23809 2 16545 -7702 -23810 2 16662 -7619 -23755 2 16776 -7535 -23702 2 16853 -7407 -23688 2 16953 -7396 -23620 2 17030 -7455 -23546 2 17132 -7488 -23461 2 17213 -7360 -23442 2 17272 -7223 -23442 2 17317 -7082 -23451 2 17338 -6941 -23478 2 17378 -6794 -23491 2 17427 -6663 -23493 2 17482 -6522 -23491 2 17581 -6402 -23450 2 17593 -6250 -23483 2 17690 -6173 -23430 2 17749 -6029 -23423 2 17775 -5884 -23440 2 17834 -5733 -23432 2 17917 -5633 -23393 2 17994 -5643 -23332 2 18063 -5741 -23254 2 18060 -5899 -23217 2 18076 -6044 -23167 2 18082 -6194 -23123 2 18110 -6262 -23083 2 18157 -6379 -23014 2 18095 -6562 -23011 2 18120 -6659 -22964 2 18147 -6778 -22908 2 18113 -6922 -22891 2 18143 -7060 -22825 2 18135 -7208 -22786 2 18072 -7345 -22791 2 18069 -7493 -22746 2 18032 -7638 -22727 2 17981 -7784 -22718 2 17991 -7921 -22662 2 18007 -8062 -22600 2 18001 -8208 -22552 2 17983 -8349 -22514 2 17993 -8495 -22452 2 18015 -8627 -22384 2 18058 -8746 -22303 2 18066 -8882 -22243 2 18094 -9006 -22170 2 18179 -9082 -22070 2 18282 -9121 -21968 2 18396 -9100 -21881 2 18514 -9037 -21808 2 18628 -8964 -21740 2 18731 -8881 -21686 2 18805 -8752 -21674 2 18924 -8693 -21595 2 19040 -8659 -21506 2 19156 -8618 -21419 2 19263 -8528 -21359 2 19359 -8418 -21316 2 19471 -8352 -21240 2 19580 -8281 -21167 2 19694 -8225 -21084 2 19796 -8192 -21000 2 19902 -8099 -20936 2 20000 -7999 -20881 2 20101 -7910 -20818 2 20208 -7825 -20746 2 20313 -7749 -20672 2 20358 -7619 -20676 2 20319 -7493 -20760 2 20268 -7378 -20852 2 20245 -7252 -20917 2 20255 -7111 -20956 2 20304 -6979 -20954 2 20276 -6876 -21014 2 20185 -6840 -21114 2 20111 -6834 -21186 2 20108 -6689 -21235 2 20071 -6534 -21318 2 20018 -6435 -21398 2 20092 -6353 -21353 2 20179 -6240 -21304 2 20251 -6251 -21233 2 20263 -6359 -21189 2 20298 -6466 -21123 2 20365 -6354 -21092 2 20427 -6344 -21035 2 20475 -6323 -20995 2 20444 -6203 -21061 2 20463 -6169 -21052 2 20538 -6261 -20952 2 20630 -6342 -20837 2 20712 -6350 -20753 2 20821 -6253 -20673 2 20911 -6263 -20579 2 21027 -6238 -20469 2 21133 -6160 -20382 2 21218 -6120 -20306 2 21319 -6122 -20199 2 21417 -6075 -20110 2 21525 -5939 -20035 2 21618 -5957 -19930 2 21719 -5850 -19851 2 21791 -5855 -19771 2 21836 -5851 -19722 2 21902 -5864 -19645 2 21810 -5969 -19715 2 21694 -5972 -19841 2 21614 -6084 -19895 2 21573 -6259 -19885 2 21628 -6352 -19796 2 21703 -6347 -19716 2 21801 -6375 -19598 2 21900 -6384 -19484 2 22016 -6327 -19371 2 22091 -6347 -19279 2 22137 -6485 -19181 2 22197 -6479 -19113 2 22236 -6560 -19040 2 22296 -6632 -18945 2 22339 -6741 -18855 2 22290 -6897 -18857 2 22346 -6996 -18754 2 22396 -7067 -18668 2 22392 -7200 -18622 2 22436 -7294 -18532 2 22459 -7435 -18447 2 22359 -7551 -18521 2 22272 -7651 -18585 2 22289 -7686 -18550 2 22299 -7813 -18485 2 22347 -7777 -18442 2 22439 -7787 -18327 2 22490 -7736 -18285 2 22593 -7680 -18182 2 22702 -7664 -18052 2 22730 -7764 -17974 2 22748 -7927 -17880 2 22789 -7878 -17849 2 22804 -7725 -17898 2 22822 -7608 -17924 2 22921 -7505 -17841 2 22999 -7391 -17788 2 23089 -7288 -17714 2 23178 -7223 -17624 2 23254 -7170 -17545 2 23316 -7184 -17457 2 23335 -7302 -17382 2 23391 -7283 -17316 2 23440 -7322 -17232 2 23505 -7263 -17169 2 23522 -7297 -17130 2 23499 -7470 -17087 2 23559 -7525 -16980 2 23614 -7426 -16948 2 23628 -7464 -16912 2 23660 -7540 -16833 2 23709 -7610 -16733 2 23662 -7735 -16742 2 23642 -7814 -16733 2 23722 -7796 -16628 2 23701 -7926 -16596 2 23757 -7928 -16515 2 23793 -7970 -16442 2 23839 -8067 -16329 2 23771 -8202 -16361 2 23745 -8294 -16352 2 23757 -8394 -16284 2 23648 -8458 -16409 2 23665 -8470 -16378 2 23753 -8465 -16252 2 23838 -8420 -16151 2 23936 -8410 -16010 2 23969 -8499 -15914 2 23959 -8571 -15890 2 23851 -8695 -15985 2 23842 -8815 -15933 2 23849 -8981 -15830 2 23908 -8929 -15770 2 23981 -8800 -15731 2 24056 -8661 -15693 2 24120 -8530 -15667 2 24160 -8522 -15611 2 24170 -8645 -15526 2 24205 -8740 -15418 2 24243 -8842 -15300 2 24237 -8974 -15233 2 24191 -9115 -15222 2 24134 -9252 -15231 2 24102 -9361 -15213 2 24137 -9453 -15101 2 24174 -9544 -14984 2 24181 -9661 -14898 2 24173 -9802 -14819 2 24180 -9922 -14727 2 24205 -10022 -14618 2 24248 -10096 -14495 2 24301 -10153 -14365 2 24358 -10204 -14233 2 24425 -10229 -14099 2 24486 -10265 -13966 2 24555 -10267 -13844 2 24631 -10257 -13715 2 24655 -10354 -13599 2 24696 -10417 -13476 2 24764 -10435 -13335 2 24813 -10479 -13209 2 24839 -10567 -13092 2 24891 -10605 -12960 2 24969 -10587 -12825 2 25048 -10570 -12684 2 25087 -10606 -12577 2 25124 -10671 -12446 2 25154 -10733 -12332 2 25176 -10822 -12208 2 25194 -10913 -12091 2 25208 -11008 -11973 2 25248 -11068 -11834 2 25288 -11118 -11700 2 25303 -11215 -11576 2 25285 -11325 -11508 2 25275 -11460 -11395 2 25334 -11381 -11344 2 25403 -11197 -11371 2 25426 -11233 -11286 2 25399 -11364 -11215 2 25375 -11493 -11136 2 25321 -11618 -11131 2 25256 -11755 -11133 2 25206 -11893 -11101 2 25181 -12015 -11026 2 25162 -12136 -10937 2 25122 -12270 -10878 2 25066 -12409 -10850 2 24986 -12529 -10895 2 24916 -12657 -10909 2 24836 -12776 -10952 2 24754 -12899 -10992 2 24671 -13017 -11041 2 24596 -13136 -11068 2 24543 -13303 -10984 2 24643 -13198 -10887 2 24703 -13117 -10848 2 24801 -12976 -10795 2 24778 -13059 -10748 2 24699 -13183 -10779 2 24612 -13286 -10851 2 24555 -13420 -10814 2 24618 -13370 -10733 2 24721 -13240 -10658 2 24694 -13317 -10624 2 24609 -13424 -10688 2 24522 -13530 -10752 2 24437 -13644 -10801 2 24352 -13763 -10841 2 24270 -13890 -10863 2 24207 -14023 -10834 2 24126 -14151 -10848 2 24037 -14258 -10907 2 23949 -14373 -10948 2 23870 -14497 -10956 2 23777 -14609 -11010 2 23693 -14736 -11022 2 23626 -14867 -10990 2 23555 -15000 -10962 2 23478 -15127 -10952 2 23397 -15255 -10949 2 23307 -15377 -10970 2 23215 -15492 -11002 2 23124 -15611 -11027 2 23030 -15726 -11058 2 22945 -15851 -11059 2 22868 -15988 -11019 2 22776 -16160 -10960 2 22753 -16227 -10909 2 22668 -16354 -10895 2 22605 -16466 -10859 2 22572 -16588 -10739 2 22622 -16602 -10611 2 22630 -16636 -10542 2 22555 -16763 -10502 2 22455 -16893 -10508 2 22371 -16929 -10628 2 22274 -16999 -10719 2 22169 -17097 -10780 2 22071 -17155 -10889 2 22002 -17195 -10965 2 21914 -17221 -11101 2 21845 -17221 -11236 2 21760 -17243 -11366 2 21698 -17234 -11497 2 21662 -17182 -11642 2 21666 -17090 -11769 2 21656 -17009 -11903 2 21602 -16986 -12035 2 21560 -16949 -12162 2 21590 -16836 -12266 2 21571 -16763 -12398 2 21502 -16753 -12530 2 21435 -16741 -12660 2 21371 -16718 -12798 2 21302 -16706 -12928 2 21220 -16711 -13056 2 21123 -16729 -13189 2 21040 -16767 -13273 2 20978 -16741 -13403 2 20905 -16725 -13537 2 20813 -16755 -13641 2 20746 -16716 -13790 2 20744 -16615 -13915 2 20766 -16507 -14010 2 20797 -16389 -14103 2 20767 -16318 -14229 2 20698 -16287 -14364 2 20661 -16219 -14494 2 20615 -16160 -14625 2 20571 -16099 -14753 2 20531 -16031 -14883 2 20452 -16014 -15009 2 20351 -16034 -15125 2 20261 -16032 -15247 2 20179 -16017 -15371 2 20113 -15976 -15499 2 20041 -15940 -15629 2 19975 -15896 -15758 2 19916 -15842 -15887 2 19862 -15781 -16013 2 19785 -15749 -16141 2 19697 -15733 -16263 2 19606 -15721 -16385 2 19512 -15713 -16505 2 19411 -15719 -16617 2 19317 -15711 -16734 2 19239 -15677 -16854 2 19120 -15728 -16942 2 19003 -15794 -17013 2 18886 -15874 -17069 2 18782 -15900 -17160 2 18695 -15882 -17271 2 18573 -15950 -17339 2 18452 -15977 -17443 2 18366 -15975 -17535 2 18240 -16092 -17561 2 18128 -16136 -17635 2 18090 -16256 -17564 2 17992 -16386 -17544 2 17863 -16428 -17636 2 17756 -16527 -17652 2 17671 -16642 -17629 2 17547 -16740 -17660 2 17460 -16853 -17639 2 17380 -17009 -17569 2 17318 -17080 -17560 2 17145 -17152 -17660 2 17175 -17049 -17730 2 17150 -16964 -17835 2 17142 -16847 -17953 2 17111 -16757 -18067 2 17046 -16676 -18203 2 16976 -16635 -18305 2 16965 -16527 -18413 2 16976 -16410 -18508 2 16937 -16319 -18623 2 16973 -16193 -18701 2 16942 -16198 -18724 2 16858 -16321 -18694 2 16825 -16426 -18631 2 16768 -16556 -18566 2 16772 -16658 -18472 2 16783 -16762 -18367 2 16762 -16876 -18282 2 16711 -16998 -18216 2 16651 -17144 -18133 2 16735 -17174 -18027 2 16740 -17288 -17914 2 16634 -17285 -18015 2 16529 -17261 -18134 2 16527 -17152 -18239 2 16560 -17031 -18322 2 16573 -16890 -18441 2 16477 -16956 -18466 2 16355 -17077 -18463 2 16294 -17188 -18414 2 16251 -17313 -18335 2 16254 -17450 -18202 2 16135 -17468 -18289 2 16050 -17423 -18408 2 15967 -17370 -18530 2 15932 -17455 -18479 2 15925 -17505 -18438 2 15809 -17594 -18454 2 15738 -17648 -18462 2 15965 -17489 -18418 2 15931 -17515 -18424 2 15809 -17600 -18448 2 15696 -17699 -18449 2 15596 -17811 -18426 2 15509 -17927 -18387 2 15487 -18044 -18292 2 15412 -18161 -18239 2 15285 -18264 -18242 2 15171 -18353 -18249 2 15057 -18450 -18245 2 14929 -18496 -18304 2 14802 -18528 -18374 2 14664 -18619 -18393 2 14584 -18600 -18476 2 14448 -18618 -18564 2 14325 -18633 -18644 2 14191 -18696 -18683 2 14057 -18751 -18730 2 13922 -18800 -18781 2 13833 -18763 -18883 2 13783 -18682 -19001 2 13714 -18613 -19118 2 13678 -18537 -19217 2 13628 -18440 -19346 2 13519 -18500 -19364 2 13546 -18610 -19240 2 13478 -18660 -19239 2 13404 -18589 -19359 2 13321 -18650 -19358 2 13203 -18740 -19352 2 13085 -18812 -19362 2 12919 -18891 -19397 2 12952 -18810 -19453 2 12907 -18758 -19533 2 12801 -18727 -19632 2 12747 -18638 -19752 2 12694 -18554 -19865 2 12629 -18478 -19977 2 12538 -18425 -20084 2 12424 -18396 -20180 2 12297 -18391 -20262 2 12165 -18385 -20347 2 12047 -18373 -20428 2 11972 -18295 -20542 2 11930 -18210 -20642 2 11979 -18104 -20706 2 12024 -17992 -20778 2 12032 -17871 -20877 2 12048 -17753 -20969 2 12082 -17639 -21045 2 12080 -17521 -21145 2 12058 -17407 -21251 2 12026 -17300 -21356 2 11998 -17217 -21438 2 12016 -17094 -21527 2 12031 -16992 -21599 2 12008 -16866 -21711 2 11981 -16768 -21801 2 11997 -16620 -21905 2 11961 -16509 -22009 2 11932 -16417 -22094 2 11899 -16309 -22191 2 11801 -16225 -22304 2 11744 -16146 -22392 2 11689 -16052 -22488 2 11715 -15925 -22565 2 11669 -15812 -22668 2 11648 -15691 -22762 2 11651 -15567 -22846 2 11656 -15436 -22931 2 11708 -15309 -22990 2 11711 -15182 -23073 2 11703 -15057 -23158 2 11701 -14931 -23241 2 11710 -14802 -23319 2 11728 -14671 -23392 2 11711 -14546 -23479 2 11694 -14422 -23564 2 11740 -14291 -23621 2 11789 -14164 -23673 2 11862 -14037 -23712 2 11935 -13914 -23748 2 12033 -13794 -23768 2 12070 -13673 -23819 2 12096 -13529 -23888 2 12138 -13400 -23940 2 12175 -13270 -23993 2 12210 -13117 -24060 2 12304 -13005 -24072 2 12343 -12867 -24126 2 12473 -12772 -24110 2 12556 -12657 -24128 2 12650 -12552 -24134 2 12771 -12465 -24115 2 12863 -12330 -24135 2 12989 -12230 -24119 2 13096 -12199 -24077 2 13218 -12104 -24058 2 13350 -11994 -24040 2 13428 -11890 -24048 2 13480 -11751 -24087 2 13493 -11617 -24145 2 13584 -11477 -24161 2 13715 -11460 -24095 2 13846 -11354 -24070 2 13870 -11468 -24002 2 13957 -11454 -23959 2 14051 -11356 -23950 2 14124 -11220 -23971 2 14172 -11067 -24014 2 14250 -10962 -24016 2 14320 -10829 -24035 2 -7056 27453 9826 0 -7008 27479 9786 2 -6906 27476 9868 2 -6777 27515 9847 2 -6668 27554 9813 2 -6519 27617 9737 2 -6391 27674 9659 2 -6282 27725 9585 2 -6167 27762 9551 2 -6012 27799 9543 2 -5938 27852 9434 2 -5908 27905 9294 2 -5874 27910 9302 2 -5858 27863 9452 2 -5827 27834 9554 2 -5680 27843 9616 2 -5581 27860 9627 2 -5494 27876 9631 2 -5399 27877 9682 2 -5237 27901 9701 2 -5109 27917 9723 2 -4959 27937 9745 2 -4809 27958 9759 2 -4662 27998 9715 2 -4550 28035 9661 2 -4412 28071 9621 2 -4271 28106 9581 2 -4135 28146 9522 2 -4011 28174 9496 2 -3910 28205 9445 2 -4096 28213 9339 2 -4197 28233 9234 2 -4300 28252 9129 2 -4443 28238 9102 2 -4591 28228 9062 2 -4734 28194 9094 2 -4808 28209 9009 2 -4593 28241 9018 2 -4516 28266 8980 2 -4685 28263 8902 2 -4792 28271 8819 2 -4841 28276 8778 2 -4681 28310 8754 2 -4592 28359 8640 2 -4520 28372 8637 2 -4416 28357 8741 2 -4272 28377 8746 2 -4155 28413 8686 2 -4189 28448 8553 2 -4327 28454 8466 2 -4427 28463 8382 2 -4453 28465 8360 2 -4347 28492 8326 2 -4393 28523 8195 2 -4384 28538 8145 2 -4317 28505 8298 2 -4266 28467 8453 2 -4151 28459 8536 2 -4078 28428 8674 2 -4010 28406 8776 2 -4017 28356 8932 2 -4040 28308 9075 2 -3977 28273 9210 2 -3850 28285 9227 2 -3795 28309 9176 2 -3712 28281 9295 2 -3654 28327 9177 2 -3626 28375 9040 2 -3586 28429 8885 2 -3614 28457 8782 2 -3595 28481 8711 2 -3657 28491 8653 2 -3609 28529 8549 2 -3690 28560 8411 2 -3750 28587 8290 2 -3867 28586 8240 2 -3916 28585 8219 2 -3760 28626 8150 2 -3826 28656 8013 2 -3973 28645 7981 2 -3998 28662 7905 2 -3815 28670 7966 2 -3731 28699 7902 2 -3847 28715 7789 2 -3966 28711 7744 2 -3889 28748 7642 2 -3742 28736 7763 2 -3591 28772 7700 2 -3579 28804 7586 2 -3479 28791 7678 2 -3373 28800 7694 2 -3268 28780 7812 2 -3271 28777 7822 2 -3401 28776 7769 2 -3322 28734 7958 2 -3190 28744 7974 2 -3069 28758 7971 2 -2963 28778 7939 2 -2928 28818 7808 2 -3066 28829 7713 2 -3116 28808 7770 2 -3106 28854 7601 2 -3037 28891 7491 2 -2961 28909 7448 2 -2823 28897 7550 2 -2736 28876 7660 2 -2635 28909 7573 2 -2688 28928 7478 2 -2802 28940 7391 2 -2790 28981 7233 2 -2875 28988 7174 2 -2723 29010 7142 2 -2808 29039 6989 2 -2793 29050 6948 2 -2709 29027 7077 2 -2587 29011 7189 2 -2492 29048 7072 2 -2471 29082 6936 2 -2558 29102 6820 2 -2633 29107 6770 2 -2454 29131 6734 2 -2568 29141 6648 2 -2632 29173 6481 2 -2591 29200 6374 2 -2452 29216 6356 2 -2327 29225 6361 2 -2195 29210 6477 2 -2101 29233 6407 2 -2120 29265 6250 2 -2226 29273 6176 2 -2275 29291 6069 2 -2194 29310 6009 2 -2116 29313 6022 2 -2241 29334 5872 2 -2350 29317 5915 2 -2255 29361 5732 2 -2172 29393 5599 2 -2111 29420 5477 2 -1978 29444 5397 2 -1870 29472 5282 2 -1832 29502 5128 2 -1722 29522 5047 2 -1595 29539 4992 2 -1616 29555 4890 2 -1767 29544 4901 2 -1829 29537 4924 2 -1698 29566 4792 2 -1546 29565 4850 2 -1423 29580 4797 2 -1444 29596 4691 2 -1587 29595 4648 2 -1670 29598 4598 2 -1442 29610 4599 2 -1287 29616 4609 2 -1185 29636 4508 2 -1061 29654 4418 2 -954 29675 4300 2 -998 29693 4162 2 -1118 29702 4070 2 -1269 29694 4080 2 -1388 29674 4188 2 -1530 29674 4134 2 -1674 29655 4213 2 -1795 29635 4305 2 -1914 29615 4391 2 -1981 29606 4425 2 -1838 29637 4271 2 -1738 29658 4173 2 -1642 29680 4049 2 -1584 29702 3910 2 -1648 29711 3816 2 -1765 29692 3909 2 -1906 29677 3958 2 -2002 29672 3947 2 -1811 29701 3816 2 -1901 29709 3708 2 -2059 29704 3665 2 -2192 29698 3639 2 -2280 29695 3603 2 -2073 29719 3534 2 -1910 29721 3610 2 -1779 29719 3689 2 -1631 29727 3695 2 -1491 29738 3664 2 -1420 29755 3552 2 -1505 29765 3428 2 -1578 29770 3356 2 -1578 29783 3233 2 -1713 29782 3178 2 -1842 29781 3113 2 -1980 29774 3099 2 -2083 29771 3056 2 -1922 29782 3052 2 -1782 29786 3097 2 -1647 29786 3175 2 -1537 29797 3123 2 -1632 29806 2992 2 -1726 29812 2873 2 -1869 29811 2796 2 -2004 29807 2741 2 -2098 29803 2720 2 -2191 29793 2748 2 -2232 29780 2854 2 -2353 29769 2876 2 -2384 29786 2672 2 -2452 29788 2585 2 -2592 29777 2573 2 -2661 29769 2596 2 -2567 29766 2714 2 -2482 29762 2839 2 -2487 29749 2973 2 -2529 29743 2990 2 -2559 29754 2856 2 -2638 29762 2697 2 -2719 29754 2700 2 -2752 29737 2856 2 -2799 29725 2933 2 -2961 29702 3005 2 -3025 29697 2985 2 -2997 29715 2830 2 -2997 29729 2683 2 -2993 29743 2532 2 -3089 29735 2509 2 -3175 29715 2637 2 -3267 29698 2711 2 -3327 29687 2755 2 -3343 29703 2559 2 -3478 29687 2565 2 -3286 29722 2406 2 -3319 29727 2300 2 -3420 29721 2224 2 -3573 29708 2158 2 -3673 29686 2287 2 -3735 29668 2426 2 -3748 29666 2427 2 -3701 29683 2278 2 -3649 29700 2137 2 -3769 29690 2070 2 -3897 29667 2158 2 -4053 29644 2187 2 -4149 29638 2090 2 -4224 29627 2099 2 -4385 29610 2008 2 -4520 29593 1962 2 -4678 29569 1953 2 -4744 29550 2071 2 -4662 29554 2195 2 -4642 29555 2230 2 -4801 29529 2238 2 -4932 29502 2307 2 -5081 29476 2312 2 -5196 29461 2244 2 -5275 29456 2132 2 -5411 29436 2061 2 -5543 29418 1964 2 -5635 29407 1860 2 -5769 29385 1803 2 -5895 29358 1838 2 -5980 29331 1984 2 -5977 29323 2101 2 -6008 29311 2179 2 -6086 29289 2257 2 -6014 29295 2371 2 -5930 29302 2496 2 -5903 29300 2584 2 -6028 29272 2614 2 -6081 29274 2456 2 -6164 29259 2433 2 -6127 29251 2620 2 -6133 29248 2638 2 -6178 29252 2479 2 -6215 29256 2331 2 -6284 29252 2197 2 -6406 29225 2200 2 -6420 29214 2303 2 -6397 29216 2350 2 -6453 29192 2483 2 -6469 29182 2557 2 -6629 29151 2505 2 -6697 29123 2651 2 -6695 29108 2812 2 -6657 29113 2848 2 -6575 29133 2838 2 -6536 29131 2941 2 -6522 29125 3033 2 -6422 29139 3108 2 -6331 29145 3239 2 -6303 29135 3378 2 -6299 29118 3533 2 -6314 29096 3683 2 -6328 29075 3822 2 -6392 29045 3942 2 -6478 29019 3995 2 -6558 28982 4127 2 -6604 28948 4289 2 -6679 28910 4427 2 -6767 28881 4481 2 -6841 28859 4511 2 -6887 28824 4663 2 -6983 28788 4743 2 -7069 28741 4896 2 -7175 28701 4976 2 -7247 28656 5130 2 -7361 28617 5188 2 -7448 28597 5171 2 -7479 28575 5245 2 -7579 28536 5318 2 -7763 28486 5317 2 -7848 28440 5437 2 -7801 28428 5564 2 -7672 28460 5582 2 -7576 28490 5562 2 -7441 28542 5475 2 -7383 28567 5423 2 -7467 28508 5615 2 -7496 28475 5745 2 -7466 28468 5817 2 -7590 28435 5818 2 -7518 28436 5906 2 -7612 28407 5923 2 -7591 28404 5963 2 -7633 28385 6001 2 -7629 28367 6089 2 -7688 28323 6223 2 -7761 28283 6312 2 -7829 28255 6351 2 -7869 28277 6205 2 -7867 28310 6053 2 -7920 28325 5912 2 -7998 28330 5781 2 -8103 28297 5798 2 -8126 28260 5945 2 -8078 28243 6087 2 -8087 28208 6240 2 -8033 28192 6377 2 -7961 28193 6466 2 -7933 28177 6568 2 -8051 28133 6614 2 -8142 28093 6672 2 -8228 28045 6767 2 -8298 28013 6814 2 -8426 27973 6821 2 -8523 27932 6866 2 -8641 27922 6758 2 -8749 27906 6688 2 -8849 27870 6704 2 -8755 27862 6859 2 -8637 27888 6904 2 -8607 27885 6952 2 -8695 27835 7042 2 -8700 27806 7150 2 -8783 27826 6969 2 -8844 27839 6839 2 -8894 27843 6757 2 -8947 27838 6706 2 -8988 27804 6793 2 -9136 27766 6751 2 -9192 27732 6815 2 -9031 27773 6865 2 -8902 27796 6937 2 -8866 27784 7031 2 -8766 27785 7154 2 -8759 27776 7195 2 -8845 27752 7184 2 -8808 27736 7291 2 -8890 27733 7202 2 -8946 27748 7073 2 -9005 27764 6932 2 -9101 27749 6868 2 -9271 27705 6818 2 -9324 27670 6887 2 -9207 27682 6997 2 -9101 27691 7098 2 -9030 27683 7219 2 -9015 27653 7350 2 -9009 27650 7371 2 -9072 27664 7241 2 -9112 27685 7106 2 -9222 27674 7007 2 -9340 27658 6912 2 -9418 27629 6926 2 -9419 27603 7027 2 -9356 27588 7166 2 -9482 27551 7144 2 -9533 27517 7206 2 -9655 27497 7119 2 -9720 27448 7222 2 -9575 27479 7296 2 -9433 27520 7328 2 -9290 27564 7345 2 -9147 27601 7382 2 -9026 27620 7460 2 -9032 27612 7482 2 -9138 27587 7448 2 -9292 27556 7371 2 -9438 27512 7349 2 -9581 27473 7310 2 -9720 27433 7277 2 -9782 27398 7325 2 -9697 27397 7441 2 -9644 27397 7509 2 -9828 27362 7397 2 -9845 27334 7480 2 -9860 27302 7576 2 -9730 27330 7640 2 -9594 27359 7711 2 -9570 27348 7779 2 -9735 27323 7660 2 -9870 27281 7636 2 -9939 27242 7688 2 -10039 27169 7813 2 -10011 27164 7867 2 -9960 27172 7903 2 -10141 27105 7903 2 -10215 27042 8025 2 -10020 27116 8020 2 -9916 27142 8060 2 -9797 27206 7991 2 -9828 27135 8192 2 -9886 27072 8328 2 -9909 27057 8351 2 -9908 27112 8170 2 -9974 27085 8180 2 -10009 27057 8232 2 -10161 27015 8181 2 -10237 26997 8147 2 -10104 27012 8264 2 -10057 27009 8330 2 -10237 26977 8214 2 -10307 26944 8234 2 -10304 26928 8289 2 -10411 26881 8307 2 -10364 26874 8389 2 -10352 26868 8424 2 -10435 26827 8452 2 -10413 26815 8517 2 -10486 26779 8541 2 -10461 26749 8663 2 -10499 26707 8747 2 -10439 26723 8769 2 -10537 26674 8802 2 -10667 26591 8896 2 -10648 26557 9018 2 -10661 26522 9108 2 -10682 26494 9164 2 -10628 26501 9204 2 -10720 26450 9247 2 -10662 26460 9284 2 -10760 26393 9361 2 -10703 26376 9475 2 -10724 26365 9482 2 -10801 26325 9504 2 -10788 26291 9613 2 -10751 26281 9680 2 -10823 26233 9731 2 -10858 26196 9790 2 -10766 26209 9857 2 -10640 26214 9982 2 -10498 26249 10040 2 -10382 26271 10101 2 -10341 26254 10188 2 -10487 26198 10182 2 -10427 26195 10251 2 -10524 26140 10293 2 -10465 26140 10354 2 -10468 26122 10397 2 -10405 26120 10462 2 -10525 26044 10533 2 -10422 26078 10551 2 -10548 26002 10614 2 -10363 26046 10686 2 -10284 26015 10837 2 -10196 26038 10866 2 -10192 26088 10750 2 -10197 26133 10634 2 -10071 26124 10775 2 -10014 26161 10738 2 -9993 26204 10655 2 -9881 26247 10652 2 -9920 26268 10564 2 -9846 26280 10602 2 -9834 26289 10590 2 -9801 26306 10580 2 -9793 26321 10551 2 -9698 26358 10545 2 -9679 26385 10496 2 -9606 26416 10484 2 -9602 26431 10449 2 -9498 26478 10426 2 -9414 26548 10324 2 -9374 26604 10215 2 -9316 26670 10095 2 -9191 26696 10143 2 -9090 26720 10169 2 -9048 26760 10101 2 -8963 26793 10091 2 -8906 26833 10033 2 -8863 26835 10065 2 -8806 26845 10089 2 -8730 26874 10078 2 -8742 26906 9982 2 -8615 26923 10046 2 -8571 26982 9925 2 -8590 27029 9779 2 -8420 27061 9839 2 -8358 27139 9676 2 -8301 27196 9564 2 -8188 27203 9641 2 -8074 27236 9644 2 -7976 27303 9537 2 -7849 27326 9575 2 -7731 27327 9667 2 -7624 27355 9673 2 -7542 27405 9598 2 -7414 27466 9520 2 -7338 27482 9535 2 -7349 27454 9607 2 -7476 27397 9671 2 -7387 27385 9771 2 -7240 27404 9828 2 -7134 27420 9860 2 -10216 27876 4312 0 -10249 27875 4236 2 -10177 27895 4281 2 -10179 27910 4175 2 -10193 27929 4011 2 -10154 27941 4027 2 -10127 27968 3904 2 -10062 27976 4015 2 -9977 28007 4006 2 -9969 28029 3870 2 -9898 28049 3909 2 -9890 28064 3824 2 -9862 28067 3872 2 -9858 28048 4020 2 -9822 28038 4168 2 -9731 28072 4158 2 -9726 28094 4013 2 -9749 28106 3871 2 -9823 28108 3672 2 -9784 28113 3732 2 -9683 28132 3848 2 -9586 28147 3984 2 -9475 28188 3961 2 -9392 28234 3827 2 -9472 28215 3763 2 -9594 28181 3714 2 -9743 28144 3601 2 -9703 28158 3603 2 -9528 28208 3674 2 -9541 28217 3572 2 -9679 28178 3508 2 -9648 28190 3498 2 -9526 28226 3541 2 -9397 28255 3656 2 -9295 28286 3672 2 -9249 28321 3515 2 -9336 28310 3377 2 -9392 28304 3264 2 -9614 28231 3253 2 -9531 28261 3237 2 -9532 28269 3165 2 -9490 28284 3152 2 -9379 28312 3238 2 -9221 28363 3239 2 -9272 28356 3154 2 -9413 28326 3004 2 -9294 28366 2995 2 -9185 28391 3092 2 -9055 28439 3044 2 -9015 28466 2895 2 -9096 28448 2821 2 -9276 28395 2769 2 -9168 28437 2697 2 -9235 28421 2641 2 -9214 28430 2620 2 -9057 28478 2637 2 -9083 28476 2570 2 -9258 28425 2513 2 -9175 28456 2468 2 -9103 28482 2434 2 -8976 28514 2527 2 -8898 28547 2428 2 -9062 28505 2312 2 -8969 28534 2319 2 -9015 28527 2224 2 -8986 28536 2225 2 -8888 28558 2335 2 -8764 28597 2325 2 -8728 28619 2184 2 -8690 28641 2048 2 -8705 28646 1902 2 -8821 28617 1806 2 -8952 28565 1968 2 -8954 28574 1830 2 -9122 28515 1922 2 -9092 28532 1811 2 -9010 28561 1750 2 -8952 28586 1644 2 -9005 28572 1592 2 -9102 28546 1514 2 -8994 28584 1444 2 -8910 28610 1441 2 -8772 28651 1482 2 -8634 28695 1428 2 -8525 28732 1338 2 -8388 28775 1282 2 -8327 28798 1170 2 -8367 28791 1026 2 -8496 28757 923 2 -8568 28739 803 2 -8684 28703 862 2 -8695 28703 736 2 -8790 28671 830 2 -8778 28678 727 2 -8889 28645 672 2 -9017 28603 753 2 -9135 28562 874 2 -9126 28568 775 2 -9223 28539 687 2 -9343 28498 739 2 -9419 28470 860 2 -9551 28425 885 2 -9707 28373 882 2 -9676 28384 839 2 -9724 28373 634 2 -9669 28391 686 2 -9587 28415 814 2 -9473 28455 747 2 -9360 28495 645 2 -9230 28539 581 2 -9085 28585 580 2 -8953 28628 539 2 -8818 28670 524 2 -8682 28710 572 2 -8544 28751 628 2 -8425 28784 720 2 -8336 28810 682 2 -8330 28815 530 2 -8377 28804 387 2 -8469 28778 270 2 -8606 28739 182 2 -8722 28704 122 2 -8872 28658 91 2 -9005 28617 40 2 -9147 28572 28 2 -9265 28533 8 2 -9412 28485 13 2 -9559 28436 16 2 -9628 28413 143 2 -9645 28406 302 2 -9742 28371 433 2 -9772 28362 290 2 -9756 28369 130 2 -9884 28325 132 2 -10007 28281 216 2 -10094 28249 339 2 -10089 28249 467 2 -10041 28264 575 2 -10067 28254 616 2 -10188 28209 677 2 -10204 28200 799 2 -10200 28197 949 2 -10218 28185 1110 2 -10202 28184 1257 2 -10235 28164 1420 2 -10093 28220 1326 2 -10125 28204 1415 2 -10219 28161 1587 2 -10132 28196 1530 2 -10099 28204 1593 2 -10115 28189 1749 2 -10146 28169 1883 2 -10069 28189 2003 2 -9845 28275 1896 2 -9895 28250 2002 2 -9940 28226 2123 2 -10083 28169 2204 2 -10087 28163 2256 2 -10099 28153 2332 2 -10162 28123 2419 2 -10250 28082 2516 2 -10339 28038 2639 2 -10436 28012 2538 2 -10562 27964 2544 2 -10458 27990 2677 2 -10397 28001 2798 2 -10475 27966 2865 2 -10523 27933 3001 2 -10530 27924 3060 2 -10628 27877 3150 2 -10668 27850 3254 2 -10792 27792 3340 2 -10902 27737 3430 2 -11021 27680 3512 2 -11142 27633 3502 2 -11281 27581 3467 2 -11307 27555 3591 2 -11279 27544 3757 2 -11114 27604 3810 2 -11137 27577 3933 2 -11156 27550 4066 2 -11205 27510 4203 2 -11326 27459 4210 2 -11384 27459 4052 2 -11511 27421 3950 2 -11439 27458 3902 2 -11329 27515 3819 2 -11307 27544 3668 2 -11336 27552 3519 2 -11409 27536 3408 2 -11537 27490 3343 2 -11671 27443 3270 2 -11777 27386 3359 2 -11896 27318 3492 2 -11975 27296 3399 2 -12063 27272 3276 2 -12149 27252 3118 2 -12223 27212 3178 2 -12327 27161 3214 2 -12312 27172 3180 2 -12207 27227 3110 2 -12167 27260 2971 2 -12159 27284 2786 2 -12256 27246 2732 2 -12378 27199 2648 2 -12514 27139 2623 2 -12635 27077 2679 2 -12692 27039 2798 2 -12700 27020 2938 2 -12647 27032 3050 2 -12545 27067 3167 2 -12494 27080 3252 2 -12472 27070 3413 2 -12336 27139 3359 2 -12327 27139 3398 2 -12400 27088 3532 2 -12343 27097 3663 2 -12423 27052 3721 2 -12506 26999 3830 2 -12582 26945 3956 2 -12622 26908 4081 2 -12632 26881 4222 2 -12750 26831 4189 2 -12833 26782 4249 2 -12859 26743 4409 2 -12902 26704 4520 2 -12897 26675 4702 2 -12900 26651 4827 2 -12970 26596 4944 2 -12991 26559 5083 2 -12970 26538 5243 2 -12951 26518 5389 2 -12948 26489 5539 2 -12939 26460 5697 2 -12831 26513 5695 2 -12757 26569 5597 2 -12680 26631 5479 2 -12647 26673 5348 2 -12599 26725 5201 2 -12570 26761 5083 2 -12504 26817 4950 2 -12423 26880 4811 2 -12365 26894 4879 2 -12410 26845 5032 2 -12341 26877 5030 2 -12336 26873 5064 2 -12401 26815 5212 2 -12453 26766 5340 2 -12418 26778 5362 2 -12412 26778 5375 2 -12448 26735 5506 2 -12445 26708 5638 2 -12496 26658 5764 2 -12448 26675 5789 2 -12354 26721 5778 2 -12243 26785 5714 2 -12095 26874 5611 2 -12146 26822 5746 2 -12040 26874 5729 2 -11947 26939 5620 2 -11901 26979 5522 2 -11797 27045 5420 2 -11737 27089 5332 2 -11678 27137 5214 2 -11671 27170 5057 2 -11610 27217 4946 2 -11514 27279 4827 2 -11469 27319 4705 2 -11424 27352 4622 2 -11300 27425 4490 2 -11301 27413 4562 2 -11315 27388 4676 2 -11230 27420 4694 2 -11126 27488 4540 2 -11113 27481 4616 2 -11049 27509 4601 2 -10989 27523 4664 2 -11049 27476 4797 2 -11028 27457 4950 2 -11098 27423 4984 2 -11097 27406 5078 2 -10928 27456 5171 2 -11004 27424 5182 2 -11144 27379 5120 2 -11221 27331 5207 2 -11267 27303 5257 2 -11319 27259 5369 2 -11343 27225 5492 2 -11367 27191 5609 2 -11319 27200 5658 2 -11198 27263 5599 2 -11057 27337 5518 2 -11016 27333 5615 2 -10942 27355 5655 2 -10834 27410 5594 2 -10778 27416 5676 2 -10707 27468 5556 2 -10615 27480 5672 2 -10541 27515 5642 2 -10459 27543 5657 2 -10375 27597 5548 2 -10430 27594 5458 2 -10522 27569 5408 2 -10495 27586 5373 2 -10561 27579 5280 2 -10534 27594 5255 2 -10366 27659 5245 2 -10443 27643 5178 2 -10532 27636 5032 2 -10470 27665 5006 2 -10373 27698 5025 2 -10268 27754 4929 2 -10290 27765 4821 2 -10229 27797 4767 2 -10320 27770 4726 2 -10290 27788 4686 2 -10341 27778 4629 2 -10262 27816 4581 2 -10326 27798 4544 2 -10303 27818 4472 2 -10273 27852 4327 2 18592 -4797 -23051 0 18486 -4782 -23139 2 18366 -4806 -23230 2 18247 -4798 -23324 2 18129 -4791 -23417 2 18009 -4843 -23499 2 17901 -4823 -23586 2 17804 -4747 -23674 2 17695 -4684 -23769 2 17705 -4542 -23788 2 17800 -4435 -23738 2 17918 -4377 -23660 2 18035 -4352 -23576 2 18164 -4297 -23486 2 18128 -4297 -23514 2 18021 -4327 -23591 2 17901 -4336 -23680 2 17783 -4323 -23771 2 17649 -4288 -23878 2 17685 -4168 -23872 2 17672 -4156 -23883 2 17526 -4157 -23991 2 17587 -3953 -23981 2 17538 -3986 -24011 2 17419 -4051 -24086 2 17320 -4013 -24164 2 17245 -3969 -24225 2 17123 -4009 -24305 2 17012 -4079 -24371 2 16892 -4123 -24447 2 16761 -4146 -24533 2 16669 -4183 -24590 2 16553 -4263 -24654 2 16475 -4390 -24684 2 16389 -4516 -24718 2 16326 -4636 -24738 2 16193 -4736 -24806 2 16146 -4848 -24815 2 16048 -4945 -24860 2 15938 -5028 -24914 2 15857 -5158 -24939 2 15740 -5244 -24995 2 15617 -5273 -25066 2 15493 -5295 -25138 2 15348 -5299 -25226 2 15231 -5340 -25289 2 15100 -5351 -25364 2 14977 -5385 -25430 2 14792 -5442 -25526 2 14745 -5517 -25537 2 14617 -5558 -25602 2 14494 -5526 -25679 2 14534 -5419 -25679 2 14434 -5361 -25747 2 14479 -5336 -25727 2 14606 -5305 -25661 2 14733 -5255 -25600 2 14851 -5188 -25545 2 14820 -5072 -25586 2 14892 -5013 -25556 2 15023 -4995 -25482 2 15140 -4908 -25430 2 15146 -4732 -25460 2 15284 -4723 -25379 2 15413 -4732 -25299 2 15490 -4616 -25274 2 15568 -4498 -25247 2 15632 -4379 -25228 2 15688 -4231 -25219 2 15802 -4156 -25160 2 15909 -4071 -25107 2 16002 -3969 -25063 2 16112 -3880 -25007 2 16175 -3724 -24990 2 16237 -3588 -24969 2 16151 -3517 -25035 2 16022 -3524 -25117 2 15887 -3494 -25207 2 15867 -3363 -25237 2 15943 -3244 -25205 2 16038 -3136 -25158 2 16162 -3111 -25082 2 16285 -3069 -25008 2 16401 -3005 -24939 2 16518 -2931 -24871 2 16640 -2892 -24794 2 16772 -2856 -24709 2 16801 -2716 -24705 2 16809 -2563 -24716 2 16890 -2447 -24673 2 16979 -2337 -24622 2 17095 -2286 -24547 2 17195 -2190 -24485 2 17295 -2108 -24422 2 17390 -2016 -24362 2 17516 -2003 -24273 2 17630 -1949 -24195 2 17734 -1866 -24125 2 17841 -1789 -24052 2 17963 -1761 -23963 2 18082 -1731 -23875 2 18199 -1687 -23789 2 18314 -1635 -23705 2 18425 -1577 -23623 2 18536 -1518 -23539 2 18646 -1452 -23457 2 18755 -1390 -23374 2 18870 -1364 -23282 2 18976 -1335 -23198 2 19092 -1273 -23106 2 19200 -1241 -23018 2 19315 -1239 -22922 2 19425 -1190 -22831 2 19531 -1123 -22744 2 19636 -1058 -22656 2 19743 -1001 -22566 2 19844 -926 -22480 2 19953 -880 -22386 2 20057 -820 -22295 2 20159 -787 -22204 2 20261 -849 -22108 2 20360 -920 -22014 2 20380 -1034 -21990 2 20434 -1116 -21936 2 20536 -1168 -21838 2 20647 -1168 -21733 2 20706 -1277 -21671 2 20771 -1392 -21602 2 20834 -1502 -21533 2 20897 -1616 -21464 2 20973 -1718 -21382 2 21066 -1766 -21286 2 21177 -1732 -21179 2 21239 -1631 -21124 2 21280 -1525 -21091 2 21331 -1347 -21051 2 21380 -1421 -20997 2 21427 -1368 -20952 2 21487 -1243 -20899 2 21515 -1097 -20878 2 21528 -946 -20872 2 21502 -814 -20904 2 21495 -667 -20917 2 21544 -508 -20871 2 21570 -407 -20847 2 21670 -388 -20743 2 21776 -381 -20631 2 21869 -301 -20534 2 21963 -240 -20435 2 22062 -194 -20328 2 22165 -194 -20216 2 22257 -253 -20114 2 22336 -348 -20025 2 22438 -395 -19909 2 22533 -439 -19801 2 22560 -583 -19766 2 22626 -690 -19687 2 22600 -770 -19715 2 22511 -760 -19816 2 22398 -800 -19942 2 22319 -843 -20029 2 22294 -969 -20050 2 22246 -1086 -20099 2 22150 -1172 -20199 2 22046 -1179 -20312 2 21943 -1186 -20423 2 21839 -1164 -20536 2 21730 -1165 -20650 2 21635 -1124 -20753 2 21596 -1197 -20789 2 21643 -1332 -20732 2 21749 -1350 -20620 2 21798 -1315 -20569 2 21890 -1293 -20473 2 21960 -1401 -20392 2 22043 -1446 -20299 2 22137 -1417 -20198 2 22248 -1462 -20072 2 22197 -1542 -20123 2 22098 -1599 -20227 2 22020 -1711 -20303 2 21952 -1809 -20368 2 21969 -1931 -20338 2 21944 -2081 -20350 2 21859 -2136 -20436 2 21769 -2084 -20537 2 21735 -1957 -20585 2 21699 -1810 -20637 2 21626 -1616 -20729 2 21647 -1690 -20702 2 21632 -1881 -20700 2 21553 -1973 -20774 2 21449 -2038 -20876 2 21347 -2075 -20976 2 21226 -2059 -21100 2 21260 -2112 -21061 2 21199 -2236 -21109 2 21099 -2312 -21201 2 20994 -2327 -21304 2 20884 -2348 -21409 2 20778 -2380 -21509 2 20676 -2441 -21599 2 20572 -2494 -21693 2 20464 -2557 -21787 2 20362 -2582 -21880 2 20261 -2627 -21968 2 20150 -2706 -22060 2 20050 -2787 -22141 2 19963 -2881 -22208 2 19874 -3016 -22269 2 19836 -3154 -22284 2 19789 -3295 -22306 2 19675 -3451 -22383 2 19635 -3534 -22405 2 19514 -3607 -22498 2 19531 -3608 -22484 2 19661 -3617 -22369 2 19515 -3753 -22474 2 19605 -3761 -22394 2 19596 -3816 -22393 2 19506 -3935 -22451 2 19503 -4078 -22428 2 19520 -4254 -22380 2 19416 -4204 -22480 2 19370 -4243 -22512 2 19261 -4256 -22603 2 19094 -4188 -22757 2 19069 -4299 -22757 2 18965 -4403 -22824 2 18871 -4504 -22883 2 18787 -4620 -22929 2 18691 -4722 -22986 2 26493 2257 -13893 0 26417 2226 -14042 2 26343 2263 -14176 2 26277 2342 -14284 2 26334 2467 -14158 2 26332 2589 -14140 2 26262 2599 -14267 2 26191 2606 -14397 2 26117 2655 -14522 2 26062 2759 -14599 2 26105 2834 -14508 2 26159 2869 -14403 2 26216 2942 -14286 2 26269 3031 -14169 2 26342 2993 -14040 2 26338 3075 -14030 2 26373 3124 -13954 2 26438 3084 -13838 2 26443 3116 -13823 2 26412 3256 -13849 2 26403 3389 -13834 2 26456 3451 -13718 2 26482 3584 -13633 2 26520 3612 -13552 2 26579 3522 -13459 2 26604 3610 -13386 2 26651 3461 -13332 2 26707 3344 -13250 2 26755 3251 -13176 2 26797 3121 -13122 2 26847 2986 -13051 2 26912 2904 -12935 2 26962 2859 -12841 2 26969 2745 -12850 2 26973 2632 -12865 2 27039 2568 -12740 2 27084 2587 -12639 2 27150 2549 -12504 2 27207 2456 -12400 2 27269 2404 -12273 2 27323 2354 -12161 2 27356 2201 -12117 2 27402 2081 -12034 2 27454 1980 -11932 2 27496 1860 -11853 2 27541 1742 -11766 2 27587 1640 -11674 2 27645 1596 -11541 2 27703 1560 -11407 2 27760 1523 -11272 2 27817 1501 -11133 2 27871 1447 -11006 2 27897 1314 -10957 2 27922 1239 -10901 2 27940 1118 -10866 2 27969 962 -10809 2 27975 838 -10804 2 27966 736 -10833 2 28047 797 -10618 2 28093 875 -10489 2 28133 900 -10378 2 28190 903 -10222 2 28229 997 -10105 2 28255 1047 -10028 2 28297 952 -9919 2 28330 831 -9836 2 28339 680 -9820 2 28368 562 -9745 2 28381 407 -9713 2 28377 249 -9731 2 28358 137 -9787 2 28330 11 -9869 2 28344 -135 -9829 2 28332 -280 -9859 2 28300 -363 -9947 2 28290 -460 -9973 2 28240 -495 -10111 2 28202 -604 -10212 2 28173 -734 -10282 2 28180 -891 -10250 2 28172 -1001 -10264 2 28150 -1140 -10310 2 28128 -1307 -10350 2 28120 -1433 -10354 2 28094 -1544 -10408 2 28037 -1560 -10560 2 27994 -1563 -10673 2 27938 -1574 -10815 2 27887 -1546 -10951 2 27844 -1524 -11064 2 27827 -1502 -11108 2 27807 -1663 -11135 2 27781 -1822 -11177 2 27720 -1745 -11339 2 27659 -1784 -11481 2 27609 -1725 -11609 2 27577 -1625 -11698 2 27551 -1591 -11764 2 27499 -1684 -11874 2 27443 -1713 -11997 2 27408 -1812 -12063 2 27355 -1748 -12193 2 27311 -1733 -12292 2 27255 -1806 -12406 2 27221 -1939 -12460 2 27208 -2093 -12465 2 27175 -2167 -12524 2 27119 -2097 -12655 2 27064 -2038 -12783 2 27006 -1983 -12913 2 26950 -1916 -13039 2 26912 -1821 -13131 2 26885 -1691 -13204 2 26889 -1580 -13210 2 26869 -1512 -13257 2 26847 -1341 -13322 2 26808 -1226 -13410 2 26836 -1143 -13361 2 26856 -1081 -13326 2 26866 -918 -13319 2 26819 -776 -13421 2 26783 -653 -13500 2 26771 -612 -13525 2 26711 -593 -13644 2 26663 -467 -13744 2 26604 -404 -13859 2 26600 -259 -13871 2 26619 -113 -13836 2 26611 46 -13851 2 26594 190 -13882 2 26562 326 -13942 2 26511 422 -14036 2 26491 498 -14071 2 26486 537 -14079 2 26421 448 -14204 2 26353 433 -14330 2 26280 443 -14463 2 26254 548 -14506 2 26307 656 -14405 2 26368 749 -14289 2 26423 836 -14181 2 26476 931 -14077 2 26508 1063 -14007 2 26458 1200 -14090 2 26490 1333 -14019 2 26528 1473 -13932 2 26551 1571 -13877 2 26600 1698 -13768 2 26606 1814 -13742 2 26626 1897 -13691 2 26540 1925 -13853 2 26493 1978 -13935 2 26531 2077 -13849 2 26551 2165 -13797 2 -3761 29749 925 0 -3656 29765 837 2 -3636 29770 722 2 -3716 29761 685 2 -3745 29758 654 2 -3792 29754 574 2 -3902 29740 533 2 -4038 29721 614 2 -4138 29704 746 2 -4137 29705 716 2 -4065 29718 547 2 -4032 29724 476 2 -3937 29738 360 2 -4008 29730 290 2 -4171 29707 338 2 -4171 29708 232 2 -4162 29710 103 2 -4309 29689 -50 2 -4419 29673 -19 2 -4426 29672 116 2 -4479 29664 55 2 -4601 29645 20 2 -4664 29635 115 2 -4581 29646 328 2 -4665 29634 284 2 -4726 29625 103 2 -4854 29604 176 2 -4783 29615 272 2 -4663 29633 359 2 -4592 29642 539 2 -4623 29637 505 2 -4693 29628 372 2 -4835 29606 296 2 -4911 29593 368 2 -4829 29604 529 2 -4815 29605 624 2 -4823 29600 745 2 -4712 29615 849 2 -4560 29639 875 2 -4406 29659 969 2 -4453 29652 960 2 -4609 29630 919 2 -4634 29622 1043 2 -4675 29616 1026 2 -4766 29605 901 2 -4806 29597 951 2 -4835 29593 935 2 -4902 29586 806 2 -4980 29577 656 2 -5090 29558 660 2 -5203 29536 762 2 -5299 29515 878 2 -5345 29508 843 2 -5287 29521 750 2 -5169 29544 656 2 -5065 29564 544 2 -5041 29571 393 2 -5109 29560 306 2 -5239 29537 362 2 -5359 29515 418 2 -5473 29492 509 2 -5631 29461 584 2 -5713 29445 600 2 -5698 29443 797 2 -5811 29422 753 2 -5786 29430 635 2 -5767 29437 484 2 -5838 29424 344 2 -5966 29399 291 2 -6131 29365 287 2 -6123 29365 423 2 -6004 29388 534 2 -6072 29374 567 2 -6158 29356 569 2 -6277 29331 541 2 -6396 29304 585 2 -6426 29295 705 2 -6221 29337 790 2 -6292 29322 798 2 -6450 29289 738 2 -6530 29273 666 2 -6515 29279 525 2 -6405 29305 456 2 -6299 29329 353 2 -6342 29321 215 2 -6483 29290 249 2 -6597 29264 336 2 -6669 29248 313 2 -6715 29238 171 2 -6841 29210 72 2 -6991 29174 76 2 -6959 29181 166 2 -7016 29167 259 2 -7001 29169 407 2 -7065 29151 529 2 -7015 29161 644 2 -6926 29179 767 2 -6896 29182 911 2 -6923 29172 1031 2 -7043 29140 1132 2 -7013 29142 1251 2 -6887 29167 1360 2 -6796 29185 1444 2 -6652 29218 1429 2 -6663 29221 1322 2 -6572 29244 1254 2 -6560 29252 1130 2 -6560 29258 968 2 -6445 29284 943 2 -6448 29282 994 2 -6497 29266 1133 2 -6451 29270 1279 2 -6318 29296 1347 2 -6157 29332 1304 2 -6088 29340 1454 2 -5988 29359 1470 2 -5913 29372 1521 2 -5816 29395 1450 2 -5756 29403 1518 2 -5624 29430 1506 2 -5589 29443 1365 2 -5651 29438 1214 2 -5609 29448 1173 2 -5525 29461 1240 2 -5475 29466 1322 2 -5480 29458 1478 2 -5419 29472 1422 2 -5435 29478 1230 2 -5357 29491 1263 2 -5321 29491 1401 2 -5246 29498 1529 2 -5113 29525 1468 2 -5092 29525 1538 2 -5048 29524 1688 2 -4896 29553 1634 2 -4729 29577 1686 2 -4637 29587 1760 2 -4492 29608 1783 2 -4353 29626 1826 2 -4203 29645 1865 2 -4052 29663 1912 2 -4041 29670 1834 2 -4158 29660 1739 2 -4306 29645 1613 2 -4258 29652 1626 2 -4117 29666 1722 2 -4080 29678 1612 2 -4060 29678 1655 2 -3959 29684 1782 2 -3854 29693 1870 2 -3700 29708 1930 2 -3555 29725 1943 2 -3478 29742 1814 2 -3412 29756 1708 2 -3391 29765 1587 2 -3521 29757 1461 2 -3445 29765 1466 2 -3404 29774 1380 2 -3427 29779 1221 2 -3460 29778 1136 2 -3569 29767 1084 2 -3544 29773 1009 2 -3536 29778 870 2 -3626 29768 859 2 -3750 29750 942 2 -21883 20471 1436 0 -21818 20543 1406 3 -21731 20639 1341 3 -21631 20744 1330 3 -21524 20855 1327 3 -21422 20957 1381 3 -21313 21066 1398 3 -21221 21156 1458 3 -21120 21246 1585 3 -21185 21178 1642 3 -21149 21209 1699 3 -21040 21315 1719 3 -20961 21385 1817 3 -20850 21489 1868 3 -20858 21468 2018 3 -20896 21418 2153 3 -20932 21369 2289 3 -20975 21312 2419 3 -21067 21217 2450 3 -21178 21102 2487 3 -21289 20991 2484 3 -21379 20907 2418 3 -21471 20823 2321 3 -21568 20723 2319 3 -21552 20726 2442 3 -21459 20812 2518 3 -21405 20851 2661 3 -21467 20773 2768 3 -21566 20665 2809 3 -21665 20555 2847 3 -21722 20483 2937 3 -21645 20546 3063 3 -21552 20632 3137 3 -21447 20743 3121 3 -21340 20855 3108 3 -21234 20957 3147 3 -21135 21046 3220 3 -21029 21153 3211 3 -20929 21269 3104 3 -20905 21279 3188 3 -20987 21183 3291 3 -21051 21107 3366 3 -21059 21077 3501 3 -21074 21035 3661 3 -20958 21136 3744 3 -20898 21200 3723 3 -20804 21306 3637 3 -20743 21384 3528 3 -20680 21460 3435 3 -20607 21546 3334 3 -20604 21572 3183 3 -20604 21594 3032 3 -20595 21623 2878 3 -20593 21645 2723 3 -20608 21648 2584 3 -20616 21657 2438 3 -20609 21681 2287 3 -20581 21721 2149 3 -20538 21775 2010 3 -20447 21864 1980 3 -20374 21938 1903 3 -20255 22049 1896 3 -20167 22138 1792 3 -20049 22246 1781 3 -20025 22277 1657 3 -20038 22276 1507 3 -19978 22337 1391 3 -19878 22430 1322 3 -19768 22531 1256 3 -19740 22562 1129 3 -19742 22567 979 3 -19716 22597 826 3 -19682 22631 661 3 -19807 22524 566 3 -19879 22464 433 3 -19882 22464 316 3 -19979 22378 255 3 -20060 22306 166 3 -20124 22249 35 3 -20167 22210 -105 3 -20210 22170 -245 3 -20277 22107 -365 3 -20358 22030 -470 3 -20432 21959 -582 3 -20514 21878 -712 3 -20559 21839 -638 3 -20523 21876 -483 3 -20488 21912 -344 3 -20563 21842 -311 3 -20597 21811 -242 3 -20601 21808 -92 3 -20547 21859 40 3 -20516 21888 182 3 -20465 21933 317 3 -20397 21994 461 3 -20488 21908 547 3 -20490 21903 625 3 -20486 21902 770 3 -20548 21841 880 3 -20615 21772 994 3 -20628 21752 1154 3 -20590 21781 1281 3 -20534 21826 1413 3 -20518 21830 1565 3 -20480 21852 1740 3 -20560 21771 1816 3 -20569 21750 1969 3 -20606 21704 2080 3 -20697 21609 2160 3 -20739 21577 2082 3 -20763 21566 1941 3 -20763 21577 1817 3 -20739 21612 1669 3 -20793 21571 1529 3 -20820 21556 1378 3 -20905 21479 1270 3 -20896 21491 1233 3 -20882 21509 1144 3 -20899 21496 1068 3 -20996 21405 997 3 -21093 21313 927 3 -21190 21219 857 3 -21316 21096 765 3 -21279 21128 918 3 -21389 21015 936 3 -21494 20908 916 3 -21596 20805 863 3 -21699 20698 853 3 -21799 20594 812 3 -21902 20486 812 3 -22001 20377 846 3 -22104 20265 846 3 -22206 20153 859 3 -22296 20051 920 3 -22381 19952 996 3 -22384 19942 1136 3 -22326 19999 1264 3 -22239 20090 1346 3 -22145 20189 1411 3 -22045 20296 1446 3 -21943 20406 1449 3 25827 -2922 -14981 0 25764 -2899 -15093 2 25783 -2759 -15088 2 25804 -2618 -15077 2 25788 -2480 -15127 2 25801 -2327 -15128 2 25816 -2177 -15126 2 25822 -2028 -15137 2 25819 -1884 -15159 2 25835 -1726 -15152 2 25877 -1585 -15096 2 25833 -1473 -15182 2 25773 -1390 -15291 2 25698 -1398 -15417 2 25670 -1500 -15453 2 25666 -1668 -15443 2 25695 -1812 -15378 2 25644 -1936 -15448 2 25581 -2032 -15539 2 25504 -2118 -15655 2 25494 -2243 -15654 2 25498 -2403 -15623 2 25442 -2509 -15698 2 25350 -2511 -15845 2 25321 -2367 -15913 2 25246 -2322 -16040 2 25165 -2307 -16167 2 25132 -2193 -16235 2 25193 -2114 -16150 2 25235 -2009 -16098 2 25312 -1902 -15990 2 25306 -1753 -16017 2 25296 -1634 -16045 2 25346 -1506 -15979 2 25409 -1390 -15890 2 25452 -1255 -15831 2 25510 -1150 -15745 2 25592 -1004 -15621 2 25531 -995 -15722 2 25470 -893 -15827 2 25395 -840 -15950 2 25326 -768 -16062 2 25273 -656 -16151 2 25225 -539 -16230 2 25161 -464 -16332 2 25080 -511 -16453 2 25038 -387 -16521 2 25107 -300 -16418 2 25196 -354 -16281 2 25251 -406 -16194 2 25331 -398 -16068 2 25403 -451 -15953 2 25477 -496 -15833 2 25554 -453 -15709 2 25620 -555 -15598 2 25663 -677 -15522 2 25724 -730 -15419 2 25799 -692 -15294 2 25837 -551 -15237 2 25900 -469 -15133 2 25952 -354 -15045 2 25972 -208 -15014 2 25973 -58 -15014 2 25946 83 -15059 2 25902 207 -15134 2 25834 274 -15249 2 25760 240 -15374 2 25684 230 -15501 2 25603 252 -15634 2 25530 263 -15753 2 25455 234 -15874 2 25376 252 -15999 2 25289 258 -16137 2 25217 255 -16249 2 25133 238 -16380 2 25061 162 -16490 2 24976 154 -16618 2 24892 172 -16744 2 24809 199 -16866 2 24730 261 -16981 2 24684 380 -17046 2 24622 491 -17133 2 24565 605 -17210 2 24517 745 -17273 2 24534 871 -17243 2 24605 825 -17143 2 24679 712 -17042 2 24725 622 -16979 2 24793 530 -16882 2 24873 459 -16767 2 24955 448 -16645 2 25036 472 -16521 2 25113 494 -16403 2 25196 458 -16278 2 25274 503 -16155 2 25353 532 -16030 2 25433 552 -15901 2 25510 562 -15777 2 25582 620 -15658 2 25645 661 -15553 2 25726 694 -15418 2 25764 586 -15358 2 25813 463 -15280 2 25886 468 -15156 2 25939 408 -15067 2 25981 287 -14997 2 26023 152 -14926 2 26043 -13 -14892 2 26038 -142 -14899 2 26033 -360 -14904 2 26083 -420 -14815 2 26120 -557 -14746 2 26151 -688 -14685 2 26149 -839 -14681 2 26143 -996 -14682 2 26178 -1129 -14609 2 26188 -1276 -14579 2 26240 -1381 -14476 2 26251 -1496 -14444 2 26247 -1641 -14437 2 26212 -1820 -14478 2 26145 -1823 -14598 2 26074 -1846 -14722 2 26051 -1996 -14743 2 26016 -2125 -14786 2 26006 -2290 -14780 2 26014 -2439 -14742 2 26015 -2587 -14716 2 26032 -2726 -14659 2 26007 -2884 -14673 2 25946 -2959 -14766 2 25874 -2929 -14898 2 29737 2888 -2716 0 29746 2775 -2728 2 29754 2637 -2780 2 29760 2497 -2852 2 29758 2391 -2952 2 29756 2280 -3065 2 29751 2181 -3179 2 29746 2080 -3289 2 29742 1974 -3398 2 29726 1940 -3549 2 29720 1832 -3656 2 29716 1709 -3748 2 29712 1585 -3830 2 29702 1488 -3948 2 29703 1341 -3989 2 29702 1207 -4043 2 29684 1164 -4181 2 29669 1079 -4314 2 29652 1006 -4443 2 29639 880 -4559 2 29638 744 -4583 2 29633 602 -4638 2 29628 458 -4684 2 29623 315 -4734 2 29617 161 -4776 2 29597 96 -4902 2 29574 23 -5035 2 29563 -107 -5099 2 29547 -224 -5188 2 29529 -339 -5284 2 29511 -461 -5375 2 29501 -607 -5417 2 29482 -733 -5501 2 29467 -869 -5562 2 29448 -999 -5640 2 29440 -1148 -5652 2 29421 -1285 -5721 2 29396 -1390 -5824 2 29372 -1501 -5918 2 29350 -1632 -5991 2 29324 -1739 -6091 2 29293 -1827 -6211 2 29262 -1920 -6330 2 29241 -2059 -6382 2 29211 -2166 -6484 2 29178 -2256 -6600 2 29145 -2354 -6710 2 29110 -2438 -6832 2 29076 -2532 -6940 2 29038 -2602 -7074 2 29002 -2702 -7181 2 28971 -2820 -7261 2 28933 -2928 -7369 2 28883 -3059 -7512 2 28894 -2930 -7520 2 28873 -2914 -7605 2 28822 -3001 -7763 2 28810 -2916 -7841 2 28782 -2927 -7939 2 28738 -3033 -8060 2 28724 -2947 -8138 2 28735 -2797 -8154 2 28744 -2647 -8173 2 28755 -2497 -8181 2 28766 -2347 -8186 2 28785 -2201 -8159 2 28783 -2045 -8207 2 28802 -1908 -8173 2 28796 -1760 -8228 2 28786 -1636 -8286 2 28817 -1532 -8199 2 28845 -1410 -8122 2 28874 -1277 -8042 2 28917 -1238 -7891 2 28958 -1225 -7741 2 28992 -1354 -7590 2 28993 -1255 -7605 2 28979 -1111 -7679 2 29013 -1026 -7563 2 29029 -920 -7513 2 29041 -769 -7486 2 29050 -621 -7462 2 29074 -549 -7377 2 29114 -534 -7217 2 29145 -498 -7093 2 29176 -399 -6971 2 29175 -264 -6981 2 29181 -161 -6959 2 29176 -91 -6980 2 29149 -11 -7096 2 29141 123 -7125 2 29165 216 -7024 2 29198 256 -6886 2 29228 177 -6758 2 29276 112 -6550 2 29260 146 -6620 2 29228 232 -6758 2 29239 357 -6706 2 29271 386 -6561 2 29299 445 -6432 2 29316 562 -6343 2 29324 704 -6294 2 29345 806 -6182 2 29370 870 -6054 2 29395 927 -5924 2 29402 1068 -5863 2 29421 1172 -5749 2 29443 1068 -5655 2 29460 1101 -5558 2 29479 1185 -5437 2 29493 1353 -5323 2 29510 1397 -5216 2 29510 1537 -5174 2 29522 1647 -5072 2 29539 1728 -4946 2 29552 1823 -4830 2 29568 1902 -4703 2 29585 1971 -4564 2 29594 2077 -4461 2 29611 2152 -4311 2 29605 2247 -4298 2 29608 2371 -4212 2 29608 2490 -4140 2 29611 2603 -4049 2 29618 2709 -3932 2 29637 2710 -3782 2 29651 2749 -3641 2 29670 2741 -3493 2 29688 2730 -3344 2 29701 2763 -3198 2 29706 2850 -3075 2 29711 2927 -2947 2 29725 2934 -2799 2 17606 18970 15171 0 17593 18901 15271 3 17617 18783 15390 3 17696 18659 15450 3 17771 18540 15507 3 17859 18423 15545 3 17964 18320 15546 3 18084 18262 15475 3 18199 18247 15358 3 18306 18208 15276 3 18420 18108 15257 3 18539 18033 15202 3 18658 17969 15133 3 18769 17928 15043 3 18878 17900 14941 3 18981 17883 14830 3 19053 17914 14699 3 19128 17940 14570 3 19197 17973 14438 3 19268 18001 14307 3 19351 18014 14180 3 19377 18016 14140 3 19274 18197 14049 3 19185 18315 14017 3 19100 18436 13975 3 19035 18555 13906 3 18956 18674 13854 3 18901 18789 13774 3 18811 18890 13759 3 18714 18968 13785 3 18597 19001 13897 3 18526 19084 13878 3 18553 19105 13813 3 18596 19123 13730 3 18484 19246 13709 3 18380 19241 13855 3 18269 19324 13886 3 18182 19438 13842 3 18133 19551 13746 3 18112 19644 13641 3 18240 19600 13534 3 18313 19581 13462 3 18401 19548 13390 3 18453 19588 13258 3 18488 19644 13126 3 18427 19737 13072 3 18298 19814 13137 3 18179 19896 13178 3 18076 20008 13151 3 17965 20109 13149 3 17867 20113 13276 3 17807 20080 13405 3 17844 19968 13523 3 17920 19864 13575 3 17963 19784 13635 3 17788 19943 13634 3 17694 20051 13597 3 17626 20155 13531 3 17590 20257 13425 3 17519 20348 13381 3 17383 20400 13478 3 17275 20431 13571 3 17148 20517 13601 3 17049 20562 13658 3 16944 20678 13613 3 16828 20771 13616 3 16717 20870 13601 3 16603 20941 13632 3 16485 20988 13701 3 16448 21071 13620 3 16553 21068 13496 3 16670 21034 13404 3 16693 21064 13329 3 16520 21178 13364 3 16509 21260 13245 3 16504 21344 13118 3 16577 21360 12998 3 16676 21360 12872 3 16779 21343 12765 3 16829 21361 12670 3 16693 21471 12662 3 16665 21563 12542 3 16604 21664 12449 3 16504 21768 12400 3 16427 21866 12331 3 16310 21921 12388 3 16226 21907 12522 3 16157 21897 12628 3 16045 21940 12696 3 15928 21972 12787 3 15865 21935 12929 3 15825 21890 13053 3 15792 21836 13183 3 15741 21779 13338 3 15672 21758 13454 3 15688 21676 13566 3 15655 21614 13702 3 15661 21541 13810 3 15593 21486 13971 3 15502 21460 14113 3 15474 21429 14191 3 15539 21304 14307 3 15565 21205 14425 3 15560 21142 14522 3 15563 21046 14658 3 15676 20972 14644 3 15802 20899 14613 3 15930 20790 14629 3 15999 20719 14654 3 16100 20576 14744 3 16174 20467 14816 3 16291 20371 14820 3 16403 20278 14823 3 16525 20187 14812 3 16641 20090 14815 3 16759 20011 14788 3 16883 19924 14765 3 17002 19832 14753 3 17106 19725 14775 3 17223 19631 14764 3 17338 19540 14750 3 17460 19508 14650 3 17579 19445 14591 3 17585 19407 14633 3 17483 19406 14756 3 17446 19330 14899 3 17497 19217 14986 3 17545 19101 15078 3 17615 19014 15105 3 19067 -11237 20253 0 19034 -11359 20216 2 19005 -11510 20157 2 18995 -11645 20089 2 19026 -11758 19993 2 19023 -11890 19918 2 19002 -12007 19868 2 18944 -12149 19837 2 18905 -12288 19789 2 18897 -12413 19719 2 18922 -12525 19623 2 18919 -12657 19541 2 18980 -12758 19416 2 19037 -12808 19328 2 19127 -12847 19212 2 19189 -12929 19095 2 19287 -12941 18988 2 19400 -12889 18908 2 19514 -12818 18839 2 19629 -12767 18754 2 19741 -12753 18646 2 19853 -12705 18560 2 19952 -12621 18510 2 20036 -12484 18512 2 20114 -12352 18517 2 20193 -12224 18515 2 20274 -12096 18511 2 20340 -11959 18527 2 20413 -11826 18533 2 20481 -11691 18544 2 20540 -11553 18564 2 20607 -11417 18574 2 20678 -11284 18577 2 20755 -11156 18568 2 20826 -11021 18569 2 20895 -10886 18571 2 20960 -10748 18579 2 21023 -10610 18586 2 21089 -10473 18590 2 21163 -10341 18579 2 21225 -10218 18577 2 21292 -10070 18581 2 21361 -9936 18573 2 21427 -9799 18571 2 21498 -9666 18558 2 21568 -9532 18546 2 21632 -9394 18542 2 21682 -9256 18553 2 21737 -9114 18559 2 21752 -8974 18609 2 21807 -8833 18613 2 21888 -8719 18571 2 21941 -8633 18549 2 21997 -8479 18554 2 22007 -8344 18603 2 22012 -8206 18658 2 22026 -8060 18705 2 22105 -8010 18634 2 22118 -8145 18559 2 22169 -8227 18462 2 22252 -8104 18416 2 22312 -7963 18405 2 22325 -7827 18449 2 22307 -7696 18525 2 22310 -7554 18579 2 22332 -7407 18613 2 22350 -7261 18648 2 22364 -7114 18688 2 22362 -6969 18745 2 22360 -6833 18797 2 22352 -6697 18855 2 22305 -6606 18944 2 22290 -6461 19011 2 22227 -6310 19135 2 22152 -6377 19199 2 22057 -6481 19274 2 22055 -6630 19226 2 22014 -6770 19224 2 21960 -6916 19233 2 21860 -6981 19324 2 21766 -7099 19387 2 21695 -7043 19487 2 21631 -7093 19540 2 21617 -7310 19475 2 21563 -7374 19510 2 21530 -7563 19475 2 21451 -7634 19534 2 21370 -7770 19570 2 21362 -7675 19615 2 21303 -7723 19660 2 21188 -7947 19695 2 21141 -7895 19767 2 21032 -7972 19852 2 20939 -8057 19916 2 20897 -8185 19907 2 20871 -8219 19921 2 20794 -8165 20024 2 20698 -8166 20122 2 20603 -8249 20186 2 20496 -8278 20282 2 20381 -8332 20376 2 20280 -8370 20461 2 20172 -8410 20552 2 20134 -8566 20524 2 20063 -8700 20538 2 19979 -8826 20566 2 19899 -8947 20591 2 19854 -9086 20573 2 19844 -9221 20523 2 19818 -9364 20483 2 19806 -9503 20431 2 19822 -9632 20354 2 19798 -9766 20314 2 19804 -9905 20241 2 19806 -10035 20175 2 19765 -10176 20144 2 19720 -10302 20124 2 19634 -10427 20144 2 19551 -10539 20167 2 19457 -10666 20190 2 19388 -10803 20184 2 19287 -10892 20233 2 19208 -10984 20258 2 19140 -11130 20243 2 14146 19873 -17463 0 14250 19783 -17481 2 14167 19761 -17573 2 14202 19665 -17651 2 14326 19646 -17572 2 14360 19749 -17429 2 14450 19690 -17421 2 14560 19589 -17443 2 14674 19510 -17437 2 14712 19393 -17535 2 14834 19261 -17578 2 14820 19161 -17698 2 14893 19044 -17764 2 14990 18937 -17796 2 15082 18822 -17840 2 15193 18722 -17851 2 15293 18610 -17882 2 15388 18501 -17914 2 15517 18435 -17871 2 15634 18350 -17856 2 15742 18245 -17869 2 15864 18161 -17847 2 15990 18105 -17792 2 16118 18055 -17727 2 16242 17995 -17675 2 16351 17974 -17595 2 16325 18098 -17491 2 16177 18218 -17504 2 16233 18237 -17433 2 16356 18174 -17384 2 16415 18062 -17445 2 16493 17940 -17497 2 16605 17840 -17494 2 16728 17751 -17467 2 16844 17650 -17457 2 16905 17521 -17528 2 17026 17441 -17491 2 17138 17426 -17396 2 17177 17482 -17301 2 17292 17483 -17185 2 17403 17472 -17083 2 17523 17432 -17002 2 17635 17419 -16899 2 17754 17422 -16772 2 17833 17439 -16669 2 17960 17388 -16586 2 18073 17297 -16558 2 18191 17213 -16516 2 18309 17130 -16473 2 18431 17059 -16411 2 18546 16978 -16365 2 18651 16948 -16276 2 18751 16872 -16240 2 18776 16770 -16317 2 18671 16767 -16440 2 18566 16780 -16546 2 18502 16716 -16681 2 18435 16768 -16703 2 18342 16891 -16681 2 18263 16889 -16770 2 18123 16912 -16898 2 18042 16925 -16971 2 17936 16976 -17032 2 17806 17001 -17144 2 17687 17062 -17207 2 17574 17103 -17282 2 17484 17078 -17397 2 17393 17062 -17504 2 17341 17025 -17592 2 17474 16905 -17576 2 17548 16780 -17621 2 17550 16672 -17722 2 17533 16583 -17821 2 17445 16553 -17936 2 17339 16642 -17956 2 17215 16765 -17960 2 17114 16857 -17971 2 16986 16899 -18053 2 16921 16955 -18061 2 16966 17046 -17933 2 16893 17164 -17889 2 16818 17157 -17966 2 16771 17077 -18087 2 16723 17050 -18156 2 16610 17057 -18253 2 16487 17048 -18373 2 16379 17127 -18396 2 16220 17222 -18447 2 16225 17085 -18570 2 16103 17171 -18597 2 16031 17289 -18551 2 15883 17310 -18657 2 15737 17437 -18662 2 15778 17340 -18718 2 15850 17206 -18781 2 15777 17217 -18833 2 15646 17286 -18878 2 15557 17410 -18838 2 15434 17492 -18864 2 15380 17556 -18848 2 15386 17665 -18741 2 15337 17783 -18670 2 15250 17902 -18626 2 15146 18010 -18607 2 15050 18115 -18584 2 14981 18235 -18522 2 14935 18353 -18442 2 14901 18470 -18353 2 14795 18590 -18317 2 14682 18615 -18383 2 14624 18650 -18393 2 14567 18756 -18330 2 14459 18862 -18307 2 14343 18962 -18296 2 14253 19078 -18245 2 14203 19189 -18167 2 14173 19305 -18068 2 14155 19410 -17970 2 14181 19503 -17848 2 14161 19610 -17746 2 14100 19725 -17667 2 14064 19824 -17585 2 -1369 25599 15582 0 -1389 25542 15674 2 -1457 25488 15756 2 -1455 25427 15855 2 -1492 25411 15877 2 -1592 25380 15915 2 -1602 25295 16049 2 -1576 25237 16144 2 -1622 25160 16259 2 -1691 25080 16375 2 -1657 25029 16456 2 -1520 25077 16396 2 -1509 25059 16425 2 -1566 25001 16507 2 -1634 24899 16655 2 -1642 24827 16761 2 -1685 24706 16934 2 -1622 24747 16881 2 -1582 24828 16765 2 -1506 24913 16645 2 -1456 24866 16720 2 -1436 24804 16813 2 -1391 24726 16933 2 -1462 24641 17049 2 -1528 24560 17160 2 -1472 24501 17250 2 -1307 24513 17246 2 -1170 24523 17241 2 -991 24562 17196 2 -1000 24535 17235 2 -1083 24449 17352 2 -1045 24368 17468 2 -940 24319 17542 2 -906 24255 17632 2 -928 24173 17743 2 -931 24072 17880 2 -1030 24055 17897 2 -1185 24051 17892 2 -1325 24010 17938 2 -1452 23925 18041 2 -1375 23912 18065 2 -1287 23845 18159 2 -1316 23762 18266 2 -1424 23697 18342 2 -1565 23655 18384 2 -1676 23586 18463 2 -1601 23533 18538 2 -1399 23540 18544 2 -1317 23502 18599 2 -1202 23475 18641 2 -1066 23450 18681 2 -862 23523 18599 2 -915 23466 18668 2 -1008 23394 18754 2 -1158 23382 18760 2 -1315 23382 18750 2 -1428 23326 18811 2 -1516 23250 18898 2 -1621 23176 18980 2 -1717 23105 19058 2 -1864 23035 19129 2 -1808 23003 19173 2 -1696 23020 19162 2 -1588 23075 19105 2 -1425 23096 19093 2 -1282 23068 19137 2 -1177 23118 19083 2 -1106 23196 18993 2 -941 23215 18979 2 -805 23178 19029 2 -655 23203 19006 2 -493 23246 18957 2 -366 23254 18951 2 -257 23241 18968 2 -88 23252 18956 2 66 23240 18971 2 209 23274 18928 2 335 23314 18877 2 447 23404 18764 2 237 23456 18702 2 288 23541 18594 2 401 23611 18502 2 498 23672 18423 2 545 23760 18307 2 545 23850 18190 2 450 23919 18102 2 307 23945 18070 2 158 23924 18100 2 49 23931 18092 2 102 24025 17966 2 34 24108 17856 2 -137 24171 17770 2 -20 24167 17775 2 -43 24240 17676 2 -72 24322 17563 2 -163 24402 17450 2 -297 24450 17381 2 -378 24497 17314 2 -428 24582 17191 2 -464 24665 17071 2 -504 24749 16948 2 -595 24814 16850 2 -709 24863 16773 2 -840 24873 16752 2 -1010 24872 16744 2 -970 24886 16725 2 -812 24936 16659 2 -870 24984 16585 2 -867 24999 16561 2 -739 25038 16509 2 -660 25106 16408 2 -597 25184 16292 2 -537 25260 16175 2 -527 25329 16067 2 -664 25349 16030 2 -814 25352 16018 2 -965 25354 16007 2 -1163 25329 16034 2 -1115 25385 15948 2 -1052 25452 15846 2 -936 25507 15765 2 -863 25593 15629 2 -993 25606 15600 2 -1165 25588 15617 2 -1290 25592 15600 2 -8155 28629 -3723 0 -8112 28651 -3649 2 -7998 28694 -3562 2 -7853 28736 -3548 2 -7814 28730 -3679 2 -7820 28709 -3827 2 -7832 28685 -3978 2 -7863 28657 -4117 2 -7908 28624 -4256 2 -8031 28579 -4332 2 -8103 28539 -4459 2 -8235 28484 -4566 2 -8328 28472 -4468 2 -8402 28452 -4462 2 -8483 28437 -4402 2 -8532 28446 -4247 2 -8581 28453 -4094 2 -8598 28441 -4147 2 -8604 28423 -4252 2 -8592 28404 -4404 2 -8575 28385 -4556 2 -8651 28347 -4649 2 -8806 28306 -4605 2 -8890 28299 -4487 2 -8961 28296 -4361 2 -9024 28298 -4218 2 -9054 28310 -4069 2 -9129 28304 -3944 2 -9232 28285 -3838 2 -9368 28254 -3737 2 -9384 28239 -3810 2 -9353 28232 -3935 2 -9271 28240 -4071 2 -9197 28245 -4200 2 -9153 28237 -4346 2 -9118 28225 -4493 2 -9094 28209 -4642 2 -9169 28169 -4739 2 -9322 28121 -4720 2 -9446 28084 -4694 2 -9570 28059 -4596 2 -9640 28056 -4466 2 -9727 28050 -4310 2 -9835 28014 -4301 2 -9966 27961 -4344 2 -10111 27913 -4318 2 -10166 27914 -4180 2 -10212 27921 -4014 2 -10238 27929 -3893 2 -10275 27936 -3744 2 -10288 27951 -3592 2 -10247 27985 -3444 2 -10256 27999 -3301 2 -10221 28028 -3159 2 -10113 28080 -3045 2 -10198 28055 -2984 2 -10283 28034 -2888 2 -10382 28007 -2796 2 -10465 27988 -2680 2 -10537 27974 -2540 2 -10557 27979 -2394 2 -10482 28021 -2226 2 -10332 28076 -2235 2 -10357 28054 -2391 2 -10300 28075 -2391 2 -10185 28115 -2414 2 -10180 28124 -2319 2 -10120 28156 -2191 2 -10183 28144 -2051 2 -10131 28170 -1953 2 -9997 28216 -1988 2 -9900 28243 -2085 2 -9745 28286 -2224 2 -9698 28295 -2312 2 -9573 28332 -2384 2 -9428 28376 -2433 2 -9289 28426 -2383 2 -9149 28473 -2359 2 -9007 28517 -2381 2 -8863 28562 -2380 2 -8716 28607 -2375 2 -8574 28651 -2364 2 -8432 28691 -2395 2 -8301 28723 -2472 2 -8232 28730 -2608 2 -8288 28704 -2718 2 -8444 28655 -2754 2 -8587 28611 -2772 2 -8725 28567 -2793 2 -8882 28519 -2788 2 -8973 28483 -2860 2 -8920 28493 -2928 2 -8779 28538 -2915 2 -8630 28584 -2906 2 -8490 28627 -2903 2 -8355 28661 -2955 2 -8236 28687 -3041 2 -8340 28654 -3065 2 -8458 28616 -3097 2 -8455 28601 -3238 2 -8470 28584 -3346 2 -8449 28588 -3364 2 -8341 28633 -3256 2 -8207 28666 -3297 2 -8096 28685 -3411 2 -8165 28648 -3556 2 -8180 28629 -3670 2 -27734 11163 2489 0 -27715 11176 2640 2 -27707 11168 2754 2 -27666 11234 2897 2 -27620 11321 2998 2 -27597 11336 3148 2 -27559 11394 3267 2 -27508 11486 3377 2 -27460 11561 3502 2 -27437 11569 3653 2 -27419 11564 3804 2 -27413 11519 3978 2 -27465 11437 3855 2 -27489 11361 3909 2 -27482 11331 4043 2 -27465 11307 4218 2 -27454 11303 4302 2 -27448 11263 4444 2 -27415 11280 4602 2 -27436 11177 4727 2 -27440 11107 4867 2 -27425 11074 5021 2 -27417 11030 5159 2 -27388 11034 5307 2 -27358 11036 5453 2 -27389 10911 5549 2 -27432 10778 5597 2 -27445 10683 5712 2 -27446 10612 5839 2 -27418 10600 5990 2 -27385 10589 6157 2 -27410 10471 6249 2 -27472 10362 6158 2 -27546 10233 6042 2 -27529 10198 6174 2 -27495 10207 6312 2 -27454 10228 6456 2 -27414 10238 6606 2 -27375 10249 6749 2 -27342 10239 6896 2 -27317 10208 7043 2 -27261 10236 7217 2 -27233 10237 7319 2 -27179 10284 7452 2 -27106 10343 7635 2 -27100 10438 7525 2 -27095 10536 7406 2 -27113 10592 7259 2 -27147 10605 7112 2 -27173 10642 6956 2 -27138 10747 6929 2 -27154 10798 6787 2 -27166 10846 6664 2 -27193 10872 6506 2 -27203 10917 6390 2 -27201 11005 6247 2 -27205 11041 6163 2 -27184 11162 6037 2 -27197 11118 6062 2 -27204 11111 6040 2 -27211 11181 5878 2 -27205 11253 5765 2 -27203 11325 5636 2 -27204 11387 5502 2 -27215 11419 5381 2 -27245 11426 5213 2 -27248 11479 5077 2 -27225 11582 4969 2 -27212 11661 4848 2 -27227 11688 4698 2 -27231 11745 4534 2 -27243 11761 4418 2 -27262 11777 4250 2 -27286 11772 4114 2 -27294 11796 3987 2 -27311 11806 3835 2 -27335 11799 3685 2 -27375 11748 3548 2 -27405 11725 3392 2 -27429 11705 3261 2 -27468 11651 3120 2 -27505 11603 2977 2 -27542 11546 2848 2 -27596 11442 2742 2 -27656 11299 2734 2 -27681 11249 2685 2 -27714 11204 2525 2 -15425 23492 10498 0 -15483 23493 10411 2 -15604 23447 10333 2 -15727 23380 10297 2 -15842 23304 10294 2 -15992 23206 10284 2 -16103 23132 10275 2 -16224 23041 10290 2 -16347 22951 10298 2 -16487 22827 10350 2 -16595 22774 10292 2 -16652 22683 10401 2 -16726 22664 10322 2 -16928 22537 10273 2 -17023 22500 10197 2 -16964 22465 10371 2 -17064 22397 10354 2 -17187 22328 10298 2 -17311 22248 10265 2 -17370 22154 10368 2 -17277 22159 10512 2 -17185 22184 10609 2 -17115 22175 10740 2 -17047 22160 10879 2 -16982 22145 11008 2 -16905 22151 11117 2 -16777 22190 11232 2 -16668 22237 11301 2 -16686 22204 11338 2 -16777 22137 11335 2 -16755 22117 11407 2 -16657 22153 11480 2 -16575 22175 11556 2 -16546 22160 11627 2 -16675 22085 11585 2 -16801 22002 11561 2 -16921 21954 11475 2 -16946 21897 11548 2 -16841 21922 11654 2 -16724 21997 11680 2 -16557 22091 11740 2 -16502 22105 11793 2 -16364 22215 11778 2 -16315 22219 11837 2 -16382 22109 11951 2 -16474 22028 11975 2 -16600 21924 11991 2 -16590 21891 12064 2 -16453 21975 12099 2 -16451 21952 12143 2 -16527 21855 12216 2 -16463 21831 12344 2 -16325 21931 12349 2 -16230 22022 12314 2 -16091 22157 12252 2 -16203 22115 12182 2 -16196 22157 12114 2 -16028 22300 12076 2 -16122 22271 12004 2 -16273 22164 11999 2 -16264 22224 11899 2 -16174 22320 11842 2 -16065 22378 11881 2 -15899 22471 11927 2 -15958 22477 11837 2 -16067 22449 11743 2 -16017 22494 11726 2 -15986 22559 11644 2 -15876 22641 11633 2 -15754 22728 11629 2 -15782 22790 11469 2 -15872 22781 11362 2 -15960 22765 11271 2 -16065 22741 11168 2 -16076 22784 11065 2 -16136 22804 10935 2 -16112 22853 10868 2 -15969 22942 10893 2 -15990 22992 10756 2 -16088 22955 10687 2 -16232 22871 10651 2 -16218 22900 10609 2 -16109 22990 10581 2 -15967 23088 10584 2 -15853 23162 10594 2 -15729 23250 10584 2 -15602 23325 10607 2 -15566 23392 10512 2 -15506 23427 10523 2 -15394 23477 10576 2 1236 -19143 -23066 0 1240 -19065 -23130 2 1178 -18965 -23215 2 1044 -18914 -23264 2 892 -18939 -23249 2 841 -18930 -23258 2 835 -18796 -23367 2 737 -18720 -23431 2 685 -18614 -23517 2 675 -18495 -23611 2 628 -18364 -23715 2 760 -18290 -23768 2 901 -18329 -23733 2 997 -18415 -23662 2 1150 -18467 -23614 2 1280 -18439 -23630 2 1420 -18389 -23661 2 1604 -18317 -23705 2 1660 -18239 -23761 2 1709 -18118 -23850 2 1758 -17994 -23940 2 1864 -17898 -24004 2 1890 -17974 -23945 2 1862 -18119 -23838 2 1973 -18067 -23869 2 2158 -17999 -23903 2 2192 -17910 -23967 2 2198 -17801 -24048 2 2258 -17688 -24126 2 2344 -17560 -24211 2 2331 -17465 -24281 2 2432 -17346 -24356 2 2533 -17287 -24387 2 2657 -17220 -24422 2 2813 -17176 -24435 2 2933 -17125 -24456 2 3039 -16997 -24533 2 3056 -17057 -24489 2 2959 -17158 -24431 2 2922 -17279 -24350 2 2796 -17369 -24300 2 2774 -17474 -24227 2 2676 -17581 -24161 2 2515 -17738 -24063 2 2561 -17637 -24133 2 2542 -17657 -24120 2 2392 -17723 -24087 2 2371 -17837 -24004 2 2389 -17903 -23953 2 2310 -18026 -23869 2 2183 -18052 -23861 2 2200 -18114 -23813 2 2182 -18209 -23742 2 2119 -18360 -23631 2 2125 -18475 -23541 2 2158 -18549 -23480 2 2191 -18681 -23371 2 2209 -18798 -23276 2 2315 -18869 -23208 2 2449 -18917 -23155 2 2517 -19007 -23074 2 2422 -19096 -23010 2 2282 -19142 -22986 2 2157 -19215 -22938 2 2010 -19262 -22911 2 1899 -19365 -22834 2 1903 -19445 -22765 2 1933 -19562 -22663 2 2002 -19666 -22567 2 2080 -19761 -22476 2 2015 -19813 -22436 2 1875 -19888 -22382 2 1750 -19879 -22400 2 1633 -19810 -22470 2 1546 -19722 -22553 2 1482 -19623 -22644 2 1411 -19521 -22737 2 1328 -19422 -22826 2 1254 -19329 -22909 2 1201 -19185 -23032 2 24076 9507 -15164 0 24148 9432 -15096 2 24231 9437 -14960 2 24279 9500 -14843 2 24329 9569 -14716 2 24408 9567 -14585 2 24493 9498 -14487 2 24560 9349 -14470 2 24620 9207 -14460 2 24672 9068 -14458 2 24699 8924 -14502 2 24739 8777 -14525 2 24803 8633 -14501 2 24838 8498 -14521 2 24863 8349 -14564 2 24922 8305 -14488 2 24967 8413 -14348 2 25028 8279 -14320 2 25028 8159 -14388 2 25056 8016 -14421 2 25068 7879 -14476 2 25088 7728 -14521 2 25065 7650 -14603 2 25039 7507 -14721 2 24971 7646 -14765 2 24904 7611 -14895 2 24928 7489 -14916 2 25018 7378 -14821 2 25053 7247 -14826 2 25030 7189 -14893 2 24984 7110 -15009 2 24909 7071 -15151 2 24840 7164 -15220 2 24753 7215 -15337 2 24694 7143 -15466 2 24653 7047 -15574 2 24606 6901 -15713 2 24572 7013 -15717 2 24568 7181 -15648 2 24510 7159 -15749 2 24483 7052 -15839 2 24429 6959 -15962 2 24420 6828 -16033 2 24389 6745 -16115 2 24296 6691 -16277 2 24295 6559 -16332 2 24240 6564 -16412 2 24200 6739 -16400 2 24268 6799 -16274 2 24268 6900 -16231 2 24296 7043 -16128 2 24211 7121 -16221 2 24224 7194 -16169 2 24299 7248 -16032 2 24364 7200 -15954 2 24399 7293 -15858 2 24444 7404 -15738 2 24515 7416 -15622 2 24598 7325 -15534 2 24652 7232 -15491 2 24720 7294 -15354 2 24728 7416 -15281 2 24712 7574 -15230 2 24693 7687 -15205 2 24696 7821 -15131 2 24685 7951 -15081 2 24608 8096 -15129 2 24570 8231 -15118 2 24442 8342 -15264 2 24407 8347 -15318 2 24347 8469 -15346 2 24275 8610 -15381 2 24211 8744 -15406 2 24185 8879 -15370 2 24208 8977 -15278 2 24197 9122 -15209 2 24151 9268 -15193 2 24084 9400 -15218 2 2308 -19901 -22330 0 2300 -19787 -22432 2 2337 -19723 -22484 2 2425 -19727 -22472 2 2440 -19678 -22512 2 2583 -19746 -22437 2 2712 -19766 -22404 2 2770 -19636 -22512 2 2887 -19557 -22565 2 2900 -19505 -22609 2 3059 -19593 -22512 2 3107 -19688 -22422 2 3101 -19806 -22318 2 3159 -19910 -22217 2 3274 -19983 -22135 2 3330 -20069 -22048 2 3358 -20178 -21945 2 3314 -20227 -21906 2 3266 -20212 -21927 2 3403 -20291 -21833 2 3426 -20397 -21731 2 3490 -20418 -21700 2 3618 -20482 -21619 2 3700 -20544 -21547 2 3825 -20639 -21434 2 3936 -20703 -21351 2 4050 -20746 -21289 2 4104 -20811 -21214 2 4284 -20844 -21146 2 4388 -20914 -21055 2 4463 -20986 -20968 2 4515 -21081 -20862 2 4604 -21159 -20763 2 4696 -21228 -20672 2 4701 -21312 -20584 2 4729 -21354 -20534 2 4777 -21395 -20480 2 4781 -21483 -20387 2 4824 -21561 -20294 2 4755 -21611 -20258 2 4604 -21673 -20226 2 4453 -21660 -20273 2 4311 -21715 -20245 2 4183 -21755 -20230 2 4102 -21791 -20208 2 3936 -21811 -20218 2 3797 -21806 -20250 2 3675 -21758 -20325 2 3585 -21677 -20427 2 3510 -21596 -20525 2 3389 -21521 -20624 2 3370 -21428 -20724 2 3334 -21327 -20833 2 3308 -21211 -20956 2 3403 -21160 -20992 2 3261 -21109 -21066 2 3255 -21003 -21172 2 3319 -20927 -21238 2 3311 -20917 -21249 2 3194 -20891 -21292 2 3064 -20851 -21350 2 2978 -20778 -21433 2 3108 -20688 -21502 2 3221 -20608 -21562 2 3292 -20556 -21601 2 3109 -20680 -21510 2 2979 -20749 -21462 2 2857 -20764 -21464 2 2768 -20778 -21462 2 2637 -20756 -21500 2 2738 -20679 -21561 2 2885 -20642 -21578 2 2960 -20614 -21594 2 2812 -20585 -21641 2 2859 -20558 -21661 2 2731 -20529 -21705 2 2611 -20465 -21780 2 2536 -20379 -21869 2 2477 -20274 -21974 2 2395 -20192 -22058 2 2345 -20108 -22139 2 2252 -19994 -22253 2 2301 -19944 -22292 2 27917 -4121 -10180 0 27862 -4187 -10305 2 27806 -4247 -10431 2 27749 -4284 -10565 2 27693 -4307 -10703 2 27636 -4325 -10842 2 27579 -4341 -10980 2 27527 -4331 -11114 2 27465 -4352 -11256 2 27404 -4390 -11390 2 27349 -4377 -11527 2 27301 -4326 -11660 2 27239 -4364 -11790 2 27175 -4425 -11913 2 27113 -4477 -12034 2 27050 -4501 -12168 2 27000 -4496 -12280 2 27041 -4288 -12264 2 27049 -4137 -12298 2 27095 -4038 -12229 2 27159 -3999 -12099 2 27217 -4027 -11960 2 27275 -4040 -11821 2 27330 -4034 -11696 2 27392 -3974 -11570 2 27427 -3868 -11524 2 27464 -3746 -11475 2 27506 -3616 -11416 2 27568 -3602 -11272 2 27625 -3566 -11143 2 27683 -3520 -11011 2 27736 -3489 -10887 2 27792 -3472 -10750 2 27841 -3363 -10658 2 27883 -3418 -10530 2 27888 -3560 -10469 2 27921 -3629 -10355 2 27973 -3608 -10222 2 28027 -3598 -10076 2 28080 -3577 -9937 2 28129 -3583 -9793 2 28178 -3561 -9659 2 28230 -3525 -9520 2 28267 -3390 -9459 2 28317 -3294 -9344 2 28363 -3283 -9207 2 28408 -3251 -9077 2 28457 -3187 -8948 2 28501 -3117 -8831 2 28533 -3148 -8714 2 28573 -3163 -8578 2 28617 -3139 -8438 2 28662 -3110 -8294 2 28689 -3158 -8184 2 28688 -3299 -8133 2 28697 -3409 -8053 2 28716 -3518 -7938 2 28725 -3563 -7885 2 28673 -3579 -8066 2 28632 -3576 -8212 2 28584 -3639 -8349 2 28548 -3707 -8442 2 28531 -3847 -8438 2 28482 -3878 -8588 2 28436 -3890 -8734 2 28387 -3914 -8879 2 28339 -3966 -9009 2 28290 -4026 -9137 2 28239 -4061 -9277 2 28193 -4052 -9419 2 28152 -4004 -9561 2 28104 -4022 -9694 2 28052 -4031 -9842 2 28000 -4062 -9974 2 27958 -4088 -10082 2 11139 23963 -14202 0 11228 23868 -14291 2 11324 23782 -14358 2 11412 23695 -14432 2 11474 23602 -14535 2 11501 23527 -14637 2 11499 23436 -14783 2 11540 23343 -14898 2 11643 23251 -14962 2 11725 23154 -15046 2 11774 23059 -15154 2 11846 22962 -15245 2 11917 22865 -15335 2 12003 22768 -15413 2 12088 22670 -15490 2 12190 22573 -15552 2 12236 22479 -15652 2 12257 22386 -15768 2 12322 22284 -15862 2 12428 22187 -15915 2 12510 22084 -15994 2 12556 21984 -16096 2 12650 21883 -16159 2 12749 21781 -16219 2 12799 21678 -16317 2 12787 21598 -16432 2 12634 21734 -16372 2 12497 21821 -16360 2 12396 21794 -16474 2 12337 21751 -16574 2 12342 21669 -16677 2 12236 21830 -16545 2 12294 21866 -16453 2 12278 21975 -16321 2 12263 22068 -16206 2 12281 22140 -16093 2 12244 22241 -15981 2 12164 22340 -15905 2 12061 22438 -15845 2 11959 22533 -15787 2 11861 22629 -15724 2 11753 22715 -15681 2 11630 22755 -15714 2 11510 22727 -15843 2 11464 22661 -15971 2 11442 22582 -16097 2 11431 22565 -16129 2 11441 22668 -15977 2 11418 22762 -15860 2 11377 22858 -15750 2 11345 22952 -15637 2 11324 23042 -15518 2 11296 23133 -15403 2 11247 23228 -15296 2 11203 23321 -15186 2 11164 23411 -15076 2 11136 23503 -14953 2 11094 23597 -14837 2 11047 23683 -14734 2 10970 23771 -14650 2 10909 23814 -14625 2 10787 23958 -14480 2 10737 24054 -14356 2 10712 24134 -14241 2 10678 24210 -14136 2 10591 24307 -14035 2 10623 24366 -13909 2 10703 24328 -13913 2 10721 24235 -14062 2 10787 24164 -14133 2 10930 24095 -14141 2 11052 24077 -14077 2 11107 24019 -14132 2 24092 5088 -17137 0 24106 4990 -17147 2 24101 4845 -17195 2 24134 4705 -17188 2 24227 4665 -17067 2 24323 4656 -16933 2 24372 4485 -16908 2 24429 4448 -16836 2 24501 4435 -16734 2 24557 4298 -16687 2 24680 4208 -16529 2 24659 4278 -16541 2 24654 4432 -16509 2 24708 4508 -16406 2 24771 4497 -16315 2 24859 4427 -16199 2 24913 4293 -16152 2 24996 4237 -16040 2 25078 4200 -15921 2 25152 4113 -15826 2 25188 3971 -15805 2 25229 3828 -15775 2 25271 3687 -15742 2 25214 3638 -15843 2 25160 3783 -15896 2 25106 3922 -15947 2 25048 4038 -16010 2 24992 3958 -16117 2 24917 3960 -16231 2 24843 3910 -16357 2 24783 4056 -16412 2 24705 4039 -16533 2 24640 3967 -16648 2 24610 3837 -16722 2 24668 3705 -16666 2 24696 3561 -16656 2 24695 3413 -16688 2 24674 3281 -16746 2 24614 3195 -16851 2 24544 3124 -16966 2 24466 3072 -17087 2 24395 3144 -17175 2 24370 3104 -17218 2 24373 2969 -17237 2 24318 2958 -17317 2 24256 3084 -17383 2 24226 3227 -17398 2 24244 3372 -17345 2 24285 3483 -17265 2 24242 3638 -17295 2 24153 3782 -17387 2 24105 3675 -17477 2 24080 3540 -17539 2 24074 3353 -17584 2 24046 3400 -17613 2 24020 3572 -17615 2 23959 3663 -17679 2 23898 3795 -17734 2 23881 3941 -17725 2 23906 4069 -17662 2 23896 4232 -17637 2 23900 4361 -17601 2 23930 4479 -17530 2 23889 4622 -17549 2 23904 4793 -17483 2 23955 4892 -17385 2 23998 4977 -17300 2 24054 5068 -17196 2 -3077 27485 11624 0 -3212 27455 11659 2 -3277 27494 11548 2 -3382 27504 11494 2 -3481 27440 11615 2 -3635 27419 11617 2 -3755 27420 11579 2 -3821 27363 11689 2 -3841 27363 11685 2 -3874 27416 11549 2 -3954 27435 11476 2 -4093 27375 11569 2 -4195 27407 11458 2 -4276 27352 11558 2 -4367 27316 11610 2 -4494 27264 11682 2 -4529 27272 11650 2 -4536 27330 11510 2 -4469 27386 11402 2 -4494 27431 11285 2 -4557 27480 11141 2 -4671 27496 11053 2 -4650 27472 11120 2 -4695 27410 11253 2 -4795 27428 11168 2 -4887 27398 11202 2 -4912 27358 11287 2 -4960 27341 11307 2 -5071 27316 11320 2 -5089 27291 11372 2 -4958 27294 11422 2 -4807 27314 11439 2 -4691 27296 11528 2 -4783 27244 11613 2 -4724 27217 11700 2 -4794 27198 11717 2 -4935 27190 11677 2 -5119 27162 11663 2 -5072 27145 11723 2 -4913 27142 11798 2 -4880 27105 11895 2 -4790 27096 11953 2 -4797 27064 12023 2 -4862 27007 12123 2 -5035 26956 12167 2 -4956 26929 12259 2 -4791 26938 12303 2 -4665 26910 12413 2 -4621 26870 12517 2 -4505 26851 12598 2 -4375 26828 12693 2 -4205 26843 12720 2 -4095 26879 12679 2 -3994 26908 12648 2 -3842 26927 12656 2 -3696 26961 12628 2 -3558 27004 12574 2 -3414 27034 12550 2 -3254 27071 12514 2 -3177 27122 12423 2 -3062 27168 12350 2 -3024 27196 12298 2 -2987 27233 12225 2 -2968 27273 12140 2 -3040 27319 12019 2 -3110 27358 11910 2 -3130 27418 11766 2 -3093 27467 11662 2 -26874 10130 8671 0 -26904 10149 8554 2 -26927 10215 8403 2 -26969 10221 8259 2 -27020 10197 8121 2 -27063 10109 8085 2 -27032 10061 8248 2 -27021 9976 8388 2 -27066 9846 8395 2 -27091 9728 8453 2 -27087 9628 8578 2 -27119 9545 8571 2 -27181 9496 8428 2 -27224 9502 8279 2 -27261 9521 8134 2 -27295 9541 7998 2 -27330 9566 7846 2 -27362 9593 7699 2 -27417 9490 7632 2 -27415 9412 7737 2 -27397 9324 7903 2 -27343 9381 8023 2 -27299 9390 8161 2 -27265 9362 8303 2 -27225 9351 8448 2 -27175 9374 8580 2 -27124 9382 8734 2 -27096 9334 8872 2 -27099 9220 8979 2 -27105 9125 9058 2 -27071 9141 9143 2 -27008 9257 9212 2 -26944 9392 9265 2 -26876 9459 9393 2 -26858 9399 9502 2 -26805 9396 9654 2 -26736 9483 9760 2 -26682 9486 9904 2 -26629 9485 10046 2 -26581 9471 10187 2 -26554 9406 10315 2 -26506 9435 10411 2 -26436 9556 10479 2 -26434 9669 10381 2 -26451 9755 10257 2 -26497 9774 10118 2 -26549 9826 9929 2 -26491 9886 10026 2 -26495 9928 9971 2 -26552 9921 9825 2 -26552 10020 9728 2 -26559 10089 9633 2 -26600 10117 9491 2 -26635 10156 9351 2 -26663 10213 9209 2 -26718 10186 9077 2 -26765 10205 8917 2 -26832 10122 8810 2 12962 21402 -16551 0 13045 21364 -16535 2 13138 21270 -16582 2 13162 21167 -16695 2 13218 21060 -16786 2 13310 20955 -16844 2 13385 20847 -16920 2 13504 20757 -16935 2 13578 20653 -17002 2 13654 20551 -17066 2 13768 20532 -16997 2 13891 20566 -16855 2 13965 20465 -16917 2 14088 20376 -16922 2 14226 20308 -16888 2 14319 20188 -16953 2 14303 20098 -17073 2 14348 19996 -17155 2 14426 19875 -17230 2 14320 19895 -17296 2 14190 19980 -17304 2 14079 19975 -17400 2 14044 20033 -17362 2 14095 20106 -17236 2 14169 20156 -17116 2 14117 20254 -17043 2 14003 20286 -17100 2 13944 20219 -17227 2 13788 20285 -17274 2 13664 20303 -17351 2 13592 20247 -17474 2 13528 20184 -17596 2 13450 20131 -17715 2 13342 20088 -17845 2 13229 20207 -17795 2 13112 20304 -17771 2 12985 20385 -17772 2 12850 20445 -17801 2 12720 20439 -17901 2 12584 20470 -17962 2 12362 20560 -18013 2 12415 20587 -17946 2 12403 20698 -17826 2 12362 20799 -17737 2 12240 20915 -17685 2 12290 20911 -17655 2 12423 20832 -17655 2 12548 20816 -17585 2 12621 20870 -17469 2 12728 20899 -17356 2 12791 20961 -17234 2 12844 21030 -17110 2 12883 21107 -16985 2 12900 21195 -16863 2 12919 21281 -16741 2 12947 21361 -16616 2 -6596 29135 -2761 0 -6532 29140 -2866 2 -6389 29166 -2915 2 -6434 29143 -3052 2 -6441 29132 -3132 2 -6493 29108 -3252 2 -6610 29094 -3143 2 -6614 29087 -3191 2 -6602 29071 -3358 2 -6714 29059 -3241 2 -6734 29042 -3348 2 -6719 29029 -3490 2 -6834 29000 -3506 2 -6936 28990 -3386 2 -7006 28986 -3276 2 -6942 29021 -3098 2 -7039 28997 -3100 2 -7085 29001 -2957 2 -7136 29004 -2805 2 -7194 28988 -2820 2 -7183 28977 -2959 2 -7189 28960 -3104 2 -7230 28934 -3253 2 -7376 28901 -3216 2 -7444 28898 -3084 2 -7442 28914 -2933 2 -7391 28942 -2783 2 -7370 28959 -2655 2 -7358 28976 -2498 2 -7401 28976 -2368 2 -7446 28976 -2224 2 -7382 29001 -2108 2 -7252 29039 -2031 2 -7124 29075 -1967 2 -6983 29108 -1992 2 -7031 29087 -2128 2 -6975 29094 -2215 2 -6830 29126 -2247 2 -6674 29163 -2227 2 -6519 29200 -2206 2 -6514 29193 -2310 2 -6610 29162 -2421 2 -6741 29133 -2416 2 -6877 29098 -2456 2 -7041 29061 -2424 2 -7056 29048 -2533 2 -6984 29052 -2679 2 -6827 29085 -2726 2 -6699 29114 -2738 2 -2179 24668 16933 0 -2273 24621 16989 2 -2387 24623 16970 2 -2508 24560 17044 2 -2579 24503 17116 2 -2524 24452 17197 2 -2598 24373 17297 2 -2672 24349 17320 2 -2812 24350 17297 2 -3027 24335 17281 2 -3012 24255 17396 2 -2987 24205 17470 2 -3118 24123 17560 2 -3049 24073 17641 2 -2873 24025 17735 2 -2950 23948 17827 2 -3066 23851 17937 2 -2988 23838 17967 2 -2838 23862 17960 2 -2845 23843 17984 2 -3000 23822 17987 2 -3117 23762 18045 2 -3231 23694 18115 2 -3298 23598 18228 2 -3162 23583 18272 2 -3218 23542 18314 2 -3117 23539 18336 2 -3141 23501 18380 2 -3101 23479 18415 2 -2961 23488 18427 2 -2805 23518 18413 2 -2675 23579 18354 2 -2541 23609 18335 2 -2417 23663 18282 2 -2248 23696 18260 2 -2100 23712 18257 2 -2013 23779 18180 2 -1953 23870 18067 2 -1899 23957 17957 2 -1911 24057 17822 2 -1907 24136 17715 2 -1941 24223 17592 2 -1891 24282 17515 2 -1761 24336 17454 2 -1695 24405 17364 2 -1733 24488 17244 2 -1773 24558 17140 2 -1839 24628 17032 2 -2071 24619 17018 2 -2127 24667 16942 2 -8496 -28645 2696 0 -8490 -28638 2793 2 -8441 -28638 2937 2 -8417 -28630 3083 2 -8449 -28605 3218 2 -8520 -28569 3353 2 -8635 -28524 3439 2 -8758 -28477 3517 2 -8896 -28429 3558 2 -9031 -28380 3604 2 -9169 -28331 3640 2 -9312 -28282 3666 2 -9457 -28235 3650 2 -9599 -28187 3654 2 -9740 -28136 3672 2 -9884 -28085 3677 2 -10018 -28042 3643 2 -10172 -27984 3665 2 -10237 -27975 3555 2 -10227 -27997 3406 2 -10160 -28037 3274 2 -10020 -28088 3269 2 -9887 -28135 3271 2 -9756 -28187 3212 2 -9609 -28239 3195 2 -9547 -28277 3049 2 -9433 -28312 3075 2 -9339 -28330 3190 2 -9195 -28379 3179 2 -9209 -28392 3012 2 -9271 -28386 2878 2 -9175 -28419 2856 2 -9176 -28428 2765 2 -9133 -28449 2691 2 -9136 -28457 2596 2 -9120 -28472 2479 2 -9093 -28490 2375 2 -8964 -28531 2374 2 -8860 -28554 2484 2 -8919 -28525 2601 2 -8914 -28518 2693 2 -8963 -28490 2823 2 -8910 -28500 2892 2 -8788 -28530 2968 2 -8726 -28556 2899 2 -8644 -28572 2989 2 -8590 -28589 2982 2 -8623 -28594 2837 2 -8688 -28588 2687 2 -8578 -28625 2652 2 -16082 -24523 6323 0 -16020 -24529 6458 2 -15949 -24539 6591 2 -15879 -24549 6725 2 -15781 -24578 6846 2 -15746 -24559 6995 2 -15696 -24552 7130 2 -15714 -24505 7250 2 -15786 -24468 7218 2 -15856 -24461 7089 2 -15964 -24420 6989 2 -16084 -24361 6918 2 -16198 -24309 6833 2 -16317 -24250 6758 2 -16436 -24184 6710 2 -16562 -24108 6673 2 -16720 -24010 6631 2 -16810 -23934 6679 2 -16935 -23857 6638 2 -16995 -23841 6542 2 -17074 -23814 6431 2 -17068 -23846 6331 2 -17058 -23899 6154 2 -16992 -23968 6068 2 -16886 -24059 6002 2 -16809 -24090 6094 2 -16753 -24084 6267 2 -16691 -24155 6162 2 -16665 -24207 6025 2 -16541 -24294 6015 2 -16437 -24341 6110 2 -16331 -24386 6217 2 -16268 -24440 6170 2 -16301 -24423 6149 2 -16379 -24396 6047 2 -16449 -24375 5943 2 -16569 -24331 5786 2 -16442 -24403 5846 2 -16467 -24408 5750 2 -16531 -24405 5577 2 -16546 -24426 5439 2 -16485 -24462 5462 2 -16452 -24459 5578 2 -16362 -24490 5704 2 -16284 -24512 5831 2 -16246 -24504 5968 2 -16148 -24541 6080 2 -16100 -24536 6225 2 -13245 26217 -6103 0 -13278 26234 -5958 3 -13269 26268 -5824 3 -13181 26333 -5732 3 -13204 26349 -5600 3 -13216 26373 -5459 3 -13160 26428 -5325 3 -13089 26490 -5191 3 -13022 26543 -5092 3 -13002 26580 -4946 3 -13029 26590 -4816 3 -12998 26613 -4772 3 -12968 26615 -4843 3 -12923 26660 -4715 3 -12880 26658 -4844 3 -12873 26631 -5009 3 -12881 26616 -5070 3 -12834 26677 -4861 3 -12862 26687 -4730 3 -12943 26671 -4596 3 -12977 26668 -4516 3 -12830 26714 -4664 3 -12780 26712 -4809 3 -12787 26681 -4959 3 -12854 26627 -5078 3 -12930 26568 -5192 3 -12974 26519 -5332 3 -12954 26498 -5483 3 -12897 26498 -5614 3 -12775 26544 -5679 3 -12662 26580 -5760 3 -12545 26612 -5868 3 -12420 26650 -5958 3 -12410 26642 -6017 3 -12554 26589 -5952 3 -12687 26528 -5942 3 -12841 26459 -5918 3 -12843 26428 -6051 3 -12854 26395 -6172 3 -12936 26328 -6283 3 -12951 26300 -6371 3 -12881 26303 -6497 3 -12842 26291 -6624 3 -12822 26291 -6663 3 -12957 26248 -6568 3 -13055 26225 -6468 3 -13158 26200 -6358 3 -13215 26202 -6233 3 -6930 29187 -252 0 -6981 29174 -385 2 -6897 29194 -393 2 -6780 29220 -475 2 -6715 29233 -607 2 -6717 29228 -764 2 -6833 29201 -787 2 -6967 29171 -709 2 -7079 29146 -620 2 -7090 29147 -447 2 -7160 29131 -349 2 -7296 29098 -297 2 -7442 29061 -275 2 -7581 29025 -321 2 -7715 28990 -293 2 -7876 28946 -259 2 -7903 28940 -142 2 -7982 28919 -8 2 -7892 28943 160 2 -8007 28911 253 2 -8005 28909 411 2 -7983 28914 519 2 -7949 28920 649 2 -7959 28915 741 2 -7850 28941 907 2 -7923 28917 1015 2 -7934 28909 1153 2 -7867 28921 1307 2 -7703 28962 1362 2 -7612 28988 1329 2 -7466 29023 1375 2 -7381 29050 1276 2 -7315 29072 1134 2 -7283 29086 991 2 -7322 29081 835 2 -7386 29068 704 2 -7477 29048 572 2 -7538 29033 481 2 -7485 29049 337 2 -7489 29050 183 2 -7453 29059 76 2 -7321 29093 39 2 -7289 29101 -79 2 -7207 29121 -120 2 -7152 29135 3 2 -7019 29167 -105 2 -6918 29191 -165 2 1042 29488 5419 0 1140 29468 5506 2 1192 29440 5642 2 1240 29410 5787 2 1330 29392 5861 2 1449 29370 5941 2 1505 29391 5825 2 1515 29417 5689 2 1561 29418 5669 2 1638 29401 5734 2 1696 29405 5697 2 1714 29381 5814 2 1587 29360 5958 2 1503 29344 6054 2 1569 29319 6161 2 1714 29328 6079 2 1801 29324 6069 2 1701 29302 6206 2 1758 29290 6247 2 1601 29287 6301 2 1676 29253 6436 2 1822 29235 6480 2 1876 29219 6538 2 1996 29192 6620 2 1999 29236 6423 2 1984 29270 6272 2 2016 29296 6140 2 1993 29330 5982 2 1999 29357 5847 2 1977 29389 5688 2 2039 29411 5555 2 2108 29427 5441 2 1938 29456 5349 2 1814 29474 5288 2 1690 29500 5185 2 1612 29529 5044 2 1478 29539 5024 2 1455 29516 5165 2 1513 29489 5300 2 1581 29462 5432 2 1572 29455 5470 2 1476 29486 5328 2 1402 29513 5199 2 1326 29514 5210 2 1274 29500 5304 2 1200 29527 5167 2 1094 29520 5230 2 1031 29506 5324 2 14587 -2200 26122 0 14605 -2253 26108 3 14566 -2389 26117 3 14538 -2545 26118 3 14545 -2696 26099 3 14597 -2834 26056 3 14631 -2970 26021 3 14566 -3107 26042 3 14594 -3236 26011 3 14646 -3379 25963 3 14686 -3514 25923 3 14761 -3633 25863 3 14859 -3716 25795 3 14945 -3817 25731 3 14964 -3963 25698 3 15001 -4103 25654 3 15084 -4216 25587 3 15080 -4412 25556 3 15180 -4472 25487 3 15298 -4562 25400 3 15352 -4471 25383 3 15308 -4343 25433 3 15261 -4217 25482 3 15208 -4079 25536 3 15151 -3945 25591 3 15136 -3795 25622 3 15126 -3660 25648 3 15063 -3515 25705 3 14978 -3401 25770 3 14860 -3363 25843 3 14792 -3232 25899 3 14861 -3110 25874 3 14879 -2978 25880 3 14831 -2839 25923 3 14849 -2689 25928 3 14782 -2559 25980 3 14785 -2412 25992 3 14776 -2269 26010 3 14722 -2131 26053 3 14675 -1991 26090 3 14644 -1799 26121 3 14581 -1884 26150 3 14560 -2031 26151 3 14545 -2184 26147 3 15944 24781 -5628 0 16037 24729 -5595 3 16161 24642 -5620 3 16287 24563 -5601 3 16414 24482 -5586 3 16541 24404 -5555 3 16667 24323 -5533 3 16793 24242 -5507 3 16908 24180 -5427 3 17029 24106 -5376 3 17140 24046 -5293 3 17262 23972 -5229 3 17380 23894 -5197 3 17487 23834 -5116 3 17588 23780 -5017 3 17707 23703 -4964 3 17816 23637 -4887 3 17900 23598 -4766 3 17967 23572 -4639 3 18040 23550 -4468 3 18092 23498 -4531 3 18088 23472 -4679 3 18035 23486 -4814 3 17961 23515 -4943 3 17880 23551 -5069 3 17767 23620 -5141 3 17646 23708 -5152 3 17559 23753 -5239 3 17482 23789 -5333 3 17380 23842 -5431 3 17296 23875 -5553 3 17187 23933 -5640 3 17071 24006 -5681 3 16964 24058 -5782 3 16880 24126 -5742 3 16788 24189 -5748 3 16762 24187 -5834 3 16632 24269 -5863 3 16515 24352 -5852 3 16396 24441 -5815 3 16272 24523 -5816 3 16149 24608 -5800 3 16024 24694 -5780 3 15902 24789 -5715 3 6601 28935 4379 0 6617 28914 4497 2 6691 28878 4612 2 6745 28857 4665 2 6750 28831 4815 2 6827 28795 4925 2 6904 28787 4861 2 6967 28752 4981 2 7104 28744 4828 2 7203 28735 4734 2 7136 28769 4629 2 7058 28801 4550 2 7059 28818 4438 2 6964 28853 4361 2 6936 28879 4230 2 6843 28914 4143 2 6830 28937 4003 2 6777 28968 3861 2 6727 28992 3766 2 6688 29020 3618 2 6667 29045 3457 2 6660 29065 3300 2 6666 29080 3151 2 6656 29098 3001 2 6644 29116 2853 2 6613 29137 2702 2 6560 29159 2587 2 6445 29194 2489 2 6302 29224 2499 2 6240 29226 2630 2 6280 29203 2780 2 6357 29176 2892 2 6371 29156 3054 2 6357 29142 3214 2 6306 29140 3330 2 6271 29132 3466 2 6291 29114 3576 2 6285 29093 3752 2 6314 29066 3909 2 6373 29034 4051 2 6388 29013 4178 2 6433 28985 4302 2 6559 28946 4371 2 6639 28936 4317 2 -10564 27211 -6925 0 -10666 27196 -6827 3 -10758 27193 -6696 3 -10692 27249 -6570 3 -10648 27297 -6442 3 -10705 27306 -6306 3 -10809 27243 -6401 3 -10863 27177 -6587 3 -10903 27179 -6512 3 -10894 27220 -6357 3 -10859 27271 -6197 3 -10726 27333 -6153 3 -10727 27362 -6021 3 -10858 27350 -5837 3 -10767 27409 -5728 3 -10704 27454 -5628 3 -10580 27517 -5555 3 -10556 27505 -5662 3 -10559 27476 -5795 3 -10474 27476 -5946 3 -10363 27496 -6047 3 -10301 27539 -5956 3 -10296 27579 -5781 3 -10195 27612 -5798 3 -10134 27608 -5923 3 -10105 27586 -6073 3 -10101 27556 -6214 3 -10072 27529 -6379 3 -10028 27513 -6517 3 -9997 27491 -6656 3 -9971 27439 -6905 3 -10041 27436 -6814 3 -10144 27432 -6677 3 -10161 27452 -6570 3 -10229 27461 -6425 3 -10356 27432 -6342 3 -10419 27395 -6399 3 -10307 27403 -6545 3 -10366 27377 -6563 3 -10447 27326 -6647 3 -10485 27283 -6760 3 -10524 27237 -6884 3 15744 -1075 25514 0 15750 -1211 25505 3 15813 -1397 25456 3 15908 -1314 25401 3 16002 -1224 25346 3 16121 -1294 25267 3 16218 -1324 25204 3 16230 -1493 25187 3 16285 -1476 25152 3 16278 -1318 25165 3 16373 -1274 25106 3 16495 -1312 25024 3 16627 -1173 24943 3 16473 -1111 25048 3 16509 -1019 25029 3 16592 -908 24978 3 16674 -786 24927 3 16732 -679 24891 3 16802 -538 24847 3 16816 -409 24841 3 16842 -266 24825 3 16958 -234 24746 3 17091 -163 24655 3 17066 -71 24673 3 16930 -143 24766 3 16838 -82 24829 3 16773 18 24873 3 16699 117 24922 3 16593 126 24993 3 16501 189 25054 3 16395 135 25123 3 16295 69 25189 3 16178 80 25264 3 16055 17 25342 3 15939 -32 25415 3 15886 -130 25448 3 15827 -272 25484 3 15782 -417 25510 3 15817 -552 25485 3 15812 -719 25485 3 15775 -852 25504 3 15736 -1001 25522 3 10098 22921 16512 0 10171 22873 16534 3 10309 22814 16531 3 10448 22757 16522 3 10594 22697 16511 3 10736 22652 16481 3 10862 22640 16415 3 10996 22586 16399 3 11137 22535 16374 3 11275 22481 16354 3 11422 22444 16304 3 11516 22346 16372 3 11574 22247 16465 3 11602 22153 16573 3 11476 22145 16670 3 11359 22137 16761 3 11351 22060 16868 3 11336 21965 17001 3 11318 21886 17115 3 11170 21839 17271 3 11220 21849 17226 3 11341 21875 17114 3 11372 21935 17016 3 11397 22047 16853 3 11418 22096 16775 3 11526 22118 16671 3 11668 22092 16607 3 11680 22153 16517 3 11582 22253 16452 3 11523 22348 16364 3 11456 22467 16248 3 11411 22470 16275 3 11273 22494 16338 3 11126 22561 16346 3 11015 22608 16357 3 10857 22652 16401 3 10720 22701 16424 3 10556 22789 16409 3 10447 22795 16469 3 10302 22834 16507 3 10161 22882 16528 3 13989 -2192 -26448 0 14075 -2230 -26399 2 14234 -2219 -26315 2 14215 -2366 -26312 2 14190 -2534 -26310 2 14293 -2581 -26250 2 14403 -2650 -26183 2 14468 -2774 -26134 2 14552 -2864 -26078 2 14670 -2875 -26010 2 14793 -2891 -25938 2 14892 -2832 -25888 2 14886 -2685 -25908 2 14929 -2681 -25883 2 14962 -2831 -25848 2 15065 -2890 -25781 2 15190 -2916 -25705 2 15316 -2899 -25633 2 15444 -2879 -25557 2 15573 -2876 -25480 2 15669 -2915 -25416 2 15602 -3033 -25444 2 15473 -3081 -25517 2 15358 -3168 -25575 2 15264 -3187 -25629 2 15138 -3220 -25699 2 15030 -3290 -25754 2 14897 -3287 -25831 2 14771 -3284 -25904 2 14646 -3237 -25981 2 14537 -3172 -26050 2 14411 -3126 -26126 2 14307 -3036 -26193 2 14233 -2922 -26247 2 14097 -2908 -26321 2 13981 -2828 -26392 2 14028 -2672 -26383 2 13945 -2602 -26434 2 13861 -2493 -26489 2 13864 -2337 -26502 2 13936 -2234 -26473 2 119 4674 29633 0 88 4579 29648 3 62 4423 29672 3 80 4291 29691 3 18 4132 29714 3 -118 4236 29699 3 -182 4289 29691 3 -305 4319 29686 3 -393 4445 29666 3 -431 4516 29655 3 -570 4663 29630 3 -576 4579 29643 3 -774 4545 29644 3 -715 4545 29645 3 -575 4501 29655 3 -449 4433 29667 3 -373 4291 29689 3 -296 4220 29700 3 -177 4186 29706 3 -87 4067 29723 3 -255 3970 29735 3 -93 3962 29737 3 -34 3904 29745 3 51 3784 29760 3 43 3648 29777 3 -21 3534 29791 3 -154 3520 29792 3 -297 3549 29788 3 -292 3511 29792 3 -151 3445 29801 3 -7 3360 29811 3 46 3278 29820 3 58 3290 29819 3 123 3466 29799 3 128 3589 29784 3 146 3730 29767 3 143 3902 29745 3 128 4067 29723 3 88 4173 29708 3 110 4327 29686 3 72 4457 29667 3 109 4599 29645 3 16496 -5129 24527 0 16526 -5272 24476 3 16589 -5399 24406 3 16575 -5541 24384 3 16573 -5693 24350 3 16557 -5840 24326 3 16563 -5987 24286 3 16526 -6122 24278 3 16447 -6249 24299 3 16415 -6396 24282 3 16455 -6517 24223 3 16478 -6666 24167 3 16482 -6803 24126 3 16465 -6950 24096 3 16530 -7066 24017 3 16526 -7198 23981 3 16523 -7337 23940 3 16603 -7345 23883 3 16669 -7309 23848 3 16759 -7369 23766 3 16731 -7146 23854 3 16666 -7054 23926 3 16670 -6905 23967 3 16674 -6757 24007 3 16698 -6611 24030 3 16684 -6468 24079 3 16715 -6322 24097 3 16797 -6201 24071 3 16837 -6057 24080 3 16811 -5924 24131 3 16747 -5821 24200 3 16740 -5682 24238 3 16755 -5535 24262 3 16748 -5389 24300 3 16741 -5240 24337 3 16689 -5113 24399 3 16616 -5005 24472 3 16532 -4986 24532 3 18721 21147 10116 0 18680 21234 10009 3 18582 21296 10061 3 18439 21402 10097 3 18329 21477 10138 3 18232 21582 10089 3 18193 21673 9966 3 18147 21757 9864 3 18065 21853 9803 3 18030 21796 9992 3 17921 21835 10103 3 17880 21825 10197 3 17869 21761 10352 3 17957 21663 10404 3 17882 21667 10524 3 17980 21550 10597 3 17935 21559 10656 3 17853 21561 10788 3 17884 21478 10903 3 17947 21378 10994 3 18002 21279 11097 3 18062 21177 11194 3 18158 21069 11242 3 18250 20961 11295 3 18358 20861 11305 3 18470 20736 11352 3 18531 20767 11195 3 18581 20759 11126 3 18662 20746 11015 3 18769 20679 10959 3 18847 20636 10907 3 18882 20678 10764 3 18942 20690 10636 3 18949 20742 10522 3 18846 20833 10526 3 18804 20936 10396 3 18733 21040 10315 3 18719 21091 10236 3 -7108 28862 -4057 0 -6996 28883 -4101 2 -6855 28909 -4159 2 -6785 28907 -4286 2 -6726 28899 -4426 2 -6685 28884 -4588 2 -6817 28841 -4660 2 -6963 28802 -4688 2 -7056 28759 -4808 2 -7135 28718 -4935 2 -7236 28677 -5025 2 -7335 28631 -5143 2 -7407 28589 -5273 2 -7496 28542 -5399 2 -7600 28523 -5357 2 -7739 28494 -5311 2 -7879 28462 -5278 2 -8020 28417 -5305 2 -8149 28387 -5272 2 -8148 28416 -5110 2 -8158 28436 -4984 2 -8180 28456 -4833 2 -8073 28502 -4738 2 -7948 28555 -4628 2 -7935 28579 -4505 2 -7851 28621 -4383 2 -7804 28654 -4246 2 -7781 28682 -4099 2 -7760 28708 -3952 2 -7741 28733 -3805 2 -7694 28764 -3665 2 -7546 28802 -3673 2 -7401 28835 -3707 2 -7258 28866 -3752 2 -7168 28873 -3870 2 -7170 28853 -4009 2 -12612 27178 1511 0 -12540 27216 1425 2 -12489 27246 1288 2 -12460 27266 1148 2 -12374 27309 1050 2 -12249 27367 996 2 -12247 27372 899 2 -12376 27315 851 2 -12512 27253 844 2 -12654 27188 844 2 -12781 27129 828 2 -12917 27064 818 2 -13058 26996 845 2 -13159 26950 735 2 -13294 26885 668 2 -13301 26878 790 2 -13258 26895 951 2 -13331 26856 1021 2 -13469 26786 1036 2 -13499 26767 1149 2 -13407 26808 1265 2 -13282 26867 1333 2 -13180 26911 1444 2 -13045 26975 1477 2 -13024 26978 1591 2 -13102 26932 1729 2 -13183 26888 1807 2 -13206 26866 1956 2 -13216 26850 2102 2 -13099 26898 2216 2 -13018 26941 2173 2 -12962 26977 2059 2 -12996 26971 1910 2 -12948 26997 1879 2 -12807 27066 1847 2 -12707 27120 1747 2 -12665 27148 1613 2 29276 3899 5265 0 29298 3743 5253 2 29318 3595 5246 2 29343 3446 5206 2 29366 3305 5168 2 29393 3175 5097 2 29422 3113 4964 2 29445 3121 4821 2 29462 3180 4679 2 29478 3228 4541 2 29490 3306 4407 2 29495 3408 4295 2 29487 3545 4234 2 29473 3692 4205 2 29449 3860 4226 2 29424 3981 4285 2 29403 4086 4331 2 29368 4240 4420 2 29339 4391 4466 2 29315 4478 4539 2 29279 4633 4616 2 29252 4727 4687 2 29221 4852 4750 2 29185 4961 4861 2 29150 5061 4969 2 29141 5074 5006 2 29154 5033 4973 2 29133 5045 5084 2 29173 4951 4944 2 29152 4930 5083 2 29175 4780 5095 2 29184 4645 5170 2 29204 4491 5194 2 29217 4347 5239 2 29225 4241 5284 2 29253 4054 5276 2 29265 3973 5269 2 23365 142 -18817 0 23419 236 -18748 2 23490 320 -18658 2 23545 426 -18587 2 23456 523 -18696 2 23405 630 -18757 2 23410 786 -18744 2 23495 792 -18638 2 23578 684 -18536 2 23616 577 -18492 2 23679 455 -18415 2 23738 508 -18337 2 23667 627 -18425 2 23628 753 -18470 2 23640 902 -18449 2 23642 1081 -18436 2 23702 1046 -18361 2 23760 918 -18293 2 23786 778 -18266 2 23820 611 -18228 2 23787 484 -18274 2 23782 353 -18283 2 23764 210 -18310 2 23738 83 -18343 2 23743 -68 -18337 2 23701 -188 -18392 2 23646 -313 -18460 2 23548 -436 -18582 2 23566 -367 -18561 2 23617 -239 -18498 2 23652 -100 -18454 2 23672 46 -18429 2 23659 207 -18445 2 23568 218 -18560 2 23478 185 -18675 2 23388 137 -18788 2 12054 -19593 -19257 0 12112 -19628 -19184 2 12209 -19670 -19079 2 12337 -19705 -18961 2 12413 -19733 -18883 2 12532 -19744 -18791 2 12671 -19706 -18738 2 12809 -19646 -18707 2 12948 -19599 -18661 2 13098 -19570 -18586 2 13118 -19633 -18506 2 13063 -19738 -18433 2 12973 -19846 -18380 2 12871 -19951 -18338 2 12756 -20043 -18318 2 12612 -20189 -18258 2 12610 -20263 -18177 2 12520 -20359 -18132 2 12405 -20457 -18101 2 12269 -20549 -18089 2 12162 -20610 -18091 2 12041 -20657 -18119 2 11916 -20688 -18166 2 11872 -20631 -18260 2 11874 -20542 -18358 2 11862 -20438 -18483 2 11804 -20434 -18524 2 11674 -20490 -18544 2 11662 -20430 -18617 2 11718 -20324 -18699 2 11742 -20222 -18793 2 11720 -20119 -18917 2 11724 -20054 -18983 2 11779 -19942 -19067 2 11836 -19818 -19161 2 11887 -19712 -19240 2 11976 -19615 -19283 2 19917 21699 5700 0 19946 21645 5798 3 20020 21556 5878 3 20091 21467 5959 3 20208 21369 5916 3 20357 21252 5827 3 20292 21329 5772 3 20200 21431 5717 3 20134 21505 5669 3 20071 21584 5594 3 20056 21630 5466 3 19983 21729 5344 3 19976 21765 5218 3 19976 21785 5136 3 20031 21770 4983 3 20055 21778 4851 3 20114 21757 4697 3 20152 21751 4557 3 20209 21730 4405 3 20265 21704 4271 3 20289 21708 4140 3 20301 21727 3976 3 20203 21835 3885 3 20179 21835 4002 3 20192 21793 4162 3 20145 21808 4312 3 20113 21811 4447 3 20082 21801 4633 3 20042 21811 4753 3 19980 21843 4867 3 19921 21867 5000 3 19903 21848 5153 3 19843 21867 5301 3 19829 21844 5446 3 19880 21767 5567 3 -4651 29635 -334 0 -4703 29626 -408 2 -4850 29603 -374 2 -4892 29595 -451 2 -4991 29577 -532 2 -5114 29557 -447 2 -5147 29550 -563 2 -5258 29530 -583 2 -5348 29516 -458 2 -5398 29506 -477 2 -5512 29485 -510 2 -5520 29486 -356 2 -5546 29482 -203 2 -5602 29472 -109 2 -5621 29469 -106 2 -5638 29464 -260 2 -5695 29452 -386 2 -5831 29426 -359 2 -5953 29402 -262 2 -6088 29375 -238 2 -6157 29361 -103 2 -6058 29382 3 2 -6102 29373 84 2 -6073 29379 143 2 -5941 29405 175 2 -5749 29443 195 2 -5825 29428 220 2 -5757 29441 299 2 -5667 29457 379 2 -5491 29490 438 2 -5425 29504 315 2 -5310 29525 264 2 -5189 29547 229 2 -5057 29570 206 2 -5091 29565 132 2 -5019 29577 73 2 -4927 29593 -8 2 -4797 29614 -93 2 -4654 29637 -143 2 -4527 29656 -220 2 -4574 29648 -298 2 -17857 23953 -2714 0 -17926 23893 -2788 3 -18040 23816 -2717 3 -18149 23741 -2645 3 -18260 23662 -2589 3 -18308 23633 -2507 3 -18297 23651 -2416 3 -18389 23587 -2341 3 -18493 23509 -2311 3 -18527 23492 -2203 3 -18637 23403 -2226 3 -18751 23306 -2281 3 -18872 23207 -2306 3 -18959 23143 -2231 3 -18875 23222 -2120 3 -18727 23344 -2088 3 -18630 23421 -2085 3 -18522 23502 -2144 3 -18409 23586 -2188 3 -18290 23674 -2236 3 -18181 23757 -2250 3 -18054 23850 -2283 3 -17932 23938 -2323 3 -17817 24023 -2342 3 -17699 24105 -2388 3 -17579 24189 -2427 3 -17462 24271 -2446 3 -17351 24353 -2425 3 -17331 24363 -2466 3 -17452 24270 -2534 3 -17541 24207 -2517 3 -17500 24213 -2738 3 -17619 24117 -2815 3 -17730 24029 -2869 3 -17814 23978 -2776 3 -17835 23976 -2665 3 18868 16148 -16830 0 18750 16259 -16855 2 18707 16352 -16812 2 18718 16438 -16716 2 18731 16503 -16636 2 18683 16608 -16587 2 18797 16599 -16466 2 18815 16688 -16355 2 18832 16739 -16284 2 18942 16702 -16193 2 19048 16614 -16160 2 19167 16558 -16076 2 19271 16491 -16021 2 19330 16397 -16046 2 19344 16307 -16121 2 19375 16198 -16193 2 19257 16245 -16287 2 19168 16381 -16255 2 19169 16237 -16399 2 19211 16138 -16447 2 19317 16009 -16450 2 19426 15905 -16421 2 19476 15773 -16489 2 19546 15638 -16535 2 19542 15557 -16616 2 19471 15573 -16684 2 19414 15712 -16621 2 19368 15720 -16666 2 19410 15585 -16743 2 19438 15496 -16794 2 19287 15620 -16853 2 19178 15693 -16910 2 19101 15819 -16879 2 19024 15945 -16848 2 18945 16054 -16833 2 -21907 20246 3192 0 -21969 20189 3129 3 -22031 20141 2994 3 -22106 20075 2884 3 -22115 20089 2714 3 -22026 20188 2709 3 -21989 20204 2879 3 -21917 20284 2864 3 -21909 20306 2769 3 -22008 20207 2702 3 -22110 20105 2640 3 -22214 19997 2582 3 -22283 19896 2761 3 -22306 19861 2826 3 -22302 19847 2954 3 -22257 19875 3101 3 -22223 19890 3247 3 -22144 19959 3361 3 -22078 20010 3487 3 -22019 20051 3621 3 -21941 20108 3775 3 -21888 20147 3874 3 -21815 20203 3995 3 -21732 20270 4103 3 -21646 20343 4199 3 -21550 20438 4229 3 -21554 20445 4177 3 -21615 20409 4035 3 -21653 20397 3891 3 -21745 20327 3739 3 -21783 20294 3691 3 -21786 20318 3543 3 -21797 20331 3395 3 -21851 20296 3262 3 16309 24931 -3533 0 16333 24928 -3444 3 16435 24871 -3364 3 16503 24821 -3403 3 16622 24729 -3492 3 16625 24714 -3581 3 16738 24630 -3632 3 16722 24638 -3651 3 16604 24721 -3630 3 16539 24780 -3524 3 16432 24857 -3485 3 16350 24897 -3584 3 16314 24902 -3706 3 16409 24826 -3797 3 16515 24745 -3866 3 16623 24662 -3928 3 16744 24580 -3931 3 16861 24501 -3927 3 16981 24410 -3976 3 17095 24334 -3951 3 17238 24224 -4004 3 17283 24185 -4044 3 17434 24060 -4145 3 17329 24128 -4191 3 17267 24185 -4114 3 17175 24267 -4019 3 17061 24346 -4025 3 16965 24416 -4007 3 16862 24497 -3942 3 16741 24580 -3945 3 16619 24664 -3937 3 16506 24748 -3880 3 16404 24826 -3816 3 16274 24923 -3737 3 16261 24953 -3596 3 -15019 23246 -11578 0 -14910 23264 -11682 2 -14918 23205 -11790 2 -15047 23143 -11747 2 -15108 23141 -11673 2 -15227 23027 -11742 2 -15345 22995 -11652 2 -15459 22950 -11590 2 -15579 22896 -11536 2 -15655 22849 -11526 2 -15718 22782 -11574 2 -15828 22756 -11473 2 -15934 22687 -11463 2 -16056 22632 -11402 2 -16121 22648 -11278 2 -16125 22668 -11232 2 -16194 22556 -11357 2 -16349 22491 -11263 2 -16453 22454 -11186 2 -16570 22417 -11087 2 -16622 22438 -10965 2 -16528 22521 -10939 2 -16394 22618 -10940 2 -16279 22698 -10946 2 -16167 22748 -11007 2 -16038 22793 -11103 2 -15918 22872 -11112 2 -15792 22955 -11121 2 -15669 23040 -11120 2 -15552 23101 -11156 2 -15442 23127 -11256 2 -15334 23147 -11362 2 -15224 23172 -11457 2 -15107 23211 -11533 2 24179 -4896 -17070 0 24114 -4821 -17184 2 24036 -4779 -17304 2 23959 -4730 -17424 2 23883 -4680 -17542 2 23811 -4620 -17655 2 23736 -4562 -17771 2 23663 -4494 -17884 2 23643 -4379 -17939 2 23748 -4370 -17802 2 23832 -4412 -17680 2 23919 -4418 -17561 2 24004 -4436 -17439 2 24091 -4445 -17317 2 24173 -4473 -17195 2 24249 -4528 -17073 2 24287 -4649 -16986 2 24350 -4729 -16874 2 24417 -4790 -16759 2 24492 -4834 -16636 2 24556 -4907 -16520 2 24604 -5012 -16418 2 24610 -5154 -16365 2 24590 -5276 -16355 2 24581 -5392 -16330 2 24493 -5373 -16468 2 24428 -5307 -16587 2 24349 -5270 -16714 2 24299 -5169 -16818 2 24253 -5061 -16916 2 24228 -4963 -16981 2 13075 24485 11382 0 13035 24537 11315 3 13049 24595 11171 3 13066 24647 11037 3 13124 24679 10896 3 13188 24702 10765 3 13272 24705 10655 3 13301 24761 10487 3 13231 24789 10508 3 13259 24735 10600 3 13183 24714 10743 3 13098 24707 10863 3 13023 24692 10986 3 12911 24694 11114 3 12959 24634 11190 3 12980 24560 11329 3 13031 24478 11446 3 13037 24416 11572 3 13145 24322 11648 3 13281 24260 11623 3 13376 24180 11679 3 13508 24092 11710 3 13502 24057 11787 3 13521 24047 11786 3 13608 24092 11592 3 13518 24116 11649 3 13436 24190 11589 3 13381 24297 11429 3 13334 24277 11525 3 13241 24296 11592 3 13111 24370 11585 3 13117 24438 11433 3 -3768 -29624 2870 0 -3723 -29620 2964 2 -3672 -29612 3106 2 -3613 -29604 3244 2 -3556 -29596 3384 2 -3524 -29582 3531 2 -3572 -29561 3660 2 -3603 -29542 3778 2 -3694 -29513 3913 2 -3847 -29485 3976 2 -3926 -29459 4093 2 -4101 -29434 4104 2 -4116 -29411 4251 2 -4222 -29379 4364 2 -4371 -29355 4380 2 -4515 -29339 4337 2 -4614 -29340 4228 2 -4630 -29359 4078 2 -4605 -29383 3929 2 -4542 -29410 3795 2 -4452 -29439 3674 2 -4348 -29468 3568 2 -4233 -29496 3472 2 -4156 -29522 3344 2 -4101 -29546 3201 2 -4083 -29563 3055 2 -4058 -29581 2912 2 -3964 -29605 2794 2 -3829 -29623 2796 2 -8205 28819 -1455 0 -8254 28801 -1550 2 -8361 28766 -1624 2 -8487 28732 -1561 2 -8618 28693 -1569 2 -8730 28656 -1628 2 -8702 28657 -1749 2 -8567 28692 -1831 2 -8651 28660 -1947 2 -8790 28620 -1908 2 -8919 28585 -1836 2 -9006 28564 -1726 2 -9131 28529 -1655 2 -9261 28491 -1586 2 -9403 28446 -1547 2 -9493 28421 -1456 2 -9328 28481 -1356 2 -9367 28474 -1234 2 -9280 28508 -1094 2 -9169 28545 -1060 2 -9034 28588 -1038 2 -8883 28636 -1050 2 -8784 28664 -1111 2 -8691 28687 -1243 2 -8584 28721 -1198 2 -8470 28758 -1099 2 -8352 28795 -1033 2 -8260 28818 -1126 2 -8295 28801 -1294 2 -8224 28817 -1398 2 7341 28492 5857 0 7438 28460 5889 2 7539 28452 5798 2 7668 28438 5701 2 7830 28390 5718 2 7928 28340 5833 2 8064 28319 5747 2 8185 28307 5632 2 8271 28304 5523 2 8343 28302 5421 2 8335 28323 5325 2 8176 28362 5360 2 8030 28402 5372 2 7886 28446 5348 2 7746 28492 5311 2 7622 28534 5261 2 7482 28590 5163 2 7406 28625 5075 2 7323 28666 4961 2 7251 28704 4848 2 7101 28738 4869 2 7002 28745 4972 2 6964 28728 5118 2 7029 28689 5249 2 7039 28664 5367 2 7152 28627 5420 2 7247 28579 5543 2 7271 28549 5663 2 7281 28519 5802 2 13904 22523 14121 0 13885 22616 13991 3 13862 22704 13870 3 13812 22799 13763 3 13791 22886 13640 3 13735 22984 13530 3 13756 23049 13398 3 13850 23060 13281 3 13849 23083 13243 3 13730 23116 13310 3 13624 23219 13239 3 13603 23299 13119 3 13491 23390 13073 3 13455 23476 12955 3 13469 23542 12820 3 13498 23576 12727 3 13436 23522 12892 3 13438 23447 13026 3 13505 23359 13114 3 13603 23275 13162 3 13610 23198 13290 3 13712 23103 13350 3 13715 23022 13486 3 13755 22931 13600 3 13780 22835 13736 3 13823 22750 13833 3 13860 22660 13943 3 13876 22575 14065 3 13903 22498 14162 3 25599 5928 -14475 0 25632 5834 -14455 2 25679 5674 -14436 2 25704 5584 -14427 2 25758 5448 -14382 2 25820 5368 -14300 2 25888 5257 -14218 2 25952 5142 -14145 2 26019 5031 -14061 2 26083 4917 -13981 2 26150 4825 -13889 2 26220 4740 -13785 2 26286 4636 -13696 2 26369 4446 -13598 2 26311 4464 -13704 2 26244 4541 -13807 2 26175 4633 -13908 2 26113 4751 -13984 2 26039 4827 -14096 2 25976 4942 -14172 2 25926 5072 -14217 2 25877 5187 -14265 2 25795 5241 -14392 2 25732 5361 -14462 2 25647 5441 -14582 2 25627 5578 -14564 2 25625 5718 -14514 2 25597 5864 -14506 2 6784 26265 12812 0 6851 26260 12786 3 6888 26317 12648 3 6860 26383 12526 3 6940 26395 12457 3 7001 26439 12328 3 6956 26510 12200 3 6856 26598 12064 3 6829 26548 12189 3 6731 26545 12249 3 6598 26552 12306 3 6460 26633 12204 3 6610 26606 12183 3 6542 26645 12134 3 6449 26718 12023 3 6331 26734 12051 3 6213 26773 12025 3 6119 26840 11924 3 6122 26830 11945 3 6202 26760 12059 3 6334 26697 12131 3 6385 26622 12268 3 6415 26598 12305 3 6526 26558 12333 3 6653 26507 12375 3 6781 26468 12388 3 6768 26436 12463 3 6742 26387 12580 3 6675 26397 12594 3 6588 26399 12638 3 6582 26350 12742 3 6739 26294 12775 3 23238 12726 -14073 0 23314 12662 -14004 2 23402 12541 -13967 2 23490 12436 -13912 2 23574 12315 -13878 2 23659 12194 -13841 2 23744 12071 -13803 2 23807 11928 -13818 2 23873 11779 -13833 2 23893 11664 -13895 2 23917 11520 -13973 2 23895 11434 -14082 2 23897 11260 -14218 2 23825 11373 -14249 2 23754 11507 -14259 2 23668 11618 -14312 2 23584 11736 -14355 2 23512 11862 -14370 2 23441 12000 -14370 2 23372 12136 -14368 2 23303 12270 -14367 2 23219 12399 -14393 2 23162 12522 -14377 2 23083 12679 -14368 2 23103 12772 -14251 2 23169 12767 -14150 2 -15626 24491 7484 0 -15709 24424 7530 3 -15823 24336 7576 3 -15891 24331 7450 3 -15794 24436 7310 3 -15838 24404 7322 3 -15947 24300 7432 3 -16018 24275 7358 3 -16001 24333 7201 3 -15945 24419 7033 3 -15890 24473 6971 3 -15791 24563 6878 3 -15837 24533 6879 3 -15948 24452 6909 3 -16055 24357 6999 3 -16004 24389 7001 3 -15986 24382 7068 3 -16030 24311 7211 3 -16059 24254 7337 3 -16186 24137 7444 3 -16125 24179 7440 3 -16041 24227 7465 3 -15912 24285 7554 3 -15889 24256 7692 3 -15835 24244 7842 3 -15738 24281 7922 3 -15737 24303 7856 3 -15770 24317 7744 3 -15731 24382 7619 3 -15653 24462 7524 3 5003 28957 -6038 0 4861 28970 -6093 2 4773 28965 -6186 2 4651 28977 -6222 2 4657 29016 -6034 2 4577 29057 -5893 2 4509 29060 -5930 2 4620 29016 -6058 2 4606 28990 -6193 2 4490 28991 -6274 2 4370 29026 -6197 2 4277 29059 -6107 2 4340 29085 -5933 2 4439 29091 -5832 2 4462 29118 -5680 2 4524 29115 -5642 2 4651 29078 -5729 2 4709 29072 -5713 2 4710 29100 -5571 2 4737 29127 -5400 2 4852 29114 -5370 2 4986 29081 -5425 2 5095 29049 -5495 2 5193 29015 -5584 2 5236 28975 -5749 2 5239 28945 -5892 2 5130 28947 -5981 2 5035 28967 -5962 2 7323 -10567 -27106 0 7444 -10473 -27109 2 7586 -10400 -27098 2 7708 -10350 -27083 2 7739 -10373 -27065 2 7660 -10491 -27042 2 7560 -10617 -27021 2 7444 -10719 -27013 2 7345 -10807 -27005 2 7227 -10921 -26991 2 7111 -11008 -26986 2 6982 -11075 -26993 2 6849 -11139 -27000 2 6701 -11221 -27003 2 6597 -11310 -26992 2 6471 -11369 -26997 2 6309 -11412 -27018 2 6258 -11328 -27065 2 6379 -11231 -27077 2 6494 -11148 -27084 2 6609 -11062 -27092 2 6754 -10979 -27090 2 6859 -10920 -27087 2 6987 -10830 -27091 2 7092 -10715 -27109 2 7198 -10629 -27115 2 -20783 20998 5211 0 -20850 20958 5102 3 -20917 20922 4977 3 -20993 20892 4774 3 -21013 20855 4853 3 -21074 20809 4782 3 -21077 20840 4633 3 -21112 20834 4497 3 -21161 20814 4355 3 -21209 20795 4213 3 -21269 20759 4085 3 -21351 20696 3972 3 -21456 20603 3897 3 -21500 20539 3987 3 -21455 20559 4125 3 -21397 20591 4260 3 -21353 20607 4404 3 -21328 20601 4553 3 -21327 20568 4702 3 -21290 20570 4859 3 -21246 20586 4984 3 -21159 20648 5096 3 -21079 20711 5172 3 -20965 20832 5150 3 -20891 20912 5123 3 -20791 20984 5232 3 -22450 -137 19899 0 -22520 -123 19820 2 -22619 -100 19707 2 -22717 -81 19594 2 -22803 -121 19494 2 -22907 -110 19371 2 -23003 -78 19258 2 -23100 -69 19142 2 -23184 -129 19038 2 -23206 -308 19010 2 -23238 -416 18969 2 -23188 -553 19027 2 -23207 -602 19002 2 -23237 -742 18960 2 -23181 -877 19023 2 -23115 -953 19100 2 -23068 -876 19160 2 -23045 -876 19187 2 -22966 -908 19281 2 -22874 -897 19390 2 -22792 -820 19490 2 -22695 -798 19604 2 -22606 -729 19709 2 -22573 -628 19750 2 -22503 -511 19833 2 -22471 -367 19872 2 -22436 -211 19914 2 23559 -1507 -18512 0 23586 -1582 -18472 2 23629 -1756 -18401 2 23572 -1676 -18481 2 23509 -1710 -18559 2 23421 -1798 -18661 2 23325 -1715 -18789 2 23240 -1762 -18889 2 23143 -1796 -19004 2 23077 -1751 -19088 2 22968 -1771 -19218 2 22884 -1855 -19310 2 22792 -1913 -19413 2 22686 -1996 -19528 2 22649 -1899 -19581 2 22699 -1776 -19535 2 22759 -1645 -19476 2 22846 -1567 -19381 2 22948 -1558 -19260 2 23035 -1504 -19161 2 23134 -1469 -19044 2 23231 -1522 -18921 2 23315 -1490 -18819 2 23412 -1493 -18699 2 23506 -1497 -18580 2 25640 -4315 -14965 0 25671 -4360 -14899 2 25725 -4425 -14786 2 25710 -4580 -14766 2 25634 -4590 -14894 2 25560 -4592 -15021 2 25478 -4612 -15153 2 25400 -4654 -15270 2 25321 -4628 -15409 2 25247 -4615 -15533 2 25175 -4614 -15650 2 25105 -4564 -15777 2 25024 -4551 -15909 2 24947 -4487 -16047 2 24931 -4305 -16122 2 24946 -4338 -16089 2 25011 -4416 -15966 2 25061 -4496 -15866 2 25144 -4435 -15751 2 25216 -4431 -15637 2 25285 -4460 -15517 2 25364 -4425 -15397 2 25444 -4368 -15281 2 25529 -4328 -15150 2 25601 -4313 -15033 2 6329 18585 22684 0 6222 18564 22731 2 6103 18534 22787 2 5970 18511 22841 2 5834 18479 22902 2 5692 18474 22941 2 5549 18489 22965 2 5398 18536 22962 2 5245 18510 23019 2 5135 18477 23070 2 5130 18363 23162 2 5257 18293 23189 2 5404 18256 23185 2 5539 18188 23206 2 5675 18127 23221 2 5816 18095 23210 2 5948 18036 23223 2 6062 17953 23258 2 6213 17926 23239 2 6269 17982 23181 2 6295 18100 23081 2 6227 18202 23020 2 6222 18319 22928 2 6260 18425 22833 2 6318 18529 22732 2 7748 26705 11261 0 7877 26637 11333 3 7952 26630 11298 3 8089 26575 11329 3 8076 26525 11454 3 7915 26580 11440 3 7964 26532 11517 3 7921 26528 11556 3 7786 26594 11496 3 7788 26582 11521 3 7914 26519 11580 3 8013 26449 11671 3 8135 26389 11725 3 8276 26351 11709 3 8423 26276 11775 3 8315 26276 11852 3 8345 26249 11890 3 8517 26219 11833 3 8567 26260 11705 3 8549 26316 11593 3 8429 26381 11531 3 8303 26449 11469 3 8197 26514 11395 3 8128 26589 11268 3 8004 26639 11239 3 7852 26680 11248 3 14610 -1401 -26164 0 14567 -1458 -26185 2 14446 -1519 -26249 2 14332 -1603 -26306 2 14221 -1688 -26361 2 14113 -1783 -26413 2 13986 -1835 -26477 2 13886 -1932 -26522 2 13800 -2050 -26559 2 13736 -2187 -26581 2 13722 -2338 -26575 2 13649 -2484 -26599 2 13560 -2432 -26650 2 13533 -2289 -26676 2 13574 -2156 -26666 2 13669 -2056 -26626 2 13786 -1978 -26571 2 13880 -1878 -26530 2 13988 -1774 -26480 2 14093 -1684 -26430 2 14209 -1612 -26372 2 14326 -1532 -26314 2 14447 -1473 -26251 2 14559 -1387 -26194 2 26396 -4371 -13570 0 26423 -4399 -13507 2 26470 -4487 -13387 2 26459 -4647 -13354 2 26403 -4733 -13434 2 26339 -4718 -13564 2 26274 -4696 -13699 2 26212 -4654 -13830 2 26149 -4621 -13960 2 26101 -4541 -14075 2 26074 -4571 -14115 2 25987 -4591 -14270 2 25924 -4526 -14403 2 25955 -4384 -14392 2 26022 -4388 -14270 2 26057 -4341 -14219 2 26131 -4339 -14083 2 26200 -4247 -13983 2 26270 -4268 -13844 2 26222 -4393 -13896 2 26149 -4456 -14014 2 26152 -4520 -13987 2 26221 -4533 -13852 2 26291 -4431 -13754 2 26354 -4399 -13643 2 26582 10216 -9436 0 26612 10199 -9371 2 26661 10137 -9296 2 26736 10035 -9191 2 26806 9948 -9083 2 26856 9832 -9061 2 26902 9685 -9083 2 26937 9541 -9132 2 26918 9462 -9267 2 26888 9419 -9398 2 26842 9387 -9560 2 26765 9470 -9692 2 26721 9513 -9771 2 26644 9610 -9887 2 26592 9700 -9940 2 26532 9847 -9955 2 26440 10014 -10032 2 26382 10088 -10110 2 26342 10231 -10070 2 26378 10279 -9926 2 26426 10269 -9808 2 26489 10246 -9660 2 26537 10247 -9528 2 -8254 28832 -761 0 -8351 28805 -729 2 -8382 28795 -779 2 -8479 28765 -837 2 -8637 28717 -847 2 -8782 28673 -869 2 -8914 28633 -844 2 -9053 28590 -821 2 -9199 28544 -807 2 -9215 28542 -663 2 -9069 28591 -578 2 -8902 28642 -610 2 -8868 28655 -498 2 -8887 28651 -344 2 -8769 28689 -252 2 -8641 28728 -205 2 -8506 28769 -131 2 -8366 28810 -54 2 -8284 28833 -115 2 -8267 28837 -270 2 -8224 28848 -374 2 -8183 28858 -522 2 -8199 28850 -663 2 14884 12125 23053 0 14876 12008 23120 3 14906 11952 23129 3 14932 11851 23165 3 14890 11721 23257 3 14861 11601 23336 3 14760 11590 23405 3 14652 11571 23482 3 14576 11491 23569 3 14515 11367 23666 3 14467 11258 23748 3 14434 11131 23828 3 14432 11072 23856 3 14489 11238 23744 3 14551 11356 23650 3 14625 11429 23568 3 14677 11533 23485 3 14794 11533 23412 3 14886 11615 23313 3 14940 11710 23231 3 15012 11739 23169 3 14988 11885 23110 3 14955 12016 23064 3 14899 12149 23031 3 -6839 29182 -1275 0 -6959 29154 -1272 2 -7122 29116 -1246 2 -7082 29122 -1321 2 -6932 29154 -1422 2 -7012 29132 -1464 2 -7172 29094 -1440 2 -7190 29087 -1490 2 -7233 29071 -1592 2 -7317 29050 -1600 2 -7318 29058 -1437 2 -7317 29068 -1235 2 -7373 29051 -1293 2 -7473 29022 -1376 2 -7616 28985 -1374 2 -7651 28981 -1239 2 -7637 28992 -1082 2 -7503 29028 -1033 2 -7429 29050 -964 2 -7294 29083 -983 2 -7136 29124 -948 2 -6984 29160 -951 2 -6893 29178 -1061 2 -6852 29183 -1177 2 3600 19765 22280 0 3523 19706 22344 2 3417 19636 22422 2 3258 19628 22453 2 3254 19526 22542 2 3347 19427 22614 2 3368 19313 22708 2 3403 19203 22796 2 3391 19086 22896 2 3404 18954 23003 2 3442 18883 23056 2 3565 18841 23072 2 3660 18944 22972 2 3787 18948 22948 2 3869 18984 22905 2 3876 19100 22807 2 3875 19219 22707 2 3856 19329 22616 2 3863 19435 22525 2 3857 19539 22436 2 3783 19652 22349 2 3697 19742 22284 2 17666 16854 -17432 0 17724 16885 -17342 2 17791 16930 -17230 2 17918 16890 -17137 2 17995 16812 -17133 2 18113 16756 -17062 2 18201 16791 -16935 2 18319 16691 -16907 2 18429 16598 -16879 2 18561 16520 -16810 2 18536 16520 -16837 2 18511 16453 -16930 2 18552 16336 -17000 2 18502 16244 -17141 2 18405 16314 -17178 2 18298 16420 -17192 2 18201 16512 -17207 2 18079 16559 -17290 2 17993 16494 -17441 2 17876 16587 -17474 2 17758 16667 -17517 2 17707 16741 -17498 2 5861 26752 12246 0 5943 26719 12278 3 5987 26652 12403 3 6063 26588 12503 3 6067 26522 12640 3 6065 26462 12766 3 6091 26401 12880 3 6147 26329 12999 3 6232 26264 13090 3 6345 26283 12999 3 6265 26308 12986 3 6188 26367 12904 3 6140 26439 12779 3 6124 26503 12653 3 6151 26583 12471 3 6234 26608 12376 3 6235 26664 12254 3 6162 26713 12183 3 6146 26668 12291 3 6117 26615 12418 3 6065 26610 12455 3 6050 26665 12344 3 5987 26722 12251 3 -14603 25601 -5597 0 -14613 25626 -5455 3 -14541 25693 -5331 3 -14532 25728 -5186 3 -14555 25744 -5041 3 -14593 25750 -4894 3 -14610 25770 -4737 3 -14602 25798 -4613 3 -14665 25788 -4461 3 -14719 25785 -4302 3 -14699 25791 -4332 3 -14640 25802 -4463 3 -14570 25818 -4597 3 -14498 25834 -4734 3 -14467 25826 -4873 3 -14402 25848 -4948 3 -14321 25869 -5068 3 -14370 25817 -5193 3 -14419 25761 -5334 3 -14462 25710 -5462 3 -14513 25651 -5604 3 -5757 29270 -3178 0 -5793 29252 -3278 2 -5861 29224 -3408 2 -5920 29196 -3544 2 -5974 29168 -3683 2 -5986 29146 -3834 2 -6090 29117 -3891 2 -6197 29114 -3738 2 -6274 29102 -3699 2 -6337 29097 -3634 2 -6237 29133 -3517 2 -6168 29164 -3380 2 -6078 29196 -3261 2 -6132 29186 -3247 2 -6275 29151 -3290 2 -6253 29169 -3172 2 -6197 29196 -3033 2 -6072 29228 -2975 2 -5962 29260 -2883 2 -5843 29286 -2859 2 -5834 29278 -2966 2 -5799 29273 -3080 2 20081 22197 2006 0 20029 22248 1962 3 19945 22316 2048 3 19841 22396 2177 3 19772 22454 2205 3 19652 22556 2242 3 19579 22628 2147 3 19531 22686 1965 3 19447 22754 2020 3 19337 22841 2090 3 19319 22849 2175 3 19383 22797 2142 3 19461 22742 2024 3 19539 22672 2050 3 19573 22629 2195 3 19664 22543 2265 3 19779 22442 2265 3 19840 22378 2370 3 19907 22321 2340 3 19964 22284 2204 3 20039 22228 2085 3 -17819 21913 10114 0 -17847 21924 10041 2 -17989 21830 9991 2 -18092 21748 9985 2 -18216 21658 9954 2 -18329 21566 9948 2 -18407 21461 10030 2 -18384 21428 10142 2 -18308 21434 10266 2 -18205 21467 10380 2 -18089 21534 10443 2 -17994 21621 10427 2 -18050 21651 10268 2 -18162 21570 10241 2 -18264 21486 10238 2 -18299 21499 10148 2 -18221 21573 10131 2 -18079 21658 10203 2 -17989 21737 10193 2 -17880 21832 10180 2 7617 6776 28215 0 7517 6813 28232 3 7385 6874 28253 3 7244 6851 28295 3 7155 6929 28298 3 7059 6941 28319 3 6957 6994 28332 3 6964 7141 28293 3 6845 7234 28299 3 6704 7171 28348 3 6744 7018 28377 3 6821 6891 28390 3 6937 6804 28383 3 6991 6735 28386 3 7007 6611 28411 3 7128 6497 28407 3 7223 6562 28369 3 7338 6651 28318 3 7457 6692 28278 3 7607 6721 28230 3 10847 17337 21949 0 10792 17303 22003 2 10656 17302 22071 2 10531 17343 22098 2 10386 17362 22152 2 10252 17384 22197 2 10111 17366 22276 2 9981 17428 22285 2 9817 17454 22338 2 9770 17393 22406 2 9840 17312 22439 2 9987 17297 22385 2 10128 17279 22335 2 10272 17218 22317 2 10398 17181 22287 2 10527 17198 22213 2 10660 17210 22140 2 10795 17215 22071 2 10859 17284 21986 2 2092 29573 4591 0 2046 29564 4670 2 1956 29577 4622 2 1958 29556 4757 2 1869 29563 4746 2 1736 29579 4697 2 1693 29577 4729 2 1664 29563 4825 2 1638 29547 4927 2 1716 29523 5045 2 1933 29523 4963 2 1889 29508 5068 2 1947 29490 5150 2 2107 29485 5117 2 2256 29470 5142 2 2347 29484 5020 2 2377 29504 4884 2 2396 29527 4733 2 2339 29553 4599 2 2182 29565 4597 2 -20217 21829 -3845 0 -20288 21770 -3804 3 -20398 21664 -3822 3 -20498 21569 -3820 3 -20608 21466 -3813 3 -20703 21371 -3827 3 -20739 21336 -3830 3 -20831 21249 -3814 3 -20902 21162 -3908 3 -20902 21134 -4061 3 -20920 21118 -4051 3 -21018 21043 -3926 3 -20974 21090 -3913 3 -20890 21189 -3825 3 -20812 21275 -3771 3 -20698 21385 -3777 3 -20601 21481 -3762 3 -20503 21571 -3787 3 -20392 21673 -3801 3 -20276 21784 -3787 3 24559 5678 -16267 0 24604 5701 -16191 2 24686 5684 -16071 2 24739 5567 -16031 2 24787 5431 -16003 2 24816 5270 -16013 2 24895 5197 -15913 2 24957 5092 -15850 2 24944 4963 -15911 2 24888 4876 -16026 2 24854 4751 -16116 2 24781 4757 -16226 2 24746 4891 -16239 2 24761 5018 -16178 2 24727 5176 -16180 2 24673 5314 -16217 2 24622 5452 -16249 2 24567 5591 -16286 2 7773 28919 -1814 0 7684 28935 -1932 3 7601 28948 -2066 3 7560 28958 -2064 3 7552 28971 -1911 3 7714 28934 -1824 3 7766 28928 -1689 3 7784 28931 -1541 3 7690 28962 -1435 3 7636 28979 -1388 3 7836 28923 -1441 3 7944 28897 -1366 3 7975 28889 -1355 3 7986 28878 -1505 3 8116 28838 -1584 3 8143 28827 -1638 3 7982 28876 -1572 3 7912 28896 -1567 3 7913 28888 -1688 3 7822 28910 -1738 3 28847 -786 -8199 0 28861 -867 -8144 2 28878 -857 -8081 2 28911 -873 -7961 2 28932 -1026 -7868 2 28905 -1107 -7953 2 28864 -1112 -8100 2 28838 -1229 -8178 2 28820 -1361 -8220 2 28796 -1481 -8282 2 28753 -1536 -8420 2 28713 -1609 -8543 2 28700 -1555 -8595 2 28699 -1384 -8627 2 28725 -1317 -8552 2 28767 -1260 -8419 2 28790 -1117 -8359 2 28803 -967 -8333 2 28827 -831 -8264 2 -13526 25075 -9397 0 -13630 25018 -9397 3 -13799 24914 -9428 3 -13880 24870 -9423 3 -13999 24814 -9396 3 -14135 24752 -9355 3 -14290 24661 -9360 3 -14269 24682 -9336 3 -14144 24753 -9341 3 -14009 24825 -9352 3 -13975 24875 -9269 3 -14054 24879 -9139 3 -14132 24892 -8980 3 -14093 24909 -8997 3 -14039 24887 -9139 3 -13973 24880 -9258 3 -13845 24919 -9347 3 -13726 24972 -9380 3 -13596 25044 -9379 3 -8960 -28564 -1947 0 -8964 -28571 -1831 2 -8966 -28579 -1682 2 -8949 -28594 -1512 2 -8909 -28613 -1384 2 -8928 -28614 -1226 2 -8925 -28621 -1082 2 -8985 -28607 -961 2 -9091 -28573 -972 2 -9108 -28564 -1078 2 -9186 -28539 -1064 2 -9263 -28512 -1129 2 -9162 -28542 -1197 2 -9150 -28541 -1299 2 -9233 -28510 -1400 2 -9157 -28531 -1460 2 -9113 -28541 -1536 2 -9123 -28531 -1659 2 -9107 -28527 -1807 2 -9030 -28542 -1960 2 17593 2406 24180 0 17547 2284 24226 3 17545 2132 24241 3 17531 1985 24264 3 17563 1840 24252 3 17624 1706 24217 3 17684 1578 24182 3 17775 1468 24123 3 17857 1306 24071 3 17908 1411 24028 3 17857 1519 24059 3 17763 1620 24121 3 17705 1753 24155 3 17693 1908 24152 3 17681 2056 24148 3 17678 2207 24137 3 17661 2361 24135 3 7274 26419 12212 0 7244 26366 12344 3 7218 26303 12493 3 7308 26248 12554 3 7429 26186 12613 3 7541 26117 12690 3 7652 26051 12758 3 7788 25974 12834 3 7833 26021 12710 3 7942 26030 12624 3 8011 26056 12527 3 7988 26120 12408 3 7920 26193 12297 3 7802 26258 12232 3 7654 26308 12220 3 7515 26352 12210 3 7380 26400 12189 3 -5378 29484 -1323 0 -5371 29481 -1417 2 -5446 29463 -1514 2 -5580 29441 -1448 2 -5703 29420 -1393 2 -5781 29402 -1447 2 -5826 29388 -1546 2 -5914 29375 -1455 2 -5937 29377 -1324 2 -6027 29364 -1195 2 -6168 29336 -1157 2 -6229 29328 -1038 2 -6099 29357 -984 2 -5952 29386 -1019 2 -5812 29414 -1014 2 -5691 29435 -1100 2 -5592 29449 -1222 2 -5449 29474 -1271 2 13477 22776 14129 0 13586 22700 14146 3 13627 22621 14233 3 13621 22544 14361 3 13596 22466 14506 3 13617 22375 14627 3 13649 22293 14722 3 13568 22263 14840 3 13562 22193 14951 3 13654 22163 14912 3 13739 22211 14762 3 13740 22262 14684 3 13689 22354 14591 3 13684 22450 14449 3 13663 22528 14345 3 13638 22613 14237 3 13606 22696 14135 3 13486 22771 14128 3 13832 17499 20061 0 13783 17475 20115 2 13696 17421 20223 2 13597 17375 20328 2 13484 17351 20424 2 13339 17356 20514 2 13276 17283 20617 2 13155 17242 20728 2 13175 17148 20793 2 13293 17069 20784 2 13431 17047 20712 2 13541 17089 20606 2 13622 17147 20504 2 13724 17195 20396 2 13694 17287 20338 2 13729 17383 20233 2 13802 17456 20119 2 24192 6529 -16496 0 24197 6448 -16521 2 24185 6316 -16589 2 24127 6227 -16706 2 24083 6134 -16805 2 24092 6027 -16829 2 24103 5937 -16846 2 24055 5829 -16952 2 23938 5791 -17129 2 23921 5911 -17113 2 23925 6067 -17053 2 23903 6207 -17033 2 23885 6347 -17007 2 23913 6459 -16925 2 23982 6524 -16802 2 24064 6503 -16693 2 24151 6513 -16563 2 13005 -9227 25411 0 13094 -9120 25404 3 13211 -9029 25376 3 13307 -8900 25371 3 13431 -8816 25335 3 13521 -8737 25315 3 13656 -8678 25262 3 13848 -8607 25182 3 13754 -8533 25259 3 13618 -8577 25318 3 13502 -8671 25348 3 13372 -8735 25395 3 13279 -8832 25410 3 13171 -8963 25420 3 13098 -9075 25418 3 13005 -9194 25423 3 12753 25778 8535 0 12805 25714 8649 3 12904 25656 8676 3 12899 25607 8826 3 12908 25602 8827 3 12996 25588 8737 3 13139 25509 8756 3 13335 25411 8745 3 13259 25477 8667 3 13174 25510 8701 3 13015 25594 8692 3 12932 25676 8574 3 12805 25749 8546 3 12774 25808 8412 3 12666 25882 8348 3 12613 25915 8325 3 12744 25815 8437 3 -16206 24956 -3814 0 -16170 24992 -3734 3 -16124 25043 -3587 3 -16050 25103 -3499 3 -15953 25178 -3396 3 -15830 25260 -3364 3 -15660 25382 -3245 3 -15548 25446 -3277 3 -15556 25430 -3363 3 -15641 25360 -3493 3 -15757 25274 -3598 3 -15867 25208 -3578 3 -16038 25095 -3610 3 -16097 25043 -3705 3 -16025 25087 -3722 3 -16060 25060 -3756 3 -16139 25001 -3808 3 -27904 9377 5782 0 -27890 9343 5903 2 -27898 9244 6020 2 -27884 9197 6154 2 -27859 9161 6323 2 -27803 9226 6472 2 -27776 9222 6590 2 -27742 9211 6749 2 -27710 9300 6758 2 -27716 9372 6634 2 -27729 9430 6497 2 -27745 9475 6357 2 -27770 9501 6210 2 -27797 9517 6064 2 -27832 9503 5921 2 -27875 9461 5785 2 24919 6169 -15523 0 24904 6086 -15580 2 24919 5942 -15612 2 24949 5794 -15619 2 24995 5646 -15600 2 25022 5494 -15611 2 24992 5479 -15665 2 24913 5547 -15766 2 24828 5590 -15884 2 24756 5692 -15961 2 24678 5787 -16047 2 24619 5957 -16075 2 24674 5984 -15981 2 24743 6013 -15863 2 24803 6077 -15744 2 24861 6146 -15625 2 25878 -4981 -14336 0 25813 -5073 -14420 2 25739 -5090 -14546 2 25665 -5138 -14659 2 25590 -5222 -14761 2 25519 -5322 -14848 2 25439 -5347 -14976 2 25377 -5286 -15103 2 25403 -5168 -15099 2 25474 -5055 -15018 2 25550 -4994 -14908 2 25629 -4889 -14808 2 25696 -4882 -14693 2 25771 -4883 -14562 2 25843 -4896 -14429 2 5450 29486 -929 0 5296 29515 -920 2 5163 29540 -867 2 5178 29540 -765 2 5233 29532 -706 2 5102 29556 -623 2 5153 29550 -477 2 5270 29531 -401 2 5422 29504 -315 2 5468 29495 -369 2 5639 29461 -477 2 5685 29450 -610 2 5752 29434 -753 2 5754 29429 -893 2 5639 29449 -972 2 5527 29472 -906 2 17357 24467 -289 0 17450 24400 -372 3 17564 24317 -439 3 17682 24231 -446 3 17669 24239 -495 3 17606 24285 -491 3 17475 24381 -456 3 17376 24453 -337 3 17263 24534 -300 3 17184 24587 -396 3 17154 24606 -535 3 17052 24672 -713 3 17070 24662 -638 3 17131 24623 -515 3 17171 24597 -373 3 17256 24539 -283 3 -10217 28170 -1431 0 -10282 28144 -1490 2 -10403 28097 -1528 2 -10515 28050 -1611 2 -10579 28018 -1753 2 -10682 27983 -1687 2 -10756 27962 -1564 2 -10869 27926 -1417 2 -10921 27912 -1294 2 -10899 27926 -1158 2 -10827 27958 -1047 2 -10754 27986 -1062 2 -10627 28032 -1137 2 -10498 28078 -1185 2 -10378 28118 -1301 2 -10287 28148 -1364 2 29126 7027 -1524 0 29151 6932 -1463 2 29186 6788 -1442 2 29223 6635 -1413 2 29255 6499 -1391 2 29287 6352 -1395 2 29323 6196 -1328 2 29354 6043 -1354 2 29344 6077 -1404 2 29311 6232 -1418 2 29276 6382 -1473 2 29249 6499 -1509 2 29208 6682 -1499 2 29181 6791 -1529 2 29146 6936 -1548 2 6145 29344 -1095 0 6034 29362 -1206 2 5981 29367 -1344 2 5899 29377 -1483 2 5794 29393 -1569 2 5647 29425 -1514 2 5569 29444 -1420 2 5524 29458 -1313 2 5593 29447 -1253 2 5432 29481 -1179 2 5583 29455 -1105 2 5724 29429 -1090 2 5863 29403 -1054 2 6008 29374 -1038 2 6135 29349 -1015 2 24375 5854 -16479 0 24415 5790 -16444 2 24458 5650 -16428 2 24517 5517 -16385 2 24575 5384 -16342 2 24640 5251 -16288 2 24683 5125 -16264 2 24720 4968 -16255 2 24687 4964 -16307 2 24633 5101 -16346 2 24582 5241 -16378 2 24504 5353 -16458 2 24446 5464 -16509 2 24420 5614 -16497 2 24397 5761 -16480 2 -17689 24006 -3293 0 -17686 23992 -3405 3 -17759 23932 -3446 3 -17793 23921 -3345 3 -17863 23883 -3240 3 -17952 23826 -3174 3 -18058 23738 -3230 3 -18221 23613 -3226 3 -18325 23541 -3170 3 -18281 23580 -3133 3 -18161 23671 -3137 3 -18055 23757 -3101 3 -17943 23847 -3058 3 -17828 23931 -3072 3 -17735 23984 -3198 3 12744 -2905 -27003 0 12739 -3050 -26989 2 12662 -3173 -27011 2 12559 -3272 -27048 2 12496 -3390 -27062 2 12429 -3512 -27077 2 12301 -3581 -27127 2 12168 -3530 -27193 2 12185 -3383 -27205 2 12292 -3266 -27170 2 12396 -3187 -27133 2 12495 -3067 -27101 2 12581 -2933 -27076 2 12700 -2875 -27027 2 -12039 24973 -11465 0 -12103 24933 -11483 2 -12239 24858 -11501 2 -12336 24773 -11582 2 -12451 24687 -11640 2 -12557 24640 -11628 2 -12685 24576 -11623 2 -12811 24507 -11631 2 -12818 24545 -11544 2 -12719 24620 -11493 2 -12563 24713 -11465 2 -12502 24768 -11412 2 -12372 24845 -11387 2 -12232 24902 -11413 2 -12108 24962 -11415 2 7404 28675 -4785 0 7375 28658 -4931 2 7358 28637 -5079 2 7365 28608 -5228 2 7320 28597 -5351 2 7170 28650 -5270 2 7039 28692 -5219 2 6925 28738 -5116 2 6908 28762 -5000 2 6915 28786 -4852 2 6971 28796 -4714 2 7096 28771 -4679 2 7242 28716 -4790 2 7371 28686 -4773 2 -18411 21935 8938 0 -18526 21854 8898 2 -18563 21784 8992 2 -18579 21717 9122 2 -18585 21659 9246 2 -18514 21661 9382 2 -18531 21602 9485 2 -18454 21620 9594 2 -18323 21711 9639 2 -18343 21746 9522 2 -18412 21735 9411 2 -18468 21751 9263 2 -18520 21762 9133 2 -18502 21809 9058 2 -18432 21899 8983 2 -19925 -10993 19549 0 -20010 -10933 19495 3 -20091 -10802 19485 3 -20186 -10670 19460 3 -20137 -10626 19534 3 -20013 -10735 19602 3 -19909 -10784 19681 3 -19947 -10749 19661 3 -20053 -10612 19629 3 -20120 -10574 19581 3 -20231 -10590 19456 3 -20220 -10666 19427 3 -20156 -10784 19428 3 -20127 -10910 19387 3 -20076 -10934 19426 3 -19976 -10981 19504 3 -18321 23571 -2957 0 -18342 23546 -3022 3 -18397 23502 -3034 3 -18524 23414 -2941 3 -18617 23343 -2915 3 -18722 23262 -2895 3 -18840 23172 -2853 3 -18964 23073 -2833 3 -18988 23069 -2701 3 -18899 23146 -2660 3 -18792 23225 -2731 3 -18702 23285 -2842 3 -18603 23365 -2831 3 -18448 23482 -2875 3 -18382 23527 -2931 3 -17336 22935 8569 0 -17413 22944 8388 2 -17449 22893 8453 2 -17444 22843 8597 2 -17477 22771 8720 2 -17466 22722 8869 2 -17430 22692 9015 2 -17385 22669 9157 2 -17286 22699 9272 2 -17255 22777 9136 2 -17259 22830 8996 2 -17268 22879 8852 2 -17294 22915 8706 2 18292 -22847 6589 0 18309 -22796 6718 2 18374 -22769 6630 2 18412 -22763 6543 2 18493 -22679 6607 2 18384 -22723 6759 2 18388 -22686 6874 2 18372 -22665 6983 2 18447 -22577 7071 2 18347 -22646 7110 2 18255 -22735 7063 2 18130 -22847 7023 2 18176 -22841 6923 2 18232 -22841 6775 2 18239 -22863 6683 2 25183 6987 -14730 0 25164 6919 -14796 2 25130 6812 -14902 2 25129 6672 -14967 2 25121 6548 -15035 2 25103 6411 -15124 2 25048 6381 -15228 2 24987 6483 -15285 2 24947 6625 -15290 2 24918 6784 -15266 2 24936 6898 -15186 2 24992 6972 -15060 2 25055 6997 -14943 2 25131 7007 -14810 2 -8316 28793 1345 0 -8428 28760 1359 2 -8534 28724 1443 2 -8653 28685 1513 2 -8736 28654 1628 2 -8666 28667 1763 2 -8625 28670 1905 2 -8613 28663 2061 2 -8514 28691 2080 2 -8406 28730 1980 2 -8311 28765 1871 2 -8269 28786 1723 2 -8299 28786 1573 2 -8283 28799 1423 2 -20941 -20602 6087 0 -20998 -20524 6152 2 -21067 -20436 6208 2 -21163 -20341 6195 2 -21239 -20259 6203 2 -21293 -20164 6326 2 -21409 -20040 6327 2 -21473 -20012 6200 2 -21426 -20086 6121 2 -21344 -20194 6052 2 -21247 -20305 6023 2 -21149 -20419 5981 2 -21065 -20528 5906 2 -20979 -20593 5984 2 -4213 -29615 2279 0 -4267 -29597 2406 2 -4380 -29573 2503 2 -4508 -29547 2582 2 -4646 -29519 2654 2 -4702 -29517 2572 2 -4590 -29544 2469 2 -4512 -29565 2351 2 -4557 -29570 2206 2 -4684 -29561 2046 2 -4549 -29584 2023 2 -4469 -29587 2148 2 -4320 -29606 2196 2 -7190 25393 -14265 0 -7112 25378 -14331 2 -7120 25307 -14452 2 -7024 25329 -14461 2 -6921 25307 -14549 2 -6937 25238 -14661 2 -7060 25152 -14750 2 -7089 25166 -14711 2 -7140 25183 -14657 2 -7201 25135 -14710 2 -7254 25157 -14645 2 -7308 25222 -14506 2 -7376 25272 -14384 2 -7458 25292 -14306 2 -7433 25354 -14210 2 -7329 25398 -14185 2 -7241 25418 -14195 2 -19493 22341 -4569 0 -19472 22331 -4707 3 -19490 22314 -4716 3 -19508 22329 -4566 3 -19549 22322 -4426 3 -19653 22240 -4378 3 -19763 22155 -4310 3 -19839 22114 -4170 3 -19850 22141 -3969 3 -19826 22151 -4033 3 -19807 22141 -4177 3 -19683 22231 -4283 3 -19626 22264 -4376 3 -19523 22343 -4430 3 631 -8774 -28681 0 536 -8722 -28699 2 423 -8648 -28724 2 297 -8665 -28720 2 79 -8600 -28741 2 199 -8618 -28735 2 202 -8556 -28753 2 51 -8393 -28802 2 169 -8385 -28804 2 295 -8444 -28786 2 437 -8487 -28771 2 573 -8549 -28750 2 715 -8613 -28728 2 692 -8702 -28702 2 19698 -3856 -22297 0 19764 -3875 -22234 2 19858 -3942 -22138 2 19917 -4057 -22065 2 19958 -4190 -22003 2 19991 -4334 -21945 2 19935 -4378 -21987 2 19823 -4377 -22088 2 19711 -4379 -22188 2 19623 -4290 -22283 2 19544 -4197 -22370 2 19509 -4061 -22425 2 19527 -3935 -22432 2 19636 -3850 -22352 2 -11506 10377 -25689 0 -11530 10271 -25721 2 -11485 10138 -25794 2 -11542 9992 -25825 2 -11574 9847 -25866 2 -11686 9764 -25848 2 -11782 9854 -25770 2 -11896 9912 -25695 2 -12010 9993 -25611 2 -11943 10110 -25596 2 -11854 10227 -25591 2 -11723 10303 -25621 2 -11590 10358 -25659 2 3573 20459 21649 0 3555 20377 21729 2 3434 20322 21799 2 3328 20243 21890 2 3339 20136 21986 2 3381 20023 22083 2 3445 19928 22159 2 3590 19867 22191 2 3648 19965 22093 2 3666 20079 21986 2 3681 20189 21883 2 3641 20303 21784 2 3617 20410 21688 2 -13127 24311 -11689 0 -13095 24275 -11800 2 -13115 24210 -11911 2 -13126 24171 -11978 2 -13007 24279 -11890 2 -12888 24314 -11947 2 -12876 24273 -12043 2 -12989 24180 -12109 2 -13137 24097 -12115 2 -13215 24038 -12146 2 -13314 24023 -12067 2 -13299 24094 -11943 2 -13218 24182 -11854 2 -13169 24265 -11738 2 -27102 -7955 10108 0 -27143 -7915 10032 3 -27136 -8036 9953 3 -27134 -8131 9881 3 -27084 -8207 9954 3 -27024 -8266 10070 3 -26970 -8365 10133 3 -26921 -8351 10273 3 -26863 -8463 10332 3 -26822 -8433 10462 3 -26878 -8318 10410 3 -26933 -8214 10351 3 -27001 -8109 10257 3 -27063 -8011 10169 3 24282 5951 -16583 0 24283 5821 -16626 2 24271 5697 -16687 2 24209 5633 -16799 2 24230 5488 -16816 2 24218 5295 -16896 2 24143 5357 -16983 2 24105 5471 -17000 2 24127 5608 -16925 2 24105 5760 -16905 2 24106 5897 -16856 2 24180 5898 -16750 2 24242 5949 -16641 2 -26265 9394 11041 0 -26290 9264 11093 2 -26229 9254 11244 2 -26168 9254 11384 2 -26112 9243 11520 2 -26040 9279 11654 2 -25958 9408 11734 2 -25991 9492 11591 2 -26038 9500 11479 2 -26097 9512 11334 2 -26157 9514 11193 2 -26220 9502 11057 2 959 -9398 -28474 0 863 -9358 -28490 2 726 -9328 -28504 2 680 -9232 -28536 2 726 -9095 -28579 2 846 -8991 -28608 2 952 -8948 -28619 2 1117 -8982 -28602 2 1239 -9037 -28580 2 1310 -9153 -28539 2 1344 -9285 -28495 2 1216 -9355 -28478 2 1066 -9394 -28471 2 14782 -8096 24818 0 14851 -8116 24770 3 14970 -8149 24688 3 15103 -8126 24614 3 15232 -8127 24535 3 15362 -8108 24459 3 15534 -8064 24365 3 15482 -8040 24406 3 15353 -8062 24480 3 15229 -8072 24555 3 15094 -8077 24636 3 14967 -8102 24705 3 14840 -8091 24785 3 -18588 -22992 5084 0 -18618 -22951 5159 2 -18714 -22867 5186 2 -18831 -22759 5237 2 -18952 -22653 5260 2 -19068 -22561 5237 2 -19052 -22600 5125 2 -18926 -22712 5098 2 -18893 -22769 4965 2 -18747 -22888 4972 2 -18807 -22812 5088 2 -18754 -22857 5086 2 -18640 -22954 5063 2 10930 21399 -17962 0 11042 21342 -17960 2 11173 21333 -17891 2 11262 21290 -17886 2 11393 21219 -17887 2 11541 21133 -17895 2 11662 21043 -17922 2 11628 21029 -17960 2 11497 21103 -17957 2 11363 21184 -17948 2 11223 21237 -17973 2 11085 21298 -17986 2 10930 21351 -18018 2 2123 5909 29336 0 2214 5831 29345 3 2344 5758 29349 3 2409 5627 29369 3 2324 5515 29397 3 2284 5382 29425 3 2334 5220 29450 3 2368 5256 29441 3 2396 5395 29413 3 2406 5530 29388 3 2414 5682 29358 3 2311 5798 29344 3 2179 5864 29340 3 -17261 24337 -3127 0 -17367 24256 -3168 3 -17464 24183 -3193 3 -17534 24116 -3312 3 -17637 24047 -3264 3 -17726 23996 -3153 3 -17753 23996 -3006 3 -17723 24027 -2932 3 -17680 24048 -3017 3 -17628 24077 -3089 3 -17503 24165 -3114 3 -17421 24240 -2985 3 -17406 24241 -3062 3 -17312 24308 -3064 3 -17925 23424 5478 0 -17981 23402 5389 3 -18090 23338 5299 3 -18186 23275 5249 3 -18344 23147 5264 3 -18466 23042 5297 3 -18395 23090 5333 3 -18307 23164 5319 3 -18188 23250 5350 3 -18055 23337 5424 3 -18122 23285 5424 3 -18079 23307 5472 3 -17970 23372 5553 3 -17965 23382 5524 3 -17949 23399 5504 3 -11151 25532 -11125 0 -11247 25472 -11165 2 -11360 25387 -11245 2 -11514 25291 -11305 2 -11603 25207 -11400 2 -11642 25248 -11268 2 -11599 25304 -11189 2 -11412 25424 -11108 2 -11533 25365 -11118 2 -11496 25398 -11081 2 -11361 25471 -11052 2 -11229 25505 -11108 2 -8245 28241 5871 0 -8361 28193 5939 2 -8472 28148 5990 2 -8527 28115 6069 2 -8460 28104 6211 2 -8525 28086 6207 2 -8559 28058 6282 2 -8448 28071 6378 2 -8314 28095 6445 2 -8194 28138 6410 2 -8186 28176 6254 2 -8154 28216 6111 2 -8181 28240 5966 2 -29258 6281 2126 0 -29281 6183 2094 3 -29308 6047 2123 3 -29331 5906 2195 3 -29338 5824 2318 3 -29335 5778 2463 3 -29327 5753 2617 3 -29302 5858 2659 3 -29285 5977 2576 3 -29271 6090 2474 3 -29263 6178 2351 3 -29254 6263 2231 3 15271 556 25816 0 15343 663 25771 3 15427 783 25718 3 15536 857 25649 3 15609 980 25601 3 15623 1179 25584 3 15563 1143 25622 3 15469 1042 25683 3 15368 952 25747 3 15275 847 25806 3 15196 727 25856 3 15215 607 25848 3 4573 29647 -405 0 4680 29631 -283 2 4807 29611 -242 2 4971 29585 -202 2 5045 29572 -186 2 5108 29561 -240 2 5156 29551 -392 2 5082 29562 -522 2 4997 29574 -630 2 4832 29602 -631 2 4723 29620 -605 2 4606 29640 -512 2 4528 29653 -458 2 9509 25746 12114 0 9428 25721 12228 3 9535 25676 12240 3 9592 25613 12327 3 9442 25639 12388 3 9484 25610 12416 3 9635 25545 12435 3 9800 25481 12436 3 9886 25484 12363 3 9884 25551 12226 3 9756 25609 12207 3 9617 25671 12187 3 10885 -3987 -27670 0 10786 -4100 -27692 2 10673 -4191 -27722 2 10543 -4265 -27761 2 10416 -4332 -27798 2 10258 -4423 -27842 2 10250 -4360 -27855 2 10358 -4251 -27832 2 10480 -4170 -27799 2 10611 -4111 -27758 2 10728 -4020 -27726 2 10847 -3956 -27689 2 -10784 27846 2885 0 -10753 27865 2814 2 -10759 27878 2664 2 -10843 27855 2552 2 -10983 27804 2512 2 -11122 27749 2511 2 -11249 27693 2565 2 -11292 27663 2687 2 -11237 27672 2830 2 -11131 27704 2930 2 -10991 27759 2933 2 -10858 27816 2891 2 -20095 -16594 14860 0 -20110 -16535 14906 3 -20157 -16401 14991 3 -20152 -16310 15097 3 -20120 -16271 15180 3 -20063 -16246 15282 3 -20156 -16058 15358 3 -20193 -16119 15245 3 -20218 -16214 15111 3 -20210 -16309 15019 3 -20219 -16404 14904 3 -20139 -16535 14866 3 -19229 22976 -1545 0 -19296 22918 -1556 3 -19384 22836 -1664 3 -19481 22751 -1696 3 -19561 22675 -1788 3 -19633 22616 -1758 3 -19658 22605 -1609 3 -19579 22684 -1447 3 -19487 22755 -1566 3 -19484 22767 -1426 3 -19393 22843 -1461 3 -19296 22921 -1516 3 -1931 -29525 -4956 0 -1965 -29500 -5088 2 -1938 -29476 -5235 2 -1892 -29453 -5379 2 -1850 -29429 -5526 2 -1722 -29428 -5571 2 -1604 -29455 -5461 2 -1567 -29483 -5322 2 -1611 -29506 -5179 2 -1693 -29523 -5051 2 -1812 -29531 -4962 2 -7314 -28817 -4011 0 -7276 -28807 -4146 2 -7213 -28803 -4283 2 -7177 -28790 -4430 2 -7097 -28787 -4575 2 -7011 -28823 -4482 2 -6887 -28867 -4392 2 -6856 -28890 -4285 2 -6964 -28879 -4182 2 -7073 -28867 -4081 2 -7192 -28850 -3996 2 -10998 25512 -11321 0 -10957 25484 -11424 2 -11011 25423 -11508 2 -11118 25352 -11562 2 -11247 25290 -11573 2 -11222 25338 -11491 2 -11242 25347 -11452 2 -11392 25299 -11408 2 -11375 25343 -11329 2 -11188 25400 -11389 2 -11262 25388 -11340 2 -11255 25425 -11265 2 -11134 25459 -11308 2 -11089 25463 -11344 2 -29990 -14 -784 0 -29991 -153 -700 2 -29992 -308 -616 2 -29988 -413 -745 2 -29987 -521 -723 2 -29990 -525 -569 2 -29994 -438 -445 2 -29994 -304 -489 2 -29994 -176 -557 2 -29993 -51 -632 2 -29991 56 -714 2 24220 -1670 -17623 0 24199 -1812 -17639 2 24131 -1911 -17722 2 24047 -1978 -17828 2 23961 -1985 -17943 2 23880 -1926 -18057 2 23840 -1814 -18121 2 23895 -1712 -18058 2 23974 -1620 -17962 2 24065 -1606 -17840 2 24155 -1637 -17716 2 140 28342 -9835 0 -8 28358 -9789 2 -155 28356 -9794 2 -307 28370 -9749 2 -403 28404 -9646 2 -302 28445 -9528 2 -163 28462 -9480 2 -13 28456 -9501 2 109 28427 -9586 2 209 28389 -9697 2 217 28348 -9817 2 9134 18840 21486 0 9268 18774 21486 2 9394 18683 21511 2 9529 18629 21498 2 9642 18562 21506 2 9779 18480 21514 2 9736 18542 21480 2 9639 18642 21438 2 9548 18737 21396 2 9398 18777 21427 2 9274 18851 21416 2 -21516 19701 6996 0 -21570 19694 6847 2 -21622 19676 6733 2 -21678 19664 6588 2 -21728 19651 6458 2 -21846 19562 6330 2 -21840 19534 6436 2 -21763 19571 6585 2 -21694 19597 6730 2 -21629 19630 6845 2 -21547 19677 6968 2 -2471 26742 -13370 0 -2577 26779 -13275 2 -2515 26811 -13223 2 -2382 26834 -13201 2 -2269 26876 -13135 2 -2111 26875 -13164 2 -1966 26888 -13159 2 -1903 26861 -13223 2 -1996 26815 -13303 2 -2172 26820 -13264 2 -2285 26791 -13306 2 -2398 26749 -13369 2 -10150 -24537 13962 0 -10160 -24501 14017 2 -10262 -24419 14085 2 -10409 -24355 14089 2 -10536 -24306 14078 2 -10669 -24284 14015 2 -10811 -24271 13929 2 -10764 -24299 13918 2 -10641 -24334 13952 2 -10497 -24383 13974 2 -10360 -24435 13986 2 -10224 -24509 13955 2 -15831 -23712 9333 0 -15820 -23673 9453 2 -15808 -23628 9584 2 -15775 -23585 9743 2 -15746 -23547 9879 2 -15818 -23485 9912 2 -15872 -23485 9825 2 -15937 -23456 9789 2 -16040 -23421 9703 2 -15980 -23513 9581 2 -15962 -23569 9472 2 -15928 -23639 9353 2 -26860 12885 -3537 0 -26882 12817 -3615 3 -26946 12675 -3639 3 -27001 12555 -3648 3 -27055 12427 -3690 3 -27153 12210 -3695 3 -27125 12276 -3679 3 -27066 12414 -3650 3 -27009 12549 -3611 3 -26952 12683 -3567 3 -26896 12816 -3514 3 21555 20350 4610 0 21542 20337 4727 3 21519 20327 4874 3 21508 20302 5023 3 21523 20237 5216 3 21612 20171 5107 3 21671 20139 4979 3 21703 20142 4825 3 21677 20203 4682 3 21606 20314 4532 3 25080 -2304 -16299 0 25116 -2395 -16231 2 25117 -2547 -16207 2 25122 -2692 -16175 2 25150 -2830 -16107 2 25122 -2953 -16129 2 25075 -2890 -16214 2 25021 -2813 -16310 2 25035 -2717 -16306 2 25069 -2633 -16267 2 25036 -2496 -16340 2 25041 -2367 -16350 2 -5147 -29506 1706 0 -5111 -29507 1790 2 -5206 -29483 1916 2 -5310 -29457 2024 2 -5395 -29433 2149 2 -5498 -29404 2278 2 -5553 -29399 2198 2 -5512 -29418 2053 2 -5456 -29438 1913 2 -5367 -29462 1792 2 -5236 -29489 1719 2 3601 24897 16346 0 3507 24832 16465 2 3401 24830 16490 2 3258 24788 16581 2 3289 24705 16698 2 3361 24642 16777 2 3522 24593 16815 2 3610 24628 16746 2 3622 24701 16636 2 3659 24768 16527 2 3651 24851 16403 2 -16031 -24558 6319 0 -16060 -24566 6211 2 -16088 -24589 6045 2 -16069 -24631 5922 2 -15939 -24699 5991 2 -15997 -24653 6028 2 -15992 -24637 6107 2 -15891 -24691 6150 2 -15759 -24740 6290 2 -15874 -24670 6277 2 -15992 -24612 6205 2 -15978 -24600 6288 2 4179 29039 -6267 0 4252 29002 -6388 2 4198 28976 -6539 2 4141 28953 -6675 2 4027 28946 -6778 2 3873 28961 -6802 2 3786 28995 -6706 2 3882 29012 -6575 2 3974 29020 -6483 2 4075 29030 -6375 2 4134 29040 -6293 2 7225 28615 -5385 0 7075 28645 -5425 2 6936 28669 -5476 2 6784 28705 -5479 2 6761 28737 -5335 2 6757 28763 -5201 2 6857 28753 -5125 2 6981 28709 -5205 2 7118 28667 -5250 2 7241 28621 -5330 2 7290 28597 -5390 2 27028 -4267 -12299 0 26981 -4368 -12368 2 26913 -4418 -12496 2 26837 -4561 -12608 2 26798 -4487 -12717 2 26756 -4387 -12840 2 26809 -4263 -12771 2 26878 -4222 -12639 2 26933 -4270 -12505 2 27000 -4241 -12369 2 17469 24240 2693 0 17441 24265 2655 3 17358 24337 2525 3 17308 24387 2395 3 17256 24436 2262 3 17199 24491 2092 3 17162 24514 2137 3 17221 24459 2280 3 17294 24396 2403 3 17345 24346 2530 3 17415 24283 2652 3 9832 -4353 -28007 0 9820 -4448 -27996 2 9788 -4592 -27984 2 9729 -4734 -27981 2 9625 -4841 -27999 2 9491 -4963 -28023 2 9489 -4891 -28036 2 9533 -4766 -28043 2 9614 -4643 -28036 2 9674 -4517 -28036 2 9749 -4386 -28031 2 3662 25807 14853 0 3527 25809 14881 3 3506 25732 15019 3 3389 25705 15092 3 3365 25652 15187 3 3378 25577 15310 3 3431 25557 15332 3 3546 25596 15240 3 3675 25628 15156 3 3740 25685 15043 3 3732 25750 14933 3 -6841 -28848 -4579 0 -6930 -28808 -4696 2 -6919 -28789 -4828 2 -6963 -28753 -4978 2 -6963 -28727 -5123 2 -6843 -28743 -5198 2 -6761 -28781 -5096 2 -6761 -28806 -4951 2 -6735 -28837 -4805 2 -6753 -28857 -4657 2 10303 -4850 -27755 0 10300 -4960 -27737 2 10213 -5078 -27747 2 10074 -5117 -27791 2 9929 -5133 -27840 2 9761 -5138 -27899 2 9812 -5010 -27904 2 9940 -4925 -27874 2 10084 -4914 -27824 2 10211 -4865 -27786 2 27435 -3603 -11592 0 27458 -3673 -11514 2 27422 -3750 -11575 2 27366 -3761 -11704 2 27296 -3766 -11864 2 27251 -3718 -11982 2 27204 -3670 -12103 2 27218 -3597 -12093 2 27279 -3599 -11954 2 27339 -3599 -11817 2 27399 -3598 -11677 2 -19573 -21914 6055 0 -19614 -21842 6181 3 -19636 -21784 6314 3 -19608 -21767 6460 3 -19535 -21790 6600 3 -19581 -21743 6621 3 -19672 -21703 6479 3 -19659 -21755 6343 3 -19678 -21784 6184 3 -19671 -21807 6128 3 -19595 -21897 6048 3 -16090 -23678 8971 0 -16023 -23693 9051 2 -16018 -23638 9203 2 -16015 -23585 9341 2 -16083 -23473 9505 2 -16183 -23453 9384 2 -16264 -23458 9230 2 -16164 -23539 9200 2 -16109 -23601 9137 2 -16122 -23641 9009 2 -7427 29059 -664 0 -7506 29036 -766 2 -7600 29009 -828 2 -7735 28973 -849 2 -7837 28948 -751 2 -7918 28929 -629 2 -7887 28941 -490 2 -7733 28982 -472 2 -7591 29020 -489 2 -7461 29052 -567 2 22146 -6178 -19271 0 22086 -6105 -19363 2 22028 -5989 -19465 2 22083 -5859 -19442 2 22158 -5893 -19347 2 22265 -5913 -19217 2 22364 -5874 -19114 2 22383 -5952 -19068 2 22315 -6079 -19107 2 22219 -6161 -19193 2 13300 25127 9578 0 13329 25168 9428 3 13322 25224 9287 3 13345 25259 9161 3 13214 25348 9104 3 13174 25364 9117 3 13300 25272 9187 3 13286 25235 9310 3 13295 25186 9430 3 13266 25146 9576 3 13305 25103 9634 3 11562 21630 17276 0 11678 21590 17248 3 11818 21543 17211 3 11925 21501 17190 3 12139 21361 17214 3 12075 21425 17181 3 11954 21517 17150 3 11818 21608 17130 3 11686 21646 17172 3 11582 21653 17234 3 -25792 5633 14249 0 -25835 5621 14175 2 -25913 5566 14055 2 -25932 5385 14090 2 -26021 5277 13966 2 -25999 5245 14019 2 -25926 5246 14153 2 -25847 5277 14286 2 -25810 5414 14301 2 -25776 5592 14294 2 -11381 25287 -11447 0 -11325 25285 -11506 2 -11409 25217 -11574 2 -11523 25137 -11634 2 -11649 25066 -11662 2 -11814 24959 -11724 2 -11783 25017 -11633 2 -11697 25094 -11553 2 -11585 25175 -11489 2 -11467 25250 -11443 2 -17257 23572 6821 0 -17336 23540 6732 3 -17352 23563 6611 3 -17405 23525 6607 3 -17508 23431 6668 3 -17570 23353 6777 3 -17659 23259 6870 3 -17643 23267 6882 3 -17519 23350 6917 3 -17406 23426 6948 3 -17298 23518 6904 3 21029 -858 -21378 0 20947 -896 -21458 2 20843 -941 -21557 2 20735 -982 -21658 2 20569 -957 -21817 2 20644 -904 -21749 2 20750 -876 -21649 2 20859 -860 -21545 2 20967 -847 -21440 2 16710 18554 16629 0 16750 18473 16680 3 16827 18373 16711 3 16917 18256 16749 3 17031 18133 16767 3 17094 18194 16637 3 17020 18312 16583 3 16906 18388 16615 3 16831 18510 16556 3 -26154 13570 5641 0 -26142 13534 5783 2 -26164 13442 5895 2 -26202 13345 5948 2 -26293 13170 5937 2 -26260 13216 5977 2 -26190 13336 6020 2 -26153 13455 5915 2 -26132 13547 5797 2 -26146 13580 5655 2 -10691 -27735 4062 0 -10602 -27760 4120 2 -10655 -27717 4273 2 -10747 -27667 4361 2 -10850 -27618 4415 2 -10969 -27559 4492 2 -11013 -27547 4456 2 -10944 -27595 4329 2 -10846 -27649 4229 2 -10755 -27701 4124 2 5294 28803 -6509 0 5435 28765 -6562 2 5493 28751 -6575 2 5368 28744 -6707 2 5286 28730 -6831 2 5158 28731 -6923 2 5072 28774 -6806 2 5084 28807 -6655 2 5161 28822 -6529 2 -13366 24028 -12001 0 -13301 24004 -12121 2 -13359 23955 -12153 2 -13477 23886 -12158 2 -13599 23815 -12161 2 -13803 23720 -12118 2 -13746 23764 -12096 2 -13613 23832 -12112 2 -13505 23913 -12075 2 -13444 23979 -12010 2 -13524 26719 1794 0 -13573 26703 1653 2 -13632 26679 1550 2 -13761 26616 1493 2 -13888 26547 1539 2 -13877 26544 1687 2 -13780 26587 1796 2 -13670 26638 1881 2 -13542 26701 1912 2 -19280 22118 -6250 0 -19277 22155 -6126 3 -19302 22175 -5974 3 -19331 22185 -5842 3 -19367 22194 -5688 3 -19295 22260 -5675 3 -19296 22219 -5830 3 -19291 22189 -5961 3 -19260 22178 -6100 3 -19264 22139 -6226 3 -5809 29420 -843 0 -5941 29393 -855 2 -6105 29361 -799 2 -6240 29333 -784 2 -6263 29331 -696 2 -6180 29351 -553 2 -6026 29384 -539 2 -5913 29405 -634 2 -5801 29425 -740 2 -2866 4214 29564 0 -2943 4106 29572 3 -2969 3985 29586 3 -2995 3827 29604 3 -2854 3694 29635 3 -2800 3856 29619 3 -2871 3844 29614 3 -2919 3882 29604 3 -2891 4037 29586 3 -2871 4152 29572 3 16380 -17659 -17885 0 16303 -17573 -18039 2 16406 -17509 -18008 2 16503 -17464 -17963 2 16599 -17490 -17849 2 16694 -17522 -17728 2 16683 -17611 -17650 2 16572 -17652 -17714 2 16465 -17641 -17823 2 2405 29362 5664 0 2244 29361 5738 2 2299 29333 5855 2 2339 29293 6035 2 2506 29280 6033 2 2614 29285 5965 2 2641 29317 5794 2 2526 29334 5756 2 15812 18669 17362 0 15874 18668 17306 3 15995 18644 17221 3 16096 18626 17145 3 16044 18729 17083 3 16070 18834 16941 3 15985 18852 17003 3 15956 18800 17087 3 15849 18789 17199 3 15811 18720 17308 3 -22192 18429 -8241 0 -22216 18378 -8289 3 -22258 18273 -8409 3 -22303 18178 -8492 3 -22300 18084 -8698 3 -22331 18079 -8630 3 -22338 18144 -8472 3 -22275 18259 -8390 3 -22230 18365 -8279 3 11904 -3476 -27317 0 11852 -3559 -27329 2 11746 -3662 -27361 2 11644 -3775 -27389 2 11457 -3842 -27459 2 11505 -3770 -27449 2 11590 -3649 -27429 2 11704 -3561 -27392 2 11826 -3480 -27350 2 29712 544 -4112 0 29725 642 -4004 2 29737 767 -3887 2 29755 747 -3754 2 29757 689 -3749 2 29748 559 -3839 2 29738 462 -3930 2 29725 324 -4041 2 29713 416 -4120 2 9469 -5342 -27961 0 9393 -5406 -27974 2 9304 -5517 -27982 2 9181 -5593 -28008 2 8988 -5629 -28063 2 9008 -5520 -28078 2 9119 -5445 -28057 2 9259 -5405 -28019 2 9392 -5332 -27989 2 -4851 24586 -16492 0 -4739 24571 -16548 2 -4627 24536 -16631 2 -4550 24463 -16759 2 -4599 24400 -16837 2 -4716 24434 -16755 2 -4836 24462 -16680 2 -4991 24482 -16605 2 -4945 24527 -16552 2 24496 6480 -16061 0 24538 6288 -16073 2 24472 6317 -16162 2 24416 6245 -16275 2 24356 6147 -16401 2 24324 6213 -16424 2 24354 6333 -16334 2 24400 6423 -16230 2 24459 6494 -16111 2 -5809 29356 -2119 0 -5784 29353 -2221 2 -5774 29344 -2368 2 -5830 29322 -2499 2 -5984 29288 -2529 2 -6093 29273 -2438 2 -6091 29287 -2278 2 -5960 29318 -2219 2 -5880 29341 -2133 2 28373 6866 -6918 0 28389 6764 -6949 3 28388 6667 -7050 3 28379 6587 -7157 3 28358 6480 -7337 3 28348 6546 -7318 3 28355 6642 -7201 3 28346 6773 -7115 3 28353 6862 -7003 3 6654 -7693 -28223 0 6739 -7650 -28214 2 6702 -7836 -28172 2 6672 -7985 -28138 2 6566 -8073 -28138 2 6420 -8014 -28188 2 6444 -7870 -28223 2 6544 -7788 -28223 2 6632 -7769 -28208 2 23496 6501 17484 0 23553 6445 17428 2 23644 6399 17321 2 23731 6414 17196 2 23818 6490 17046 2 23766 6562 17091 2 23681 6575 17204 2 23597 6571 17321 2 23515 6560 17435 2 -6643 25925 -13555 0 -6574 25925 -13589 3 -6446 25914 -13673 3 -6341 25887 -13772 3 -6232 25861 -13870 3 -6303 25806 -13939 3 -6429 25827 -13843 3 -6526 25855 -13746 3 -6602 25902 -13620 3 -7497 28006 -7711 0 -7597 27995 -7653 2 -7735 27971 -7604 2 -7708 27985 -7580 2 -7631 28032 -7482 2 -7586 28090 -7307 2 -7482 28114 -7323 2 -7446 28079 -7491 2 -7434 28048 -7619 2 -20663 19947 -8671 0 -20672 19907 -8738 3 -20771 19796 -8757 3 -20881 19698 -8716 3 -20998 19601 -8653 3 -20990 19655 -8548 3 -20937 19719 -8533 3 -20835 19792 -8613 3 -20721 19885 -8673 3 4747 25258 15476 0 4732 25211 15557 2 4707 25135 15686 2 4675 25062 15812 2 4698 24971 15949 2 4737 24983 15919 2 4740 25062 15793 2 4752 25142 15662 2 4762 25219 15534 2 8037 27999 7173 0 8163 27962 7177 2 8233 27975 7045 2 8225 28017 6884 2 8158 28054 6814 2 8012 28089 6842 2 7915 28093 6939 2 7945 28049 7079 2 -8206 28777 -2132 0 -8117 28797 -2201 2 -8074 28797 -2348 2 -8149 28767 -2462 2 -8295 28730 -2405 2 -8471 28684 -2344 2 -8422 28706 -2239 2 -8300 28748 -2158 2 26623 -4311 -13138 0 26650 -4405 -13053 2 26656 -4566 -12985 2 26620 -4634 -13035 2 26536 -4635 -13204 2 26517 -4531 -13278 2 26514 -4384 -13333 2 26575 -4298 -13239 2 -19193 23050 547 0 -19196 23050 431 3 -19322 22946 352 3 -19413 22870 343 3 -19464 22825 436 3 -19496 22795 559 3 -19434 22845 631 3 -19303 22956 634 3 -19211 23035 595 3 -21968 17844 -9950 0 -22020 17699 -10094 3 -22085 17667 -10007 3 -22138 17678 -9868 3 -22237 17606 -9774 3 -22231 17617 -9769 3 -22126 17697 -9861 3 -22081 17689 -9976 3 -21995 17812 -9949 3 -9395 -28397 2317 0 -9398 -28383 2462 2 -9404 -28368 2613 2 -9454 -28338 2757 2 -9557 -28307 2712 2 -9543 -28324 2580 2 -9525 -28345 2417 2 -9481 -28371 2277 2 -23532 -559 18600 0 -23583 -699 18529 2 -23505 -689 18629 2 -23433 -577 18723 2 -23389 -466 18781 2 -23407 -313 18762 2 -23481 -331 18668 2 -23528 -460 18607 2 29597 -880 -4821 0 29608 -761 -4772 2 29622 -629 -4709 2 29637 -507 -4624 2 29655 -564 -4504 2 29649 -703 -4524 2 29633 -832 -4605 2 29612 -925 -4721 2 -4242 28374 8769 0 -4353 28355 8779 2 -4501 28336 8763 2 -4675 28288 8829 2 -4588 28277 8909 2 -4438 28287 8953 2 -4282 28307 8966 2 -4223 28352 8851 2 23521 18132 -4238 0 23543 18134 -4111 3 23628 18036 -4054 3 23690 17940 -4116 3 23692 17903 -4262 3 23674 17888 -4420 3 23598 17983 -4444 3 23545 18081 -4325 3 -12721 26335 -6680 0 -12620 26369 -6739 3 -12632 26332 -6860 3 -12611 26302 -7010 3 -12514 26313 -7142 3 -12536 26304 -7138 3 -12623 26295 -7018 3 -12655 26319 -6869 3 -12685 26338 -6736 3 28556 -1354 -9094 0 28560 -1477 -9062 2 28550 -1630 -9069 2 28508 -1644 -9198 2 28467 -1649 -9324 2 28454 -1504 -9388 2 28484 -1384 -9315 2 28528 -1340 -9186 2 -13304 26737 -2855 0 -13380 26703 -2820 3 -13457 26675 -2713 3 -13434 26697 -2611 3 -13289 26772 -2586 3 -13198 26825 -2494 3 -13149 26843 -2557 3 -13161 26825 -2683 3 -13256 26764 -2826 3 -4166 24261 -17148 0 -4087 24250 -17183 2 -4011 24198 -17274 2 -3978 24134 -17370 2 -3850 24074 -17482 2 -3902 24057 -17493 2 -4037 24098 -17407 2 -4142 24156 -17302 2 -4173 24225 -17197 2 22208 16310 -11865 0 22163 16312 -11947 3 22054 16390 -12042 3 21967 16539 -11996 3 22058 16490 -11895 3 22110 16382 -11948 3 22139 16390 -11884 3 22178 16393 -11807 3 22206 16389 -11760 3 22184 16338 -11872 3 18389 23461 -3379 0 18467 23403 -3362 3 18593 23301 -3370 3 18741 23181 -3376 3 18715 23192 -3448 3 18595 23283 -3482 3 18475 23375 -3505 3 18352 23480 -3446 3 -12115 27105 4305 0 -12042 27144 4265 3 -11944 27205 4151 3 -11886 27256 3977 3 -11963 27223 3977 3 -12097 27163 3979 3 -12192 27111 4045 3 -12123 27125 4154 3 -12115 27113 4255 3 22705 -5 -19608 0 22754 -24 -19551 2 22862 -80 -19425 2 22818 -168 -19476 2 22730 -143 -19579 2 22671 -158 -19647 2 22567 -178 -19766 2 22561 -79 -19773 2 22650 -22 -19672 2 -21304 20829 -3509 0 -21365 20762 -3537 3 -21454 20670 -3530 3 -21547 20588 -3446 3 -21644 20505 -3331 3 -21627 20522 -3337 3 -21542 20594 -3439 3 -21449 20677 -3520 3 -21361 20768 -3524 3 21301 -2864 -20930 0 21350 -2973 -20864 2 21345 -3114 -20850 2 21328 -3240 -20847 2 21220 -3300 -20948 2 21204 -3158 -20986 2 21204 -3028 -21006 2 21247 -2886 -20982 2 -3541 26084 -14390 0 -3450 26068 -14442 2 -3307 26026 -14550 2 -3391 25972 -14628 2 -3574 25935 -14650 2 -3684 25952 -14592 2 -3711 25996 -14506 2 -3627 26064 -14406 2 -17503 -23888 4794 0 -17405 -23951 4839 2 -17332 -23984 4938 2 -17242 -24024 5056 2 -17159 -24065 5140 2 -17206 -24032 5138 2 -17288 -23990 5063 2 -17377 -23949 4945 2 -17464 -23907 4848 2 -20659 21543 3021 0 -20679 21534 2947 2 -20689 21548 2768 2 -20719 21543 2574 2 -20753 21501 2648 2 -20775 21462 2794 2 -20781 21434 2955 2 -20712 21490 3037 2 24748 -885 -16934 0 24748 -998 -16928 2 24674 -1039 -17033 2 24588 -1005 -17158 2 24491 -967 -17299 2 24522 -911 -17258 2 24610 -882 -17135 2 24697 -860 -17010 2 22276 -3747 -19742 0 22324 -3853 -19667 2 22373 -3985 -19585 2 22387 -4091 -19546 2 22326 -4162 -19602 2 22270 -4057 -19687 2 22222 -3932 -19767 2 22229 -3776 -19789 2 -16881 -24201 5419 0 -16954 -24164 5354 2 -17029 -24132 5259 2 -17093 -24103 5185 2 -17033 -24162 5108 2 -16916 -24247 5093 2 -16907 -24232 5194 2 -16837 -24280 5195 2 -16802 -24288 5271 2 -16841 -24239 5369 2 -26588 12735 5561 0 -26640 12625 5560 2 -26704 12502 5531 2 -26736 12390 5629 2 -26710 12391 5746 2 -26650 12501 5789 2 -26609 12624 5708 2 -26570 12743 5625 2 15516 21285 -14359 0 15539 21320 -14283 3 15632 21329 -14168 3 15729 21251 -14178 3 15794 21145 -14262 3 15795 21066 -14378 3 15669 21129 -14425 3 15552 21229 -14404 3 7216 28601 -5469 0 7186 28582 -5607 2 7188 28551 -5759 2 7086 28564 -5820 2 7023 28603 -5705 2 7063 28622 -5559 2 7137 28626 -5441 2 7238 28609 -5399 2 3833 29553 3454 0 3835 29564 3360 2 3801 29582 3232 2 3812 29598 3065 2 3683 29614 3070 2 3711 29595 3220 2 3702 29580 3365 2 3753 29563 3453 2 8843 28172 5303 0 8930 28154 5253 2 9026 28139 5168 2 8944 28180 5088 2 8801 28218 5127 2 8645 28261 5158 2 8644 28240 5274 2 8757 28195 5325 2 21050 -381 -21372 0 20956 -450 -21463 2 20896 -570 -21518 2 20758 -603 -21650 2 20800 -490 -21613 2 20887 -392 -21531 2 20987 -362 -21434 2 3999 25672 14999 0 3947 25630 15084 3 3910 25561 15211 3 3907 25438 15415 3 3975 25486 15318 3 4009 25560 15185 3 4016 25626 15072 3 -26361 12892 6235 0 -26360 12825 6380 2 -26385 12717 6488 2 -26451 12584 6481 2 -26444 12579 6516 2 -26380 12719 6507 2 -26355 12825 6398 2 -26349 12904 6261 2 5148 25410 15094 0 5070 25383 15166 2 5022 25312 15300 2 5104 25186 15480 2 5183 25227 15387 2 5205 25294 15269 2 5192 25377 15134 2 24083 -4111 -17411 0 23997 -4125 -17525 2 23904 -4131 -17651 2 23825 -4049 -17776 2 23851 -3979 -17756 2 23933 -3994 -17642 2 24019 -4018 -17520 2 12234 -12996 -24113 0 12221 -12862 -24191 2 12195 -12735 -24272 2 12236 -12601 -24321 2 12274 -12603 -24300 2 12281 -12743 -24224 2 12292 -12856 -24158 2 12284 -12989 -24092 2 1263 19267 22961 0 1175 19245 22984 2 1017 19131 23086 2 1130 19054 23144 2 1275 19024 23161 2 1374 19135 23064 2 1289 19219 22999 2 24383 5280 -16661 0 24459 5240 -16562 2 24541 5139 -16472 2 24541 5027 -16506 2 24458 5005 -16636 2 24364 5074 -16753 2 24336 5200 -16755 2 -3500 28664 8132 0 -3601 28667 8076 2 -3688 28634 8155 2 -3656 28603 8277 2 -3510 28568 8460 2 -3436 28603 8369 2 -3461 28641 8229 2 10996 25265 11864 0 11110 25195 11908 3 11226 25113 11972 3 11278 25087 11977 3 11162 25184 11883 3 11088 25270 11767 3 11050 25316 11705 3 10978 25286 11836 3 -8489 -28676 2368 0 -8534 -28674 2233 2 -8434 -28711 2126 2 -8299 -28751 2122 2 -8174 -28778 2234 2 -8256 -28750 2301 2 -8386 -28707 2361 2 -8544 -28708 1696 0 -8608 -28679 1845 2 -8708 -28644 1927 2 -8807 -28616 1888 2 -8873 -28606 1722 2 -8768 -28639 1705 2 -8637 -28683 1644 2 -13684 26583 2464 0 -13786 26538 2388 2 -13923 26466 2387 2 -14021 26405 2485 2 -13964 26428 2567 2 -13835 26492 2601 2 -13708 26561 2576 2 -26462 13710 -3429 0 -26501 13633 -3440 2 -26571 13498 -3431 2 -26681 13293 -3381 2 -26639 13374 -3389 2 -26569 13504 -3422 2 -26499 13638 -3433 2 25177 -2424 -16132 0 25228 -2479 -16044 2 25243 -2599 -16001 2 25250 -2748 -15966 2 25200 -2804 -16034 2 25160 -2757 -16106 2 25147 -2621 -16148 2 25146 -2487 -16171 2 -3593 28752 7771 0 -3723 28726 7809 2 -3671 28701 7923 2 -3472 28705 7997 2 -3572 28730 7864 2 -3478 28728 7914 2 -3486 28745 7848 2 18992 23204 -949 0 19042 23166 -870 3 19118 23106 -769 3 19234 23008 -825 3 19245 22994 -957 3 19136 23079 -1078 3 19034 23167 -996 3 16204 715 25237 0 16285 721 25185 3 16426 677 25094 3 16435 748 25087 3 16492 864 25046 3 16421 862 25092 3 16295 817 25176 3 16173 788 25255 3 11947 21012 -17769 0 12037 20940 -17795 2 12231 20786 -17843 2 12131 20833 -17855 2 12002 20918 -17844 2 11861 20972 -17874 2 11867 21007 -17829 2 -16323 24985 3054 0 -16387 24948 3014 2 -16524 24860 2989 2 -16479 24874 3116 2 -16373 24938 3163 2 -16467 24877 3161 2 -16422 24905 3175 2 -16303 24983 3175 2 7459 26926 10924 0 7513 26882 10997 3 7635 26828 11044 3 7776 26741 11156 3 7765 26763 11112 3 7721 26826 10988 3 7681 26855 10945 3 7541 26911 10906 3 4421 25599 -15005 0 4258 25656 -14954 2 4109 25699 -14923 2 4130 25757 -14816 2 4307 25712 -14844 2 4392 25634 -14953 2 4462 25599 -14993 2 -3740 24124 -17437 0 -3639 24118 -17467 2 -3579 24047 -17577 2 -3476 23945 -17736 2 -3550 23952 -17712 2 -3642 24019 -17602 2 -3745 24077 -17501 2 1630 23899 18060 0 1623 23826 18157 3 1649 23747 18259 3 1801 23751 18239 3 1837 23825 18138 3 1752 23907 18038 3 1698 23966 17965 3 17320 22752 -9075 0 17418 22694 -9033 3 17544 22617 -8981 3 17636 22531 -9019 3 17620 22517 -9084 3 17502 22591 -9128 3 17388 22655 -9189 3 17355 22695 -9152 3 6068 25608 14403 0 5959 25597 14466 2 5878 25552 14579 2 5966 25456 14710 2 6004 25469 14673 2 6080 25509 14571 2 6168 25566 14434 2 17827 6043 23359 0 17858 6112 23318 3 17888 6242 23260 3 17817 6372 23280 3 17695 6347 23380 3 17678 6197 23433 3 17782 6111 23376 3 1364 -29308 -6258 0 1229 -29302 -6317 2 1253 -29279 -6416 2 1413 -29273 -6411 2 1529 -29264 -6423 2 1493 -29305 -6246 2 1443 -29323 -6169 2 -18191 -23193 5583 0 -18265 -23125 5622 3 -18278 -23063 5834 3 -18333 -23041 5743 3 -18425 -23007 5582 3 -18359 -23065 5564 3 -18244 -23153 5578 3 -5480 29422 -2079 0 -5514 29407 -2194 2 -5553 29387 -2359 2 -5618 29379 -2305 2 -5670 29379 -2176 2 -5696 29385 -2019 2 -5552 29413 -2008 2 -26312 13467 5132 0 -26326 13403 5224 2 -26288 13423 5364 2 -26225 13467 5557 2 -26230 13485 5489 2 -26262 13490 5322 2 -26311 13440 5204 2 22241 13603 14842 0 22193 13609 14909 2 22130 13563 15044 2 22075 13455 15220 2 22122 13450 15156 2 22189 13486 15026 2 22228 13557 14903 2 -10783 26096 -10136 0 -10856 26061 -10147 3 -10996 26008 -10134 3 -11189 25915 -10161 3 -11137 25950 -10127 3 -11004 26011 -10118 3 -10861 26064 -10135 3 29783 1256 -3378 0 29787 1324 -3316 2 29796 1412 -3194 2 29807 1499 -3045 2 29813 1403 -3033 2 29802 1338 -3169 2 29791 1251 -3304 2 -17758 24025 2727 0 -17787 24019 2591 2 -17874 23960 2539 2 -17910 23915 2700 2 -17915 23890 2888 2 -17800 23981 2839 2 -23952 18049 730 0 -24007 17974 772 3 -24094 17855 810 3 -24203 17707 838 3 -24168 17753 865 3 -24082 17871 828 3 -23997 17987 783 3 -1959 8253 28776 0 -2044 8220 28779 3 -2153 8138 28795 3 -2157 8014 28829 3 -2103 7933 28856 3 -2141 8143 28794 3 -2032 8214 28782 3 24446 -969 -17363 0 24388 -1010 -17442 2 24298 -1004 -17567 2 24193 -976 -17713 2 24218 -945 -17680 2 24308 -942 -17556 2 24398 -945 -17431 2 2887 27868 10725 0 2967 27892 10640 2 3060 27912 10563 2 3067 27965 10418 2 3008 27944 10493 2 2954 27969 10440 2 2915 27943 10521 2 2890 27898 10646 2 21419 -3233 -20756 0 21395 -3352 -20761 2 21407 -3475 -20729 2 21356 -3587 -20762 2 21281 -3502 -20853 2 21283 -3385 -20870 2 21367 -3277 -20802 2 20078 -7369 -21038 0 20021 -7376 -21089 2 19904 -7400 -21192 2 19900 -7339 -21216 2 19922 -7209 -21240 2 19969 -7135 -21221 2 20044 -7154 -21143 2 20063 -7293 -21078 2 10608 21446 -18098 0 10453 21517 -18104 2 10323 21591 -18090 2 10282 21640 -18056 2 10461 21565 -18042 2 10590 21494 -18051 2 10655 21440 -18077 2 16151 -1050 -25260 0 16224 -1051 -25213 2 16346 -1027 -25135 2 16495 -1088 -25034 2 16434 -1132 -25073 2 16296 -1144 -25162 2 16177 -1082 -25242 2 6256 -8530 -28073 0 6167 -8540 -28090 2 6097 -8470 -28126 2 6225 -8357 -28132 2 6335 -8248 -28139 2 6377 -8317 -28110 2 6288 -8426 -28098 2 21026 13541 -16569 0 21111 13472 -16518 2 21186 13403 -16477 2 21295 13249 -16462 2 21240 13292 -16497 2 21146 13390 -16539 2 21039 13485 -16599 2 -18859 -22602 5789 0 -18753 -22656 5917 3 -18802 -22607 5950 3 -18942 -22492 5941 3 -18895 -22540 5908 3 -18990 -22473 5858 3 -18942 -22524 5819 3 -18897 -22577 5762 3 13656 23661 12396 0 13688 23703 12280 3 13634 23780 12191 3 13597 23872 12052 3 13579 23868 12080 3 13618 23786 12198 3 13648 23704 12322 3 8006 23007 -17510 0 7855 23063 -17504 2 7734 23149 -17444 2 7751 23202 -17366 2 7909 23112 -17416 2 8038 23054 -17433 2 3087 24735 16693 0 2904 24716 16754 2 2976 24631 16866 2 3080 24593 16902 2 3198 24626 16832 2 3165 24707 16719 2 -12618 24857 -11088 0 -12616 24812 -11190 2 -12669 24738 -11292 2 -12755 24707 -11265 2 -12794 24688 -11260 2 -12854 24666 -11241 2 -12811 24743 -11121 2 -12697 24822 -11075 2 -11749 25130 -11421 0 -11784 25081 -11492 2 -11894 25005 -11545 2 -11984 24923 -11628 2 -11997 24952 -11552 2 -11931 25029 -11454 2 -11852 25089 -11405 2 25018 -660 -16543 0 25084 -664 -16442 2 25163 -623 -16323 2 25190 -770 -16275 2 25104 -777 -16407 2 25026 -758 -16527 2 -15854 -24577 6681 0 -15934 -24552 6579 2 -16000 -24553 6417 2 -15916 -24614 6391 2 -15830 -24642 6496 2 -15768 -24646 6630 2 -17115 24557 -2011 0 -17119 24547 -2095 3 -17152 24511 -2241 3 -17184 24475 -2389 3 -17213 24457 -2361 3 -17182 24492 -2224 3 -17139 24533 -2095 3 11398 -4172 -27435 0 11468 -4286 -27388 2 11351 -4344 -27428 2 11215 -4449 -27467 2 11234 -4322 -27479 2 11320 -4219 -27460 2 -7436 14318 25292 0 -7574 14260 25284 2 -7657 14199 25294 2 -7564 14103 25375 2 -7447 14209 25350 2 -7349 14319 25317 2 23814 -745 -18231 0 23819 -838 -18220 2 23745 -898 -18313 2 23622 -862 -18473 2 23677 -749 -18407 2 23765 -720 -18295 2 -1698 25570 15597 0 -1786 25547 15625 2 -1901 25497 15694 2 -1932 25409 15832 2 -1812 25443 15791 2 -1719 25508 15696 2 -11912 25153 -11200 0 -11790 25170 -11291 2 -11855 25112 -11351 2 -11998 25019 -11406 2 -12028 25061 -11282 2 -12006 25116 -11184 2 -20089 -9689 20064 0 -20155 -9600 20040 3 -20231 -9447 20036 3 -20249 -9528 19980 3 -20180 -9655 19989 3 -20180 -9738 19948 3 -20141 -9747 19984 3 22251 15516 -12811 0 22247 15429 -12924 3 22161 15455 -13039 3 22141 15509 -13009 3 22106 15644 -12907 3 22178 15629 -12802 3 -6458 14255 25595 0 -6554 14149 25629 2 -6559 14123 25642 2 -6403 14187 25646 2 -6314 14292 25610 2 -6346 14389 25548 2 24489 -4261 -16797 0 24479 -4353 -16788 2 24390 -4387 -16909 2 24298 -4332 -17053 2 24353 -4261 -16994 2 24441 -4260 -16867 2 -3316 28682 8146 0 -3415 28695 8058 2 -3595 28686 8012 2 -3560 28673 8075 2 -3446 28656 8184 2 -3342 28652 8241 2 23528 1053 -18582 0 23461 1092 -18665 2 23408 1221 -18724 2 23439 1344 -18676 2 23521 1263 -18578 2 23545 1131 -18556 2 -6353 29317 -386 0 -6339 29319 -493 2 -6342 29315 -643 2 -6460 29289 -661 2 -6493 29285 -499 2 -6452 29295 -385 2 23124 -10704 15834 0 23036 -10724 15948 2 22999 -10847 15919 2 23044 -10922 15802 2 23131 -10866 15712 2 23142 -10770 15762 2 -10965 -27064 6879 0 -10940 -27048 6980 2 -11007 -26992 7089 2 -11149 -26948 7036 2 -11169 -26971 6914 2 -11039 -27037 6868 2 4917 27988 9617 0 5013 27967 9629 3 5100 27981 9543 3 5064 28053 9347 3 5010 28046 9399 3 4950 28007 9545 3 -11542 -27125 5570 0 -11473 -27141 5635 2 -11467 -27105 5817 2 -11576 -27051 5852 2 -11632 -27046 5766 2 -11584 -27093 5638 2 22858 -880 -19409 0 22912 -904 -19345 2 23022 -972 -19210 2 22961 -1059 -19279 2 22862 -1052 -19397 2 22839 -961 -19428 2 -27648 11150 3354 0 -27687 11048 3371 2 -27711 10974 3414 2 -27675 11016 3573 2 -27626 11142 3557 2 -27621 11197 3417 2 4612 1962 29578 0 4518 1931 29595 2 4427 1799 29617 2 4460 1694 29618 2 4570 1751 29598 2 4642 1891 29578 2 -1839 23767 -18214 0 -1796 23716 -18284 2 -1612 23658 -18376 2 -1690 23650 -18381 2 -1814 23669 -18344 2 -1890 23729 -18258 2 -26596 11995 6985 0 -26635 11856 7071 2 -26664 11771 7104 2 -26662 11721 7194 2 -26631 11857 7086 2 -26593 11984 7013 2 23795 -164 -18269 0 23841 -219 -18208 2 23812 -377 -18245 2 23716 -430 -18367 2 23734 -356 -18345 2 23759 -226 -18315 2 -22867 -15404 11824 0 -22826 -15380 11935 3 -22834 -15304 12017 3 -22916 -15247 11933 3 -22969 -15289 11776 3 -22920 -15374 11760 3 11693 24510 -12748 0 11629 24490 -12845 2 11504 24578 -12789 2 11546 24618 -12675 2 11682 24554 -12674 2 11749 24509 -12699 2 -11168 -26833 7435 0 -11150 -26813 7534 2 -11068 -26812 7657 2 -11110 -26778 7713 2 -11217 -26762 7614 2 -11231 -26799 7460 2 -13936 24051 -11284 0 -14010 23975 -11354 2 -14070 23913 -11412 2 -14166 23881 -11358 2 -14150 23934 -11268 2 -14032 24014 -11244 2 29225 434 -6762 0 29243 495 -6680 2 29273 556 -6542 2 29289 494 -6472 2 29273 413 -6551 2 29236 396 -6718 2 -3608 -29413 4678 0 -3700 -29407 4641 2 -3899 -29404 4497 2 -3803 -29410 4540 2 -3678 -29413 4618 2 27658 11617 -322 0 27692 11536 -286 2 27776 11329 -338 2 27740 11414 -417 2 27687 11546 -384 2 -2705 -28959 7352 0 -2729 -28937 7430 2 -2844 -28880 7605 2 -2910 -28904 7491 2 -2771 -28942 7394 2 -15874 23873 -8837 0 -15942 23833 -8822 3 -16163 23707 -8761 3 -16069 23763 -8780 3 -15941 23838 -8811 3 -22981 137 19284 0 -23077 108 19168 2 -23073 27 19173 2 -22966 -8 19302 2 -22904 106 19376 2 -7340 25545 -13913 0 -7253 25554 -13941 2 -7179 25516 -14050 2 -7181 25466 -14139 2 -7294 25470 -14073 2 -7377 25507 -13963 2 1932 28169 -10137 0 2074 28188 -10055 2 2162 28154 -10132 2 2057 28120 -10250 2 1942 28131 -10242 2 -2239 29202 6500 0 -2266 29182 6578 2 -2312 29124 6816 2 -2271 29149 6722 2 -2229 29185 6578 2 -24505 2604 17110 0 -24555 2505 17052 3 -24575 2383 17040 3 -24485 2402 17168 3 -24450 2531 17199 3 -20336 -21189 6121 0 -20347 -21152 6211 2 -20408 -21067 6302 2 -20487 -21004 6255 2 -20468 -21052 6154 2 -20397 -21137 6101 2 4254 3683 -29468 0 4574 3708 -29416 2 4411 3692 -29443 2 4306 3652 -29464 2 4284 29586 2515 0 4343 29586 2410 2 4257 29610 2263 2 4159 29616 2362 2 4179 29604 2474 2 -26886 10733 7871 0 -26857 10721 7985 2 -26772 10821 8134 2 -26796 10837 8035 2 -26847 10809 7900 2 -13498 24234 -11425 0 -13603 24169 -11437 2 -13772 24084 -11415 2 -13704 24146 -11364 2 -13569 24214 -11383 2 22043 16210 -12301 0 21987 16242 -12359 3 21917 16376 -12307 3 21981 16378 -12190 3 21948 16374 -12256 3 21996 16289 -12282 3 22450 -6144 -18928 0 22339 -6114 -19068 2 22394 -5962 -19052 2 22453 -5946 -18987 2 22468 -6083 -18926 2 20013 16577 -14989 0 20065 16571 -14926 2 20205 16488 -14829 2 20157 16444 -14943 2 20033 16517 -15028 2 8227 28696 2972 0 8212 28719 2784 2 8113 28748 2779 2 8047 28756 2886 2 8158 28716 2972 2 -6380 29120 -3367 0 -6408 29102 -3469 2 -6521 29059 -3610 2 -6539 29070 -3486 2 -6438 29107 -3369 2 23793 -10289 15101 0 23699 -10405 15169 2 23686 -10502 15121 2 23780 -10446 15013 2 23819 -10349 15019 2 18853 -3180 23118 0 18901 -3297 23063 2 18968 -3281 23010 2 18932 -3124 23061 2 18895 -3044 23102 2 -2898 29718 2905 0 -2792 29737 2818 2 -2798 29752 2644 2 -2893 29738 2699 2 -2913 29722 2848 2 4133 24673 -16558 0 4155 24634 -16610 2 4106 24558 -16734 2 4025 24530 -16795 2 4068 24641 -16622 2 -17359 23518 6748 0 -17465 23458 6687 2 -17532 23383 6774 2 -17444 23419 6873 2 -17362 23483 6864 2 24745 -5658 -15990 0 24675 -5633 -16106 2 24627 -5515 -16219 2 24669 -5498 -16162 2 24723 -5579 -16051 2 -6134 29314 -1752 0 -6252 29288 -1762 2 -6418 29255 -1723 2 -6342 29275 -1665 2 -6198 29304 -1692 2 -18455 -22892 5946 0 -18536 -22842 5888 3 -18625 -22804 5752 3 -18572 -22857 5713 3 -18496 -22884 5851 3 7506 28869 -3200 0 7392 28904 -3154 2 7455 28902 -3013 2 7565 28873 -3018 2 7586 28854 -3142 2 -19149 -22531 5067 0 -19218 -22464 5106 2 -19374 -22341 5054 2 -19308 -22407 5013 2 -19200 -22493 5043 2 -11154 10714 -25706 0 -11240 10578 -25725 2 -11378 10594 -25658 2 -11339 10688 -25636 2 -11977 -26541 7220 0 -11942 -26527 7327 2 -11921 -26490 7494 2 -12001 -26474 7422 2 -12012 -26509 7281 2 12975 18669 19573 0 12986 18730 19508 3 12861 18855 19471 3 12799 18802 19562 3 12908 18705 19583 3 -10778 27815 3183 0 -10775 27829 3071 2 -10812 27825 2976 2 -10915 27778 3045 2 -10863 27780 3206 2 5802 24352 16532 0 5856 24373 16483 2 5972 24457 16315 2 5899 24444 16362 2 5808 24383 16484 2 10271 19027 20796 0 10166 18984 20887 2 10252 18927 20896 2 10390 18890 20862 2 10365 18962 20809 2 -3812 -7158 -28883 0 -3923 -7135 -28874 2 -3910 -7011 -28906 2 -3733 -7013 -28929 2 -3745 -7106 -28905 2 -26344 13706 4261 0 -26392 13637 4185 3 -26439 13541 4200 3 -26435 13510 4322 3 -26361 13649 4335 3 4332 -21849 -20096 0 4358 -21992 -19934 2 4207 -21972 -19989 2 4236 -21901 -20060 2 11385 17811 21287 0 11313 17770 21360 2 11297 17649 21468 2 11391 17660 21410 2 11419 17767 21306 2 -25127 12810 -10224 0 -25152 12740 -10250 2 -25207 12608 -10277 2 -25238 12542 -10283 2 -25154 12745 -10240 2 12061 -19379 -19468 0 12066 -19320 -19523 2 12195 -19209 -19552 2 12252 -19233 -19494 2 12153 -19341 -19448 2 14601 -4888 -25747 0 14568 -4993 -25746 2 14427 -5040 -25816 2 14403 -4973 -25842 2 14511 -4900 -25796 2 3182 28027 10215 0 3267 28052 10121 2 3204 28102 10002 2 3120 28082 10082 2 3120 28037 10207 2 24760 -13205 -10611 0 24808 -13122 -10602 2 24903 -12966 -10571 2 24892 -13015 -10537 2 24812 -13138 -10571 2 22676 -468 -19636 0 22732 -514 -19570 2 22714 -646 -19588 2 22638 -667 -19674 2 22633 -508 -19685 2 -8077 26065 -12464 0 -8053 26040 -12533 2 -8030 25957 -12718 2 -8085 25964 -12670 2 -8098 26027 -12530 2 -16783 -24152 5918 0 -16710 -24223 5833 2 -16592 -24312 5802 2 -16622 -24273 5877 2 -16720 -24192 5930 2 3471 29597 3461 0 3568 29591 3416 2 3608 29605 3248 2 3528 29615 3245 2 3487 29604 3383 2 -23913 14805 -10440 0 -23958 14729 -10443 2 -24076 14600 -10353 2 -24045 14666 -10331 2 -23953 14772 -10394 2 -13537 24149 -11558 0 -13615 24102 -11564 2 -13770 24029 -11533 2 -13751 24067 -11476 2 -13618 24129 -11503 2 25723 -3019 -15140 0 25725 -3100 -15120 2 25701 -3299 -15119 2 25688 -3244 -15152 2 25703 -3094 -15159 2 18791 -8648 -21728 0 18744 -8620 -21779 2 18643 -8526 -21903 2 18717 -8493 -21853 2 18790 -8572 -21759 2 -8993 -28620 -183 0 -8904 -28647 -233 2 -8756 -28693 -211 2 -8757 -28693 -159 2 -8896 -28650 -131 2 -8768 -28641 -1673 0 -8745 -28654 -1578 2 -8777 -28652 -1427 2 -8847 -28628 -1473 2 -8831 -28625 -1626 2 16062 838 25324 0 16111 858 25292 3 16278 941 25182 3 16195 931 25236 3 16079 876 25312 3 -26157 14015 4405 0 -26187 13948 4434 2 -26264 13777 4517 2 -26242 13824 4499 2 -26185 13951 4441 2 21813 15801 -13211 0 21811 15743 -13282 2 21759 15677 -13446 2 21748 15724 -13407 2 21774 15796 -13281 2 -19641 22184 4702 0 -19717 22128 4647 3 -19827 22011 4732 3 -19775 22051 4761 3 -19697 22134 4702 3 15005 -1299 -25945 0 14946 -1352 -25977 2 14822 -1393 -26046 2 14814 -1291 -26055 2 14947 -1268 -25980 2 -10453 11094 -25839 0 -10386 11051 -25885 2 -10387 10949 -25927 2 -10538 10922 -25878 2 -10506 11030 -25845 2 -26735 12315 5795 0 -26781 12233 5756 2 -26818 12106 5853 2 -26783 12153 5915 2 -26743 12273 5848 2 -16802 23231 -8833 0 -16821 23187 -8911 3 -16960 23063 -8969 3 -16927 23096 -8947 3 -16826 23192 -8889 3 14422 -5109 -25805 0 14343 -5223 -25826 2 14218 -5259 -25888 2 14275 -5196 -25869 2 14387 -5111 -25824 2 10064 -5982 -27621 0 9996 -6042 -27633 2 9837 -6118 -27673 2 9853 -6071 -27678 2 9984 -6001 -27646 2 24783 -4317 -16345 0 24789 -4391 -16317 2 24747 -4466 -16360 2 24679 -4341 -16496 2 24735 -4327 -16415 2 -13180 26791 2922 0 -13128 26823 2864 2 -13126 26839 2717 2 -13216 26793 2737 2 -13242 26766 2870 2 -1749 25344 15957 0 -1843 25298 16019 2 -1724 25220 16156 2 -1727 25278 16063 2 -26328 14008 -3259 0 -26355 13942 -3321 2 -26421 13795 -3407 2 -26407 13829 -3380 2 -26355 13947 -3303 2 24089 7261 -16340 0 24137 7079 -16350 2 24066 7087 -16451 2 24046 7223 -16419 2 -7194 13999 25540 0 -7065 14003 25573 2 -7046 14131 25508 2 -7177 14118 25479 2 -24613 17122 1025 0 -24616 17111 1133 3 -24647 17056 1271 3 -24636 17071 1274 3 -24605 17125 1139 3 20152 -5943 21414 0 20130 -6048 21406 2 20152 -6167 21351 2 20197 -6130 21319 2 20191 -5970 21371 2 -1915 23677 -18322 0 -2006 23657 -18339 2 -2179 23660 -18316 2 -2137 23675 -18301 2 -1995 23680 -18310 2 -23760 17289 6048 0 -23713 17329 6115 2 -23624 17450 6118 2 -23604 17477 6114 2 -23716 17330 6101 2 -14558 23775 -11081 0 -14543 23744 -11167 2 -14555 23670 -11309 2 -14595 23665 -11268 2 -14591 23734 -11126 2 -12479 24643 -11704 0 -12534 24593 -11752 2 -12686 24504 -11774 2 -12669 24530 -11738 2 -12549 24604 -11711 2 5264 29534 -120 0 5346 29519 -241 2 5223 29540 -301 2 5181 29549 -141 2 13262 -5908 -26253 0 13197 -5980 -26269 2 13060 -6036 -26325 2 13067 -5982 -26334 2 13198 -5922 -26282 2 -20288 22087 756 0 -20269 22106 675 2 -20387 22002 550 2 -20358 22025 660 2 19086 -2847 22970 0 19124 -2792 22945 2 19150 -2643 22941 2 19104 -2610 22983 2 19082 -2759 22984 2 -2873 28899 7523 0 -3006 28886 7523 2 -2992 28856 7640 2 -2848 28868 7650 2 15596 18597 -17633 0 15663 18554 -17619 2 15752 18439 -17660 2 15707 18421 -17718 2 15641 18517 -17677 2 -28925 7951 348 0 -28916 7978 426 3 -28881 8099 542 3 -28882 8098 507 3 -28906 8019 355 3 9541 23385 16190 0 9539 23335 16263 3 9618 23226 16371 3 9637 23245 16333 3 9584 23342 16226 3 29210 473 -6823 0 29225 550 -6751 2 29256 585 -6613 2 29254 529 -6626 2 29224 461 -6764 2 -25829 15180 1561 0 -25833 15182 1475 2 -25856 15158 1300 2 -25855 15158 1331 2 -25835 15177 1479 2 -20000 22355 530 0 -20025 22333 455 2 -20094 22274 312 2 -20109 22260 359 2 -20045 22315 482 2 -444 -28368 9750 0 -392 -28333 9853 2 -553 -28311 9907 2 -531 -28358 9775 2 2286 29384 5600 0 2178 29406 5527 2 2114 29387 5651 2 2212 29368 5710 2 -9750 11346 -26004 0 -9636 11283 -26074 2 -9729 11192 -26078 2 -9817 11257 -26018 2 29357 1075 -6086 0 29383 1063 -5961 2 29386 930 -5968 2 29361 950 -6086 2 -4180 -7285 -28800 0 -4276 -7279 -28788 2 -4264 -7212 -28806 2 -4091 -7177 -28840 2 -4112 -7256 -28817 2 21812 -2819 -20403 0 21855 -3035 -20326 2 21825 -2974 -20367 2 21786 -2842 -20427 2 -6475 29293 -129 0 -6612 29262 -75 2 -6578 29270 27 2 -6448 29299 -30 2 -9851 -28219 2574 0 -9871 -28201 2699 2 -9994 -28163 2638 2 -9940 -28192 2525 2 6163 -10670 -27353 0 6247 -10640 -27345 2 6239 -10762 -27299 2 6109 -10797 -27315 2 24033 10600 14493 0 24032 10539 14540 2 24028 10423 14630 2 24057 10407 14593 2 24056 10526 14509 2 -10404 28061 2080 0 -10572 28003 2015 2 -10557 28003 2098 2 -10408 28055 2142 2 -6287 25435 -14613 0 -6462 25370 -14650 3 -6495 25390 -14600 3 -6386 25444 -14554 3 3313 24533 16946 0 3385 24479 17010 2 3522 24487 16969 2 3439 24536 16917 2 -17749 22168 9672 0 -17804 22146 9621 2 -17938 22062 9566 2 -17903 22076 9599 2 -17793 22145 9644 2 -24211 14614 -10014 0 -24256 14513 -10051 2 -24317 14469 -9967 2 -24240 14620 -9934 2 6168 20534 20984 0 6246 20515 20979 2 6401 20506 20942 2 6387 20517 20935 2 6239 20536 20960 2 25249 3517 -15816 0 25303 3462 -15741 2 25271 3358 -15814 2 25210 3456 -15891 2 24510 6812 -15901 0 24507 6742 -15936 2 24460 6643 -16049 2 24453 6659 -16053 2 24485 6769 -15959 2 8900 28579 2013 0 8872 28597 1868 2 8774 28626 1885 2 8822 28603 2014 2 -19110 -22514 5287 0 -19244 -22402 5271 2 -19210 -22449 5198 2 -19133 -22517 5191 2 -26431 12476 6763 0 -26484 12303 6875 2 -26463 12328 6907 2 -26435 12448 6801 2 -6923 29146 -1603 0 -6934 29136 -1738 2 -7020 29115 -1739 2 -7008 29127 -1586 2 -7322 29032 -1885 0 -7415 29003 -1956 2 -7499 28987 -1872 2 -7383 29021 -1818 2 3874 29626 2697 0 4032 29612 2626 2 3970 29623 2587 2 3830 29635 2662 2 -20399 -10562 19296 0 -20446 -10508 19275 3 -20549 -10426 19211 3 -20545 -10458 19198 3 -20473 -10519 19241 3 -12040 -26645 6714 0 -11949 -26652 6846 2 -12006 -26618 6881 2 -12085 -26621 6730 2 -8141 28851 -1154 0 -8185 28832 -1303 2 -8252 28814 -1284 2 -8206 28833 -1135 2 -26611 11542 7659 0 -26699 11385 7586 2 -26673 11408 7644 2 -26603 11533 7698 2 -25420 7629 13987 0 -25396 7510 14095 2 -25357 7594 14119 2 -25378 7674 14038 2 -361 26098 14791 0 -371 26034 14902 2 -317 26006 14952 2 -291 26088 14810 2 -10298 18382 21356 0 -10168 18355 21441 2 -10119 18401 21425 2 -10266 18414 21344 2 -6714 29188 -1727 0 -6808 29164 -1756 2 -6881 29154 -1648 2 -6767 29180 -1655 2 -14486 -9145 -24628 0 -14593 -9168 -24556 2 -14593 -9096 -24583 2 -14489 -9056 -24659 2 -12116 27417 1220 0 -12261 27347 1354 2 -12188 27380 1337 2 12149 -27337 -2254 0 12141 -27334 -2336 2 12232 -27288 -2395 2 12218 -27307 -2242 2 4304 29609 2188 0 4256 29629 2003 2 4218 29626 2127 2 -12276 24972 -11211 0 -12280 24929 -11301 2 -12410 24872 -11286 2 -12336 24932 -11236 2 3993 24360 17048 0 4099 24362 17021 2 4044 24442 16919 2 3988 24414 16972 2 4361 29555 2736 0 4323 29569 2645 2 4207 29585 2647 2 4282 29565 2748 2 -18479 -23127 4866 0 -18531 -23060 4984 2 -18592 -23025 4918 2 -18533 -23087 4847 2 2259 21690 20602 0 2422 21730 20541 3 2371 21760 20515 3 2252 21712 20579 3 20331 14288 -16807 0 20444 14226 -16723 2 20446 14175 -16764 2 20330 14262 -16831 2 -16786 -24244 5517 0 -16799 -24258 5419 2 -16684 -24335 5429 2 -16720 -24294 5499 2 -1657 25010 16486 0 -1764 25041 16427 2 -1791 24982 16513 2 -1685 24973 16538 2 -1331 -20857 -21523 0 -1363 -20770 -21604 2 -1351 -20739 -21635 2 -1257 -20781 -21600 2 -26552 5728 12735 0 -26466 5718 12917 2 -26507 5748 12819 2 -11118 27856 637 0 -11288 27788 642 2 -11206 27820 705 2 2831 -28218 9783 0 2873 -28191 9850 2 2774 -28176 9920 2 2755 -28216 9812 2 23950 2362 -17911 0 23970 2183 -17907 2 23926 2265 -17956 2 29304 688 -6390 0 29307 537 -6387 2 29289 555 -6469 2 -9197 -28136 4878 0 -9356 -28068 4963 2 -9281 -28105 4899 2 -10259 28140 1705 0 -10315 28115 1768 2 -10253 28132 1869 2 -10219 28149 1793 2 29280 766 -6487 0 29314 808 -6329 2 29291 712 -6445 2 6865 26520 12229 0 6827 26505 12283 2 6870 26449 12379 2 6920 26480 12286 2 13499 -19327 -18554 0 13544 -19192 -18661 2 13557 -19272 -18568 2 16732 5918 24187 0 16609 6049 24240 3 16659 5965 24226 3 13670 -4696 -26288 0 13524 -4767 -26351 2 13584 -4682 -26336 2 2313 23926 -17950 0 2152 23910 -17991 2 2232 23957 -17919 2 3781 28274 9290 0 3874 28308 9144 2 3783 28302 9202 2 25584 3122 -15352 0 25499 3096 -15499 2 25516 3155 -15460 2 29702 3744 -1936 0 29719 3591 -1971 2 29704 3680 -2026 2 24789 6574 -15566 0 24854 6405 -15532 2 24802 6507 -15572 2 -29247 6430 1802 0 -29258 6345 1924 3 -29241 6417 1947 3 -6095 14636 25468 0 -6230 14541 25490 2 -6133 14548 25510 2 -10821 10826 -25801 0 -10988 10803 -25740 2 -10923 10844 -25751 2 29023 590 -7570 0 29057 585 -7441 2 29038 490 -7520 2 23976 5439 -17192 0 24015 5262 -17193 2 23982 5349 -17211 2 5247 29038 -5412 0 5148 29074 -5312 2 5174 29074 -5284 2 5271 29042 -5365 2 -18202 -23335 4919 0 -18187 -23330 4992 2 -18249 -23268 5060 2 -18247 -23290 4960 2 5756 -9056 -28015 0 5813 -9140 -27976 2 5683 -9150 -27999 2 -11472 -27071 5962 0 -11561 -27004 6094 2 -11547 -27029 6008 2 -12893 26395 6088 0 -12940 26398 5975 2 -12990 26348 6087 2 5886 -8242 -28239 0 5912 -8076 -28281 2 5936 -8143 -28257 2 8245 18657 21999 0 8220 18598 22058 2 8293 18532 22086 2 8295 18602 22026 2 5232 21275 20494 0 5290 21152 20606 2 5277 21221 20538 2 -16253 -24546 5776 0 -16262 -24567 5656 2 -16186 -24610 5689 2 -16198 -24587 5751 2 9502 25942 11694 0 9667 25877 11702 3 9592 25912 11687 3 -12159 27406 1045 0 -12300 27340 1104 2 -12212 27379 1116 2 5425 21100 20624 0 5560 21006 20684 2 5490 21064 20644 2 3389 22127 19973 0 3245 22196 19920 3 3273 22154 19962 3 -29998 -271 -211 0 -29997 -374 -238 2 -29998 -330 -114 2 -6646 3953 28986 0 -6492 3918 29026 2 -6558 3982 29003 2 17776 -4397 -23763 0 17651 -4491 -23839 2 17710 -4430 -23806 2 15919 -2901 -25262 0 15833 -3014 -25303 2 15835 -2911 -25313 2 10276 18702 21087 0 10310 18587 21171 2 10359 18635 21106 2 -27182 9729 8156 0 -27158 9666 8308 2 -27158 9737 8225 2 -5062 29557 -877 0 -5213 29531 -862 2 -5111 29550 -815 2 5323 -9639 -27906 0 5417 -9646 -27886 2 5302 -9737 -27876 2 9566 21962 -18060 0 9646 21902 -18090 2 9500 21989 -18062 2 7782 19198 21700 0 7880 19084 21765 2 7857 19158 21708 2 -25374 8277 13699 0 -25337 8409 13687 2 -25385 8366 13624 2 -21077 21320 1096 0 -21183 21219 1014 2 -21130 21269 1084 2 24281 -1036 -17589 0 24260 -1202 -17607 2 24259 -1106 -17615 2 -22788 37 19512 0 -22873 -15 19412 2 -22790 -35 19509 2 5240 28832 -6422 0 5171 28868 -6319 2 5290 28837 -6358 2 -7468 -28825 -3652 0 -7341 -28848 -3725 2 -7367 -28853 -3642 2 24788 6981 -15389 0 24760 6890 -15474 2 24733 7001 -15468 2 -23208 -6 19010 0 -23288 -88 18912 2 -23214 -74 19003 2 -2403 29024 7200 0 -2397 28986 7353 2 -2360 29012 7263 2 -8354 27070 9869 0 -8323 27133 9722 2 -8362 27102 9775 2 25819 2792 -15019 0 25887 2702 -14919 2 25831 2718 -15012 2 -13037 26839 3117 0 -13001 26872 2978 2 -13072 26830 3050 2 19424 15377 -16920 0 19517 15245 -16932 2 19453 15309 -16947 2 25368 -2667 -15790 0 25352 -2805 -15793 2 25327 -2723 -15847 2 -27385 6432 10424 0 -27368 6315 10540 2 -27374 6382 10485 2 -16689 -24298 5573 0 -16589 -24353 5632 2 -16633 -24311 5683 2 7818 28361 5876 0 7674 28412 5820 2 7742 28383 5870 2 -1083 23630 -18452 0 -1033 23552 -18554 2 -1125 23582 -18510 2 25414 6393 -14604 0 25373 6287 -14720 2 25384 6357 -14672 2 -11631 906 -27639 0 -11511 997 -27686 2 -11560 917 -27668 2 3474 212 29797 0 3415 89 29805 2 3513 139 29793 2 2829 27930 10580 0 2846 27978 10446 2 2777 27958 10519 2 -18229 -23261 5161 0 -18349 -23176 5118 2 -18270 -23241 5106 2 1852 23822 18140 0 1727 23778 18210 2 1828 23780 18198 2 17469 17022 -17466 0 17585 16916 -17454 2 17523 16949 -17484 2 -13668 26130 5512 0 -13785 26072 5496 2 -13724 26088 5575 2 -16825 22385 -10761 0 -16894 22325 -10779 2 -16778 22432 -10738 2 -17801 -23670 4779 0 -17908 -23575 4850 2 -17869 -23615 4798 2 -16972 24643 -2166 0 -17022 24596 -2304 3 -17028 24599 -2226 3 -29510 -1408 5213 0 -29525 -1510 5096 2 -29513 -1487 5175 2 -8023 14394 25068 0 -8091 14428 25028 2 -8076 14312 25099 2 18663 8080 22054 0 18588 8173 22084 2 18557 8137 22123 2 20234 -5953 -21335 0 20185 -5823 -21416 2 20216 -5880 -21371 2 9465 -4873 -28048 0 9403 -5018 -28043 2 9413 -4932 -28055 2 11849 -3988 -27271 0 11770 -4094 -27289 2 11767 -3994 -27305 2 19173 8661 21387 0 19234 8622 21348 2 19118 8709 21417 2 -25383 8079 13799 0 -25391 7950 13860 2 -25359 8044 13865 2 -947 23612 -18482 0 -828 23562 -18551 2 -907 23559 -18551 2 -20303 -21276 5923 0 -20379 -21235 5813 2 -20315 -21291 5831 2 -3266 29707 2611 0 -3229 29723 2473 2 -3294 29712 2520 2 29437 5643 -1268 0 29461 5529 -1224 2 29455 5538 -1306 2 5941 -8348 -28196 0 5974 -8425 -28166 2 5856 -8419 -28193 2 8674 28665 1747 0 8737 28650 1683 2 8635 28683 1642 2 12119 -27290 -2892 0 12251 -27236 -2846 2 12183 -27269 -2830 2 16774 7079 -23844 0 16856 6955 -23822 2 16783 7009 -23858 2 20757 13260 17126 0 20820 13132 17148 2 20807 13220 17097 2 -23106 319 19132 0 -23120 166 19116 2 -23097 241 19143 2 28708 8390 -2334 0 28749 8273 -2247 2 28731 8314 -2321 2 -17143 22854 -9157 0 -17199 22805 -9172 3 -17088 22907 -9125 3 24593 -4420 -16602 0 24535 -4339 -16710 2 24577 -4340 -16647 2 -5670 29343 -2618 0 -5794 29319 -2618 2 -5724 29338 -2549 2 29384 4265 -4286 0 29403 4123 -4297 2 29387 4196 -4338 2 -26493 13413 -4266 0 -26420 13542 -4314 3 -26461 13463 -4305 3 -12215 8751 25965 0 -12165 8841 25959 2 -12275 8798 25921 2 942 -9821 -28331 0 815 -9781 -28349 2 833 -9745 -28361 2 5791 -10962 -27318 0 5863 -11003 -27287 2 5762 -11059 -27286 2 -16110 -24557 6118 0 -16165 -24556 5978 2 -16113 -24571 6055 2 24603 7780 -15303 0 24622 7650 -15338 2 24581 7731 -15363 2 -11587 7787 26554 0 -11664 7865 26497 2 -11661 7765 26528 2 -16566 24953 -1701 0 -16600 24921 -1840 3 -16615 24916 -1768 3 -10538 27951 2769 0 -10651 27901 2840 2 -10569 27933 2838 2 -26227 14265 -2946 0 -26256 14184 -3072 2 -26248 14216 -2996 2 -29996 -410 275 0 -29995 -474 271 2 -29995 -378 373 2 -1328 24397 17407 0 -1416 24329 17495 2 -1337 24351 17471 2 28640 5411 -7103 0 28656 5287 -7133 2 28631 5368 -7174 2 2879 27986 10415 0 2923 28031 10282 2 2875 28017 10334 2 -10402 -26170 10341 0 -10542 -26130 10301 2 -10478 -26154 10305 2 -10281 28087 2329 0 -10387 28045 2363 2 -10309 28069 2413 2 2742 27846 10820 0 2827 27881 10709 2 2757 27874 10743 2 -3438 -29243 -5748 0 -3395 -29223 -5873 2 -3366 -29241 -5797 2 -26723 12841 4584 0 -26789 12731 4504 2 -26760 12774 4551 2 -1401 24087 17828 0 -1402 24027 17909 2 -1313 24053 17881 2 5935 -7944 -28314 0 5950 -7799 -28351 2 5961 -7846 -28336 2 22691 -404 -19620 0 22781 -444 -19515 2 22707 -444 -19601 2 -615 23609 -18500 0 -642 23547 -18578 2 -715 23572 -18544 2 -7610 27327 9765 0 -7524 27336 9804 2 -7513 27370 9719 2 3275 28106 9967 0 3341 28140 9847 2 3275 28132 9893 2 -1798 26125 -14637 0 -1923 26078 -14706 2 -1863 26103 -14669 2 3404 28154 9786 0 3420 28188 9682 2 3337 28185 9720 2 -19236 -22431 5182 0 -19331 -22350 5178 2 -19290 -22398 5119 2 16386 -1104 25106 0 16313 -1022 25156 2 16289 -1074 25170 2 19553 -4260 -22350 0 19616 -4311 -22285 2 19547 -4355 -22337 2 -22905 18425 5990 0 -22809 18529 6037 2 -22842 18494 6019 2 -12241 25010 -11164 0 -12358 24940 -11192 2 -12316 24982 -11146 2 -6089 -28902 -5253 0 -6055 -28888 -5370 2 -6012 -28910 -5299 2 14736 -4824 -25682 0 14693 -4930 -25687 2 14653 -4867 -25721 2 19044 17073 -15679 0 19138 16965 -15682 2 19074 17019 -15701 2 -16277 25021 3001 0 -16379 24963 2923 2 -16347 24978 2982 2 3248 24619 16833 0 3210 24543 16951 2 3241 24575 16899 2 -19337 -22287 5420 0 -19319 -22272 5542 2 -19373 -22247 5453 2 3510 24558 16869 0 3557 24490 16958 2 3593 24526 16899 2 -6842 29209 -35 0 -6965 29180 -20 2 -6900 29196 25 2 -15937 22907 -11013 0 -16056 22845 -10969 2 -16001 22884 -10968 2 27779 11315 -526 0 27730 11436 -549 2 27739 11414 -505 2 -12034 25103 -11183 0 -12097 25045 -11243 2 -12138 25050 -11188 2 11603 -4113 -27358 0 11589 -4216 -27348 2 11525 -4163 -27383 2 12813 -2626 -26999 0 12809 -2758 -26987 2 12773 -2687 -27012 2 -25308 8431 13728 0 -25270 8388 13823 2 -25269 8477 13771 2 -25475 7114 14157 0 -25444 7234 14152 2 -25486 7172 14107 2 13199 -12085 -24077 0 13269 -11977 -24093 2 13274 -12037 -24061 2 -14219 23894 -11265 0 -14304 23809 -11338 2 -14278 23849 -11286 2 4551 -23163 -18514 0 4580 -23240 -18410 2 4531 -23215 -18454 2 5199 -9999 -27803 0 5274 -9989 -27792 2 5195 -10081 -27774 2 -3465 -29255 -5667 0 -3515 -29268 -5572 2 -3541 -29246 -5667 2 20448 -6320 21022 0 20522 -6372 20935 2 20511 -6309 20964 2 -11210 -27380 4968 0 -11277 -27333 5074 2 -11270 -27348 5004 2 -7114 29104 -1523 0 -7145 29090 -1648 2 -7171 29087 -1587 2 11126 17559 21631 0 11134 17448 21717 2 11138 17492 21679 2 -17516 22482 -9368 0 -17553 22438 -9404 3 -17476 22529 -9329 3 23571 -1939 -18457 0 23503 -1905 -18547 2 23540 -1864 -18504 2 -6394 -28910 -4832 0 -6421 -28885 -4944 2 -6353 -28909 -4893 2 5794 26057 13692 0 5738 26012 13800 2 5796 26020 13762 2 -23934 17129 5813 0 -23966 17093 5783 2 -23887 17178 5861 2 -23357 -76 18827 0 -23413 -173 18756 2 -23372 -148 18808 2 7231 -5628 -28566 0 7114 -5606 -28600 2 7178 -5572 -28591 2 8011 -2165 28829 0 7925 -2185 28852 3 7967 -2257 28835 3 -17637 -23714 5158 0 -17745 -23644 5107 2 -17695 -23678 5120 2 21913 -8820 18494 0 21979 -8702 18471 2 21945 -8748 18491 2 9869 19293 20746 0 9784 19255 20821 2 9839 19231 20817 2 22899 -4077 -18947 0 22873 -4163 -18960 2 22836 -4111 -19017 2 -14038 23901 -11476 0 -14145 23829 -11493 2 -14110 23868 -11455 2 4353 24653 16531 0 4422 24592 16603 2 4434 24633 16540 2 -18051 -23470 4832 0 -18081 -23422 4950 2 -18091 -23428 4883 2 28220 10019 -1806 0 28243 9937 -1889 2 28218 10009 -1886 2 -20490 -21140 5764 0 -20495 -21108 5864 2 -20539 -21089 5779 2 3983 28240 9309 0 3995 28275 9196 2 3943 28269 9236 2 -18699 -22936 4930 0 -18790 -22869 4897 2 -18753 -22906 4861 2 627 18932 23264 0 543 18870 23316 2 628 18877 23308 2 19354 14991 17340 0 19404 14893 17368 2 19418 14939 17313 2 -28747 8411 1693 0 -28725 8461 1814 2 -28730 8457 1755 2 -8901 26791 10151 0 -8903 26830 10046 2 -8944 26816 10046 2 -1847 24835 16728 0 -1874 24782 16803 2 -1790 24801 16784 2 -10396 25971 10836 0 -10312 25983 10887 2 -10357 26004 10794 2 -1746 26561 13836 0 -1700 26507 13946 2 -1696 26534 13896 2 -16548 24985 -1391 0 -16518 24997 -1514 3 -16558 24974 -1470 3 -23092 1143 19117 0 -23121 1046 19087 2 -23072 1066 19145 2 -9616 27575 -6867 0 -9702 27557 -6819 3 -9621 27592 -6791 3 37 -8773 -28689 0 -46 -8684 -28716 2 24 -8708 -28708 2 -5877 24660 -16042 0 -5848 24597 -16149 2 -5889 24616 -16106 2 -7063 29124 1383 0 -7169 29100 1337 2 -7157 29101 1387 2 9491 -28294 3062 0 9579 -28259 3111 2 9551 -28264 3151 2 -10563 28011 -1955 0 -10655 27974 -1986 2 -10653 27979 -1924 2 -23006 339 19251 0 -23057 259 19192 2 -23005 265 19253 2 24368 17193 -3258 0 24408 17126 -3310 3 24354 17197 -3335 3 -8017 28176 6466 0 -8104 28140 6518 2 -8032 28155 6542 2 -26550 11424 8038 0 -26521 11404 8159 2 -26522 11440 8106 2 28996 6412 -4254 0 28967 6524 -4285 2 28980 6495 -4237 2 -11839 8554 26204 0 -11778 8581 26223 2 -11885 8599 26169 2 -20098 -21617 5362 0 -20129 -21564 5463 2 -20147 -21562 5405 2 21155 4033 -20886 0 21195 3916 -20867 2 21160 3950 -20896 2 5515 20897 20806 0 5618 20829 20847 2 5581 20864 20822 2 -29988 -222 -832 0 -29990 -172 -771 2 -29987 -150 -871 2 5034 26084 13938 0 5055 26035 14022 2 5109 26045 13984 2 1691 19298 22907 0 1602 19301 22911 2 1683 19247 22951 2 2119 26865 13182 0 2003 26862 13207 2 2061 26846 13231 2 10789 18377 21116 0 10686 18371 21174 2 10748 18342 21167 2 -11870 -26301 8207 0 -11843 -26282 8308 2 -11908 -26268 8257 2 -18344 -23246 4807 0 -18428 -23172 4845 2 -18401 -23206 4787 2 -11295 25251 -11610 0 -11360 25193 -11673 2 -11375 25214 -11613 2 6300 20443 21033 0 6423 20429 21010 2 6387 20448 21002 2 29102 725 -7249 0 29129 728 -7138 2 29118 683 -7190 2 -29997 -152 -412 0 -29998 -130 -330 2 -29997 -78 -415 2 -28040 10545 1595 0 -28072 10474 1501 2 -28068 10478 1556 2 11026 18001 21316 0 10929 17970 21392 2 10976 17971 21368 2 24332 1794 -17457 0 24364 1895 -17401 2 24365 1826 -17407 2 4781 16690 24466 0 4685 16710 24471 2 4717 16651 24505 2 21656 -5891 -19908 0 21677 -5775 -19919 2 21693 -5813 -19891 2 -19012 -22658 5013 0 -19095 -22601 4959 2 -19054 -22639 4944 2 -25345 15903 2173 0 -25412 15797 2170 3 -25397 15818 2184 3 22404 -4219 -19500 0 22448 -4297 -19432 2 22396 -4274 -19498 2 -10163 28146 2130 0 -10252 28117 2078 2 -10231 28120 2147 2 -725 25703 15454 0 -832 25722 15417 2 -809 25697 15461 2 25446 6214 -14625 0 25448 6119 -14661 2 25420 6157 -14694 2 -18014 -23519 4728 0 -18082 -23452 4803 2 -18070 -23470 4757 2 8350 18419 22159 0 8436 18352 22182 2 8428 18397 22148 2 -16265 24998 3250 0 -16354 24943 3223 2 -16343 24945 3268 2 -29435 3954 4235 0 -29442 3852 4278 2 -29432 3910 4298 2 14345 -4396 -25979 0 14343 -4516 -25959 2 14326 -4471 -25976 2 -20159 -21497 5615 0 -20206 -21434 5683 2 -20217 -21441 5619 2 17291 -23956 5209 0 17268 -23996 5100 2 17301 -23964 5141 2 6171 20591 20926 0 6279 20567 20918 2 6254 20600 20893 2 -8736 -28700 -52 0 -8770 -28689 40 2 -8808 -28678 -12 2 -5134 25663 -14664 0 -5071 25629 -14746 2 -5121 25622 -14741 2 23474 -4238 -18194 0 23403 -4284 -18274 2 23424 -4241 -18258 2 -12945 26676 4562 0 -12941 26693 4471 2 -12992 26655 4551 2 11880 -13958 -23749 0 11878 -13859 -23809 2 11905 -13887 -23778 2 9893 18457 21482 0 9960 18385 21512 2 9977 18416 21478 2 -14530 23658 -11366 0 -14565 23598 -11446 2 -14588 23609 -11393 2 -17616 -23753 5046 0 -17709 -23692 5009 2 -17676 -23719 4999 2 25086 -5507 -15503 0 25035 -5496 -15589 2 25058 -5452 -15568 2 -15610 -24492 7515 0 -15622 -24508 7437 2 -15570 -24510 7538 2 -15472 22928 -11615 0 -15530 22877 -11639 2 -15545 22901 -11571 2 -12165 24913 -11461 0 -12131 24885 -11557 2 -12179 24873 -11533 2 5310 21296 20452 0 5331 21230 20516 2 5377 21242 20491 2 17800 23716 -4555 0 17858 23655 -4640 3 17827 23682 -4619 3 18987 -4163 22851 0 19043 -4074 22820 2 18989 -4105 22860 2 -13833 24181 -11133 0 -13829 24134 -11240 2 -13850 24141 -11197 2 6651 29245 -700 0 6701 29234 -696 2 6605 29254 -756 2 -25607 5901 14473 0 -25665 5849 14391 2 -25638 5846 14440 2 -19397 -22308 5108 0 -19396 -22283 5222 2 -19410 -22280 5180 2 -23259 -297 18946 0 -23312 -357 18879 2 -23273 -367 18927 2 -13405 24297 -11400 0 -13394 24263 -11486 2 -13444 24247 -11460 2 25842 -4398 -14590 0 25839 -4497 -14565 2 25818 -4470 -14610 2 -25303 12454 -10231 0 -25360 12402 -10153 2 -25336 12443 -10161 2 -8255 26088 -12300 0 -8173 26082 -12367 2 -8229 26067 -12362 2 6152 -8008 -28249 0 6063 -7968 -28280 2 6126 -7951 -28271 2 -25934 14888 2405 0 -25970 14841 2304 2 -25962 14849 2341 2 -6774 29199 -1229 0 -6789 29191 -1338 2 -6811 29188 -1297 2 -1560 24786 16830 0 -1570 24733 16907 2 -1517 24750 16886 2 -21338 21065 -960 0 -21383 21024 -863 3 -21364 21043 -882 3 -5625 24695 -16078 0 -5614 24654 -16145 2 -5678 24649 -16130 2 -26663 12045 6635 0 -26672 11975 6725 2 -26661 12013 6698 2 -27183 11286 5804 0 -27186 11232 5896 2 -27171 11276 5879 2 -20085 -21491 5891 0 -20148 -21425 5919 2 -20146 -21441 5868 2 11920 -13784 -23831 0 11942 -13686 -23876 2 11957 -13714 -23853 2 -19179 -22536 4928 0 -19213 -22489 5011 2 -19226 -22490 4954 2 -355 23212 19002 0 -447 23223 18987 2 -427 23190 19027 2 10541 18339 21273 0 10463 18306 21341 2 10505 18298 21326 2 -14382 25139 7820 0 -14472 25083 7836 2 -14434 25098 7857 2 -17775 -23685 4805 0 -17836 -23625 4875 2 -17826 -23641 4834 2 15192 -711 -25859 0 15156 -799 -25877 2 15134 -752 -25892 2 -25173 6788 14841 0 -25170 6869 14808 2 -25200 6824 14777 2 23886 -136 -18151 0 23919 -196 -18106 2 23881 -216 -18156 2 -17001 21978 11312 0 -17064 21907 11354 2 -17040 21917 11370 2 11428 -4389 -27389 0 11450 -4488 -27364 2 11416 -4465 -27381 2 -14644 23549 -11447 0 -14691 23491 -11504 2 -14708 23502 -11460 2 20716 -6655 20653 0 20742 -6675 20621 2 20731 -6583 20661 2 -27252 6392 10793 0 -27252 6313 10838 2 -27236 6338 10864 2 8257 18817 21858 0 8231 18761 21915 2 8272 18744 21914 2 17728 -4370 -23804 0 17659 -4413 -23847 2 17657 -4373 -23856 2 7081 29143 -744 0 7127 29133 -711 2 7111 29134 -804 2 20340 -6075 -21198 0 20282 -6021 -21269 2 20306 -6026 -21245 2 -10500 -27772 4297 0 -10487 -27765 4375 2 -10544 -27747 4351 2 -21551 16797 -12387 0 -21612 16772 -12313 2 -21592 16799 -12312 2 -23937 14156 -11253 0 -23897 14198 -11285 2 -23926 14126 -11313 2 2497 24497 17137 0 2528 24549 17058 2 2493 24542 17072 2 21770 -2150 -20529 0 21709 -2216 -20586 2 21723 -2188 -20574 2 -10876 -27085 6937 0 -10852 -27070 7031 2 -10890 -27062 7002 2 -26625 11639 7461 0 -26627 11581 7543 2 -26614 11615 7534 2 -25621 14760 -5070 0 -25629 14776 -4983 3 -25602 14798 -5057 3 -16344 22674 -10897 0 -16433 22621 -10874 2 -16412 22635 -10877 2 -15599 23126 -11040 0 -15659 23073 -11065 2 -15673 23082 -11027 2 2618 27824 10908 0 2667 27843 10848 2 2624 27854 10829 2 13838 15180 21865 0 13908 15114 21867 3 13911 15136 21849 3 29104 5954 -4186 0 29079 6043 -4229 2 29088 6022 -4197 2 -17298 24161 -4125 0 -17307 24139 -4219 3 -17326 24131 -4183 3 7494 29029 1081 0 7523 29023 1045 2 7443 29044 1026 2 -19537 -11007 19928 0 -19569 -10943 19932 3 -19599 -10935 19907 3 -18953 -22734 4895 0 -18996 -22685 4954 2 -19004 -22689 4904 2 13593 -5535 -26165 0 13507 -5562 -26204 2 13521 -5539 -26201 2 -19136 21815 -7612 0 -19209 21755 -7598 3 -19203 21767 -7579 3 -24002 17079 5677 0 -24030 17072 5578 2 -24024 17073 5602 2 -26057 14705 -2194 0 -26085 14644 -2268 2 -26079 14660 -2224 2 -25874 9131 12130 0 -25837 9128 12212 2 -25833 9154 12201 2 -22516 16997 -10205 0 -22582 16938 -10156 3 -22568 16954 -10162 3 15992 -257 25381 0 15990 -162 25383 2 15972 -205 25394 2 -8284 26137 -12175 0 -8230 26121 -12246 2 -8253 26111 -12251 2 -20414 -21222 5734 0 -20404 -21210 5815 2 -20435 -21186 5793 2 -15647 23076 -11075 0 -15709 23018 -11108 2 -15709 23033 -11078 2 -28391 9662 -763 0 -28401 9625 -851 2 -28403 9624 -814 2 23132 6353 18016 0 23192 6324 17948 2 23179 6347 17957 2 -24613 16950 2623 0 -24657 16892 2584 3 -24641 16907 2639 3 10870 -14991 23603 0 10905 -15056 23545 3 10912 -15035 23556 3 -27204 11625 4977 0 -27209 11578 5059 2 -27204 11598 5043 2 -26269 14142 -3158 0 -26297 14076 -3216 2 -26298 14079 -3194 2 2537 27833 10903 0 2517 27804 10982 2 2540 27806 10973 2 -27160 11434 5619 0 -27160 11399 5690 2 -27148 11427 5695 2 29168 5584 -4248 0 29158 5656 -4221 2 29165 5638 -4196 2 29735 1076 -3832 0 29738 1144 -3785 2 29740 1113 -3777 2 -1224 25269 16124 0 -1281 25233 16176 3 -1271 25234 16176 3 -28530 9221 1000 0 -28508 9285 1044 2 -28508 9286 1027 2 PDL-2.018/Demos/General.pm0000644060175006010010000000700112562522364013363 0ustar chmNone# Copyright (C) 1998 Tuomas J. Lukka. # All rights reserved, except redistribution # with PDL under the PDL License permitted. package PDL::Demos::General; use PDL; PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { comment q| Welcome to a short tour of PDL's capabilities. This tour shows some of the main selling points of PDL. However, because we want this script to run everywhere, some modules which require external modules for use are explicitly excluded, namely - PDL::Graphics::TriD (3D Graphics) [*] - PDL::Graphics::PGPLOT (PGPLOT graphics) - PDL::IO::FlexRaw (flexible raw input/output) [*]: this module has its separate demos in a subdirectory. Note that your own scripts must start with use PDL; to work properly, so that you can simply say perl script.pl or you can just try some of the commands illustrated in the demos by just retyping them at the perldl or pdl 'pdl>' command prompt. |; act q| $a = zeroes 5,5; # 5x5 matrix output $a; |; act q| # Now, don't think that the number of dimensions is limited # to two: $m = zeroes(3,2,2); # 3x2x2 cube output $m; |; act q| $a ++; # Operators like increment work.. output $a; |; act q| # xvals and yvals (yes, there is also zvals...) # give you piddles which give the coordinate value. $b = xvals $a; output $b; |; act q| # So you can do things like $b = $a + 0.1 * xvals($a) + 0.01 * yvals($a); output $b; |; act q| # Arithmetic operations work: $x = xvals(10) / 5; output $x,"\n"; output ((sin $x),"\n"); |; act q| # You can also take slices: output $b; output $b->slice(":,2:3"); # rows 2 and 3 |; act q| output $b->slice("2:3,:"); # or columns 2 and 3 |; act q| output $b; output $b->diagonal(0,1),"\n"; # 0 and 1 are the dimensions |; act q| # One of the really nifty features is that the # slices are actually references back to the original # piddle: $diag = $b->diagonal(0,1); output $b; output $diag,"\n"; $diag+=100; output "AFTER:\n"; output $diag,"\n"; output "Now, guess what \$b looks like?\n"; |; act q| # Yes, it has changed: output $b; |; act q| # Another example (we only modify elements 0,2 and 4 of # each row): $t = $b->slice("0:4:2"); $t += 50; output $b; |; act q| # There are lots of useful functions in e.g. PDL::Primitive # and PDL::Slices - we can't show you all but here are some # examples: output $b; output $b->sum, "\n"; output $b->sumover,"\n"; # Only over first dim. |; act q| output $b->xchg(0,1); output $b->minimum,"\n"; # over first dim. output $b->min,"\n"; |; act q| output $b->random; |; act q| # Here are some more advanced tricks for selecting # parts of 1-D vectors: $a = (xvals 12)/3; $i = which(sin($a) > 0.5); # Indices of those sines > 0.5 output $a,"\n"; output $i,"\n"; output $a->index($i),"\n"; # and we can have the effect of the last command in one # go using 'where' instead of 'which' and 'index' as in output $a->where(sin($a) > 0.5),"\n"; # and finally take the sin of these elements # (to show that these are indeed the correct ones) output sin($a->index($i)),"\n"; |; comment q| We hope you enjoyed these demos illustrating some of the basic capabilities of PDL. We encourage you to play with these commands in the perldl or pdl2 shell and use its online help support to find out more about these and other commands and features of PDL. Just type 'help' to get started. |; } 1; PDL-2.018/Demos/Gnuplot_demo.pm0000644060175006010010000002137513036512174014447 0ustar chmNone############################## # Gnuplot_demo package for PDL # # To use this manually: # use PDL::Demos::Screen; # do 'Gnuplot_demo.pm'; # PDL::Demos::Gnuplot_demo::run(); # # Authors: Dima Kogan & Craig DeForest package PDL::Demos::Gnuplot_demo; use PDL; BEGIN { eval 'use PDL::Graphics::Gnuplot;'; if ($@ or !defined($PDL::Graphics::Gnuplot::VERSION)) { eval <<'EOF'; sub run { print qq{ PDL::Graphics::Gnuplot is required for this demo, but didn't load. You may have to go get it from CPAN (http://search.cpan.org). You might also need to get the external "gnuplot" app (http://www.gnuplot.info). }; } EOF } return 1; } use PDL::ImageND; use PDL::Demos::Screen; # This is awful but seems to be needed since Screen.pm is where the Routines are located. -CED 2/2013 PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { local($PDL::debug) = 0; local($PDL::verbose) = 0; $s = q| # ensure that the module is loaded use PDL::Graphics::Gnuplot; # Create a Gnuplot object - the default device displays on most # operating systems. (No plot window yet - just the object). $w = gpwin(%%params%%); # Create variables to plot $x = xvals(1000); $y = $x/1000 * sin($x/10); |; if(!defined($PDL::Graphics::Gnuplot::VERSION)) { die q{ ******************************************************************************* This demo requires both the external "gnuplot" application and the module "PDL::Graphics::Gnuplot". You don't seem to have the module installed on your system. You might want to get it from CPAN and try again. ******************************************************************************* }; } if(!defined($PDL::Graphics::Gnuplot::valid_terms)) { my $ww = new PDL::Graphics::Gnuplot; } if($PDL::Graphics::Gnuplot::valid_terms->{wxt}) { $subst = "wxt, size=>[8,6,'in'], title=>'Gnuplot demo window', persist=>0"; } elsif($ENV{DISPLAY}) { $subst = "x11, size=>[8,6,'in'], title=>'Gnuplot demo window', persist=>0"; } else { $subst = ""; } $s=~s/\%\%params\%\%/$subst/; act $s; $s = q| # ensure that the module is loaded use PDL::Graphics::Gnuplot; # Create a Gnuplot object - the default device displays on most # operating systems. (No plot window yet - just the object). $w = gpwin(%%params%%); # Create variables to plot $x = xvals(1000)/1000; $y = $x * sin(100 * $x); # Generate a line plot. Plot parameters in front. $w->lines({title=>" x * sin(100 x) ",xl=>"Ordinate",yl=>"Abscissa"}, $x, $y ); |; $s =~s/\%\%params\%\%/$subst/; act $s; act q| # You can set persistent plot parameters with "options". $w->options(title=>"Two lines", xl=>"Ordinate", yl=>"Abscissa"); # A two-line plot $y2 = sqrt($x) * cos(100*$x); $w->lines($x,$y,{},$x,$y2); |; act q| # You can set persistent plot parameters with "options". $w->options(title=>"Two lines", xl=>"Ordinate", yl=>"Abscissa"); # A two-line plot. # Groups of data are separated by non-PDL options -- in this # case, the null hash since there are no per-curve options. $y2 = sqrt($x) * cos(100*$x); $w->lines($x,$y,{},$x,$y2); # A two-line plot with legend. # The legend for each line separates the groups of PDL data. $w->options(title=>"Two lines (with legend)", key=>'left'); $w->lines( legend=>"sin",$x,$y, legend=>"cos",$x,$y2 ); # |; act q| # You can also generate multiline plots with threading. # Here, $x is a 1000-element 1-D PDL, and $yy is a 1000x2 2-D PDL. $x = xvals(1000)/1000; ($y,$y2) = ( $x * sin(100 * $x), sqrt($x) * cos(100 * $x) ); $yy = pdl( $y, $y2 ); # all options can be abbreviated to the smallest unique string. # Here, "tit" stands for "title", and "le" for "legend". $w->lines({tit=>"2-lines threaded"}, le=>["sin", "cos"], $x, $yy); |; act q| # line plots are far from the only thing you can do! # Here is the same plot, with points and some tweaks to the axis labels. $w->options(tit=>"2 sets of points"); $l = ["sin", "cos"]; $w->points({xtics=>{rotate=>45,offset=>[0,-1.5],font=>',14'}, xlab=>"Tilted Labels in 14-point text" }, le=>$l, $x, $yy); |; act q| # Many types of plot are supported, using the "plot" command # and the "with" curve option. Here, we can mix and match points and lines. # You can also set plot options *temporarily* with a hash ref at the start of the # plot call: $w->plot( {title=>"Points and lines mixed"}, with=>'points', le=>'sin (points)', $x, $y, with=>'lines', le=>'cos (line)', $x, $y2); |; act q| # Many types of plot are supported, using the "plot" command # and the "with" curve option. Here, we can mix and match points and lines. $w->plot( with=>'points', le=>'sin (points)', $x, $y, with=>'lines', le=>'cos (line)', $x, $y2); $x = xvals(51)/50; ($y,$y2) = ( $x * sin(20 * $x), sqrt($x) * cos(20 * $x) ); $radii = 0.01 * (0.25 - ($x*2 - 0.5)**2); # Here are some other options. $w->plot( {title=>"Circles and Steps"}, le=>"Circles", with=>'circles', $x, $y, $radii, le=>"Steps", with=> 'steps', $x, $y2 ); |; act q| # You can plot multiple plots on one pane with "multiplot". $x = xvals(51)/50; ($y,$y2) = ( $x * sin(20 * $x), sqrt($x) * cos(20 * $x) ); $w->multiplot(layout=>[1,2]); $w->plot( {title=>"Impulses"}, with=> 'impulses', $x, $y ); $w->plot( {title=>"Filled Curves"}, with => "filledcurves", $x, $y, $y2 ); $w->end_multi(); |; act q| # 2-D data... $rv = rvals(51,51)/2; $im = 25 * cos($rv) / ($rv+1.5); $w->multiplot(layout=>[2,2]); $w->options(justify=>1); # set nice aspect ratio $w->plot( {tit=>'Default color map'}, with=>'image', $im ); $w->plot( {tit=>'Grayscale', clut=>'gray'}, with=>'image', $im ); $w->plot( {tit=>'heat map', clut=>'heat1'}, with=>'image', $im ); $w->plot( {tit=>'3d perspective', trid=>1}, with=>'pm3d', $im ); $w->end_multi; |; act q| # You can indpendently specify color and position on surface plots, # and can overlay multiple types of plot -- even in 3D. # $rv = rvals(101,101)/5; $im = cos($rv)/($rv+2.5); $grad = sumover $im->range([[-1,0],[1,0]],[$im->dims],'e') * pdl(-1,1); $im2 = $im->indexND(ndcoords(26,26)*4); # subsample $im $w->reset; $w->options( trid=>1, hidden=>'front', colorbox=>0, clut=>'heat1' ); $w->multiplot(layout=>[2,2]); $w->plot( {title=>"A colormap-shaded 3-d surface plot"}, with=>'pm3d', $im ); $w->plot( {title=>"Perspective 3-d surface plot"}, with=>'pm3d', xvals($im), yvals($im), $im, $grad ); $w->plot( {title=>"Perspective grid plot"}, with=>'lines', xvals($im2)*4, yvals($im2)*4, $im2 ); $w->plot( {title=>"Combined"}, with=>'pm3d', xvals($im),yvals($im), $im, $grad, with=>'lines', xvals($im2)*4, yvals($im2)*4, $im2 ); $w->end_multi; |; use File::Spec; $d = File::Spec->catdir( "PDL", "Demos" ); $m51path = undef; foreach my $path ( @INC ) { my $check = File::Spec->catdir( $path, $d ); if ( -d $check ) { $m51path = $check; last; } } if( defined($m51path) && -e "$m51path/m51.fits") { $m51path = "$m51path/m51.fits"; } else { comment q| ****************************************************** You seem to be missing the file 'm51.fits', which should be included in the PDL distribution. Without it, I can't show you the m51 image demos, so I'll quit now. ****************************************************** |; return; } $s = q| # Images ... $m51 = rfits('%%m51%%'); $w->reset; $w->image({j=>1, clut=>'gray', title=>"M51 galaxy"}, with=>'image',$m51 ); |; $s=~ s/\%\%m51\%\%/$m51path/; act $s; $s = q| $m51 = rfits('%%m51%%')->slice('0:-1:4,0:-1:4'); $m51s = $m51->convolveND(ones(11,11)/11**2); $w->options(clut=>'heat2', trid=>1); # 3-D display of M51: various angles (note "columnsfirst" in multiplot) $w->multiplot(layout=>[2,2,'columnsfirst']); $w->plot({title=>"M51 in 3-D (default view)"}, with=>'pm3d',xvals($m51s), yvals($m51s), $m51s, $m51s ); $w->plot({title=>"M51 in 3-D (ortho view)", view=>'equal xy'}, with=>'pm3d',xvals($m51s), yvals($m51s), $m51s, $m51s ); $w->plot({title=>"M51 in 3-D (near-vertical view)", view=>[ 0, 80, 'equal xy' ]}, with=>'pm3d',xvals($m51s), yvals($m51s), $m51s, $m51s ); $w->plot({title=>"M51 in 3-D (nearly along X axis)", view=>[ 85, 5 ]}, with=>'pm3d',xvals($m51s), yvals($m51s), $m51s, $m51s ); $w->end_multi; |; $s =~ s/\%\%m51\%\%/$m51path/; act $s; } 1; PDL-2.018/Demos/Makefile.PL0000644060175006010010000000336512562522364013433 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; # For the lazy people undef &MY::postamble; # suppress warning *MY::postamble = sub { PDL::Core::Dev::postamble(). q~ test_tjl : PERL_DL_NONLAZY=1 $(FULLPERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' *.pl ~ }; # NOTE: # we hijack m51.fits from the parent directory and # install that into the demos directory WriteMakefile( 'NAME' => 'PDL::Demos', 'VERSION_FROM' => '../Basic/Core/Version.pm', 'PM' => {'General.pm' => '$(INST_LIBDIR)/Demos/General.pm', 'Screen.pm' => '$(INST_LIBDIR)/Demos/Screen.pm', 'TriD1.pm' => '$(INST_LIBDIR)/Demos/TriD1.pm', 'TriD2.pm' => '$(INST_LIBDIR)/Demos/TriD2.pm', 'TriDGallery.pm' => '$(INST_LIBDIR)/Demos/TriDGallery.pm', 'PGPLOT_demo.pm' => '$(INST_LIBDIR)/Demos/PGPLOT_demo.pm', 'PGPLOT_OO_demo.pm' => '$(INST_LIBDIR)/Demos/PGPLOT_OO_demo.pm', 'BAD_demo.pm' => '$(INST_LIBDIR)/Demos/BAD_demo.pm', 'BAD2_demo.pm' => '$(INST_LIBDIR)/Demos/BAD2_demo.pm', 'Transform_demo.pm' => '$(INST_LIBDIR)/Demos/Transform_demo.pm', 'Cartography_demo.pm' => '$(INST_LIBDIR)/Demos/Cartography_demo.pm', 'Gnuplot_demo.pm' => '$(INST_LIBDIR)/Demos/Gnuplot_demo.pm', '../m51.fits' => '$(INST_LIBDIR)/Demos/m51.fits', 'Prima.pm' => '$(INST_LIBDIR)/Demos/Prima.pm', }, 'clean' => { 'FILES' => 'BAD_demo.pm BAD2_demo.pm' }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Demos/PGPLOT_demo.pm0000644060175006010010000001205713036512174014021 0ustar chmNonepackage PDL::Demos::PGPLOT_demo; use PDL; use PDL::Graphics::PGPLOT; PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { $ENV{PGPLOT_XW_WIDTH}=0.3; $ENV{PGPLOT_DEV}=$^O =~ /MSWin32/ ? '/GW' : "/XSERVE"; comment q| Welcome to this tour of the PDL's PGPLOT interface. This tour will introduce the PDL's PGPLOT plotting module and show what this powerful package can provide in terms of plotting. It is not designed to give a full tour of PGPLOT, you are advised to see the routines provided with pgperl for that. The PDL::Graphics::PGPLOT module provides a high-level interface to PGPLOT. However if you want even better control of your plots you might want to include the PGPLOT module specifically: use PGPLOT; One aspect of PGPLOT that requires mention is the use of devices: Normally PGPLOT will inquire you about what device you want to use, with the prompt: Graphics device/type (? to see list, default /NULL): |; act q| # ensure the module is loaded (required for PDL versions >= 2.004) use PDL::Graphics::PGPLOT; # The size of the window can be specified $ENV{PGPLOT_XW_WIDTH}=0.3; # You can set your device explicitly $id=dev($^O =~ /MSWin32/ ? '/GW' : '/XSERVE'); |; act q| # First we define some variables to use for the rest of the demo. $x=sequence(10); $y=2*$x**2; # Now a simple plot with points points $x, $y; |; act q| # Here is the same with lines line $x, $y; |; act q| # If you want to overlay one plot you can use the command # 'hold' to put the graphics on hold and 'release' to # revert the effect points $x, $y, {SYMBOL=>4}; # The last argument sets symboltype hold; # Now draw lines between the points line $x, $y; # Plot errorbars over the points $yerr=sqrt($y); errb $x, $y, $yerr; # To revert to old behaviour, use release release; |; act q| bin $x, $y; # This plots a binned histogram of the data and as you can # see it made a new plot. |; act q| # 2D data can also easily be accommodated: # First make a simple image $gradient=sequence(40,40); # Then display it. imag $gradient; # And overlay a contour plot over it: hold; cont $gradient; release; |; act q| # PDL::Graphics::PGPLOT contains several colour tables, # a more extensive collection can be found in # PDL::Graphics::LUT # # (note: the call to lut_names() can take a few seconds to execute) # use PDL::Graphics::LUT; @names = lut_names(); print "Available tables: [ ", @names, " ]\n"; # use the first table ctab( lut_data($names[0]) ); use PGPLOT; pglabel "", "", "Colour table: $names[0]"; |; act q| # To change plot specifics you can either use the specific PGPLOT # commands - recommended if you need lots of control over your # plot. # # Or you can use the new option specifications: # To plot our first graph again with blue color, dashed line # and a thickness of 10 we can do: line $x, $y, {COLOR=>5, LINESTYLE=>'dashed', LINEWIDTH=>10}; |; act q| # Now for a more complicated example. # First create some data $a=sequence(360)*3.1415/180.; $b=sin($a)*transpose(cos($a)); # Make a piddle with the wanted contours $contours=pdl [0.1,0.5,1.0]; # And an array (reference to an array) with labels $labels=['A', 'B', 'C']; # Create a contour map of the data - note that we can set the colour of # the labels. cont($b, {CONTOURS=>$contours, linest=>'DASHED', LINEWIDTH=>3, COLOR=>2, LABELCOL=>4}); hold; pgqlw($linewidth); points $a->slice('0:-1:4')*180./3.1415; release; |; act q| # # More examples of changing the plot defaults # $a = 1+sequence(10); $b = $a*2; $bord_opt = { TYPE => 'RELATIVE', VALUE => 0.1 }; line log10($a), $b, { AXIS => 'LOGX', BORDER => $bord_opt }; |; act q| # # We can also create vector maps of data # This requires one array for the horizontal component and # one for the vertical component # $horizontal=sequence(10,10); $vertical=transpose($horizontal)+random(10,10)*$horizontal/10.; $arrow={ARROW=> {FS=>1, ANGLE=>25, VENT=>0.7, SIZE=>3}}; vect $horizontal, $vertical, {ARROW=>$arrow, COLOR=>RED}; hold; cont $vertical-$horizontal, {COLOR=>YELLOW}; release; |; act q| # # To draw [filled] polygons, the command poly is handy: # $x=sequence(10)/5; poly $x, $x**2, {FILL=>HATCHED, COLOR=>BLUE}; |; act q| # # the latest feature of PDL are complex numbers # so let's play with a simple example # use PDL::Complex; $z50 = zeroes(50); $c = $z50->xlinvals(0,7)+i*$z50->xlinvals(2,4); line im sin $c; hold; # the imaginary part line re sin $c; # real line abs sin $c; release; # and the modulus |; act q| # # more complex numbers # use PDL::Complex; $c = zeroes(300)->xlinvals(0,12)+i*zeroes(300)->xlinvals(2,10); $sin = sin $c; line $sin->im, $sin->re; # look at the result in the complex plane #close the window--we're done! close_window($id); |; } 1; PDL-2.018/Demos/PGPLOT_OO_demo.pm0000644060175006010010000000543412562522364014424 0ustar chmNonepackage PDL::Demos::PGPLOT_OO_demo; # show how to use the new OO PGPLOT interface use PDL; use PDL::Graphics::PGPLOT::Window; PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { $ENV{PGPLOT_XW_WIDTH}=0.3; $ENV{PGPLOT_DEV}=$^O =~ /MSWin32/ ? '/GW' : "/XSERVE"; comment q| The PGPLOT demo showed you how to use the old interface to PGPLOT. As this is perl, TIMTOWTDI, and this demo shows you how to use the new, object-orientated PGPLOT interface. For the simple examples shown here, the new method appears overkill; however, it really comes into its own when you wish to deal with multiple plots or windows. Enough prattle, on with the show... |; act q| # we start with a different module to the traditional interface use PDL::Graphics::PGPLOT::Window; # create a window "object" $dev = $^O =~ /MSWin32/ ? '/GW' : '/XSERVE'; $win = PDL::Graphics::PGPLOT::Window->new( { Dev => $dev } ); |; act q| # First we define some variables to use for the rest of the demo. $x=sequence(10); $y=2*$x**2; # Now a simple plot with points $win->points( $x, $y ); |; act q| # Here is the same with lines $win->line( $x, $y ); # if you're beginning to think its the same as the old calls, # just with "$win->" at the beginning then you're not far wrong! |; act q| # You can do all the things you did before ... $win->points( $x, $y, {Symbol=>4} ); $win->hold; $win->line( $x, $y ); $yerr=sqrt($y); $win->errb( $x, $y, $yerr ); $win->release; |; act q| # and it acts the same way $gradient=sequence(40,40); $win->imag( $gradient ); $win->hold; $win->cont( $gradient ); $win->release; # add labels to the plot $win->label_axes( "An axis", "Another axis", "Title" ); |; act q| # let's try and read the cursor use PDL::Complex; $c = zeroes(300)->xlinvals(0,12)+i*zeroes(300)->xlinvals(2,10); $sin = sin $c; $win->line( $sin->im, $sin->re ); print "Select a point in the graph (mouse button or key press):\n"; ( $x, $y, $ch ) = $win->cursor( { Type=>'CrossHair' } ); print "\nYou selected: $x + $y i (key = $ch)\n"; |; # should really do something related to the selected points... act q| # how about another window? $win2 = PDL::Graphics::PGPLOT::Window->new( { Dev => $dev } ); $win2->env( 0, 4, -2, 0, { Axis => 'logy' } ); $x = sequence(101) / 25; $win2->points( $x, $x->sin->abs()->log10 ); |; act q| # switch back to the original window (we don't want to hurt # its feelings) $win->line( $x, { Border => 1 } ); |; act q| # free up the windows, after finding their names print "You've been watching " . $win->name(); print " and " . $win2->name() . "\n"; $win->close(); $win2->close(); |; } 1; PDL-2.018/Demos/Prima.pm0000644060175006010010000004215513036512174013062 0ustar chmNoneuse strict; use warnings; ############################################################################ package PDL::Demos::Prima; ############################################################################ use PDL; =head1 NAME PDL::Demos::Prima - PDL demo for PDL::Graphics::Prima =head1 SYNOPSIS You can enjoy this demo in any number of ways. First, you can invoke the demo from the command line by saying perl -MPDL::Demos::Prima Second, you can invoke the demo from with the pdl shell by saying pdl> demo prima Finally, all of the content is in the pod documentation, so you can simply read this, though it won't be quite so interactive. :-) perldoc PDL::Demos::Prima podview PDL::Demos::Prima =head1 DESCRIPTION The documentation in this module is meant to give a short, hands-on introduction to L, a plotting library written on top of the L GUI toolkit. =cut ############################## # Check load status of Prima # ############################## my $min_version = 0.13; my $loaded_prima = eval { require PDL::Graphics::Prima; return 0 if $PDL::Graphics::Prima::VERSION < $min_version; require PDL::Graphics::Prima::Simple; PDL::Graphics::Prima::Simple->import(); require Prima::Application; Prima::Application->import(); 1; }; ########################################### # Pull the demo pod into a data structure # ########################################### # Pull the pod apart into the following sort of array structure # @demo = ( # 'Introduction' => $first_paragraph => $first_code, # 'Introduction' => $second_paragraph => $second_code, # ... # 'First steps' => $first_paragraph => $first_code, # ... # ); my (@demo, $curr_section, $curr_par, $curr_code); my $curr_state = 'section_title'; while(my $line = ) { # Only =head2s in this documentation last if $line =~ /=head1/; if ($line =~ /^=head2 (.*)/) { # Add the current section's name and an empty arrayref $curr_section = $1; } elsif ($line =~ /^\n/) { if (defined $curr_par and defined $curr_code) { push @demo, $curr_section, $curr_par, $curr_code; $curr_par = $curr_code = undef; } } elsif (not defined $curr_par) { $curr_par = $line; } elsif (not defined $curr_code and $line !~ /^\s/) { $curr_par .= $line; } elsif ($line =~ /^\s/) { # Accumulate code lines, stripping off the leading space $line =~ s/^\s//; $curr_code .= $line; } } # Add some extra content for Prima viewing only if ($loaded_prima) { unshift @demo, 'Introduction', 'This is the demo for L. Explanatory text will appear here; code samples will appear below. Tip: you can modify and re-run the code samples. When you are done, simply close the window.', '### HEY, EDIT ME! ### use Prima::MsgBox; Prima::MsgBox::message( "Hello, this is the PDL::Graphics::Prima demo.", mb::Ok);' } ################################## # The command that runs the demo # ################################## # These are widgts I will need across multiple functions, so they are globals. my ($section_title_label, $text_pod, $code_eval, $prev_button, $next_button, $run_button, $help_window, $window, $is_evaling); sub run { # Make sure they have it. Otherwise, bail out. if (not $loaded_prima) { my $reason = "I couldn't load the library, either because it's not installed on your machine or it's broken."; $reason = "your version of PDL::Graphics::Prima (v$PDL::Graphics::Prima::VERSION) is out of date. This demo requires at least v$min_version." if defined $loaded_prima; print <create( place => { relx => 0.15, relwidth => 0.7, relheight => 0.7, rely => 0.15, anchor => 'sw', }, sizeMax => [600, 800], sizeMin => [600, 800], text => 'PDL::Graphics::Prima Demo', onDestroy => sub { require Prima::Utils; # Throw an exception after destruction is complete so that we # break out of the $::application->go loop. Prima::Utils::post(sub { die 'time to exit the event loop' }); }, onKeyUp => \&keypress_handler, ); $window->font->size(12); # Title # ---( Build list of windows that we don't want to close )--- my @dont_touch = $::application->get_widgets; my $title_height = 50; $section_title_label = $window->insert(Label => place => { x => 0, relwidth => 1, anchor => 'sw', y => -$title_height, rely => 1, height => $title_height, }, text => '', height => $title_height, alignment => ta::Center(), valignment => ta::Center(), backColor => cl::White(), font => { size => 24, }, onKeyUp => \&keypress_handler, ); # Buttons my $button_height = 35; $prev_button = $window->insert(Button => place => { x => 0, relwidth => 0.333, anchor => 'sw', y => 0, height => $button_height, }, height => $button_height, text => 'Previous', enabled => 0, onClick => sub { $current_slide-- unless $current_slide == 0; setup_slide($current_slide); }, ); $run_button = $window->insert(Button => place => { relx => 0.333, relwidth => 0.333, anchor => 'sw', y => 0, height => $button_height, }, height => $button_height, text => 'Run', onClick => sub { # Clear out old windows for my $curr_window ($::application->get_widgets) { next if grep { $curr_window == $_ } @dont_touch or defined $help_window and $curr_window == $help_window; $curr_window->destroy; } # Disable the buttons my $prev_state = $prev_button->enabled; $prev_button->enabled(0); $run_button->enabled(0); my $next_state = $next_button->enabled; $next_button->enabled(0); # Run the eval eval 'no strict; no warnings; ' . $code_eval->text; if ($@ and $@ !~ /time to exit the event loop/ ) { warn $@; Prima::MsgBox::message($@); } $prev_button->enabled($prev_state); $run_button->enabled(1); $next_button->enabled($next_state); }, ); $next_button = $window->insert(Button => place => { relx => 0.666, relwidth => 0.333, anchor => 'sw', y => 0, height => $button_height, }, height => $button_height, text => 'Next', onClick => sub { $current_slide++ unless $current_slide == @demo/3; setup_slide($current_slide); }, ); # Text my $par_container = $window->insert(Widget => place => { x => 0, relwidth => 1, anchor => 'sw', rely => 0.6, relheight => 0.4, height => -$title_height-1, }, backColor => cl::White(), ); my $padding = 10; $text_pod = $par_container->insert(PodView => place => { x => $padding, relwidth => 1, width => -2*$padding, y => $padding, relheight => 1, height => -2*$padding - 15, anchor => 'sw', }, # This Event does not appear to be documented!!! Beware!!! # Modify link clicking so that it opens the help window instead # of following the link. onLink => sub { my ($self, $link) = @_; # $link is a reference to the link that should be opened; deref $::application->open_help($$link); # Store the help window so we can close it on exit later $help_window = $::application->get_active_window; # Bring the help window to the fore $::application->get_active_window->bring_to_front if $::application->get_active_window; # Clear the event so that it doesn't follow the link in this # renderer $self->clear_event; }, backColor => cl::White(), borderWidth => 0, autoVScroll => 1, onKeyUp => \&keypress_handler, ); # Code my $code_container = $window->insert(Widget => place => { x => 0, relwidth => 1, anchor => 'sw', y => $button_height+1, relheight => 0.6, height => -$button_height-2, }, backColor => cl::White(), ); $code_eval = $code_container->insert(Edit => place => { x => $padding, relwidth => 1, width => -2*$padding, y => $padding, relheight => 1, height => -2*$padding, anchor => 'sw', }, borderWidth => 0, backColor => cl::White(), tabIndent => 4, syntaxHilite => 1, wantTabs => 1, wantReturns => 1, wordWrap => 0, autoIndent => 1, cursorWrap => 1, font => { name => 'monospace', size => 12 }, ); $window->bring_to_front; setup_slide(0); # Run this sucker local $@; eval { $::application->go }; $help_window->close if defined $help_window and $help_window->alive; } sub keypress_handler { my ($self, $code, $key, $mod) = @_; if ($key == kb::Down() or $key == kb::Right() or $key == kb::PgDn()) { $next_button->notify('Click'); } elsif ($key == kb::Up() or $key == kb::Left() or $key == kg::PgUp()) { $prev_button->notify('Click'); } else { $code_eval->notify('KeyUp', $code, $key, $mod); } } ############################################################# # Function that transitions between paragraphs and sections # ############################################################# sub setup_slide { my $number = shift; if ($number == 0) { $prev_button->enabled(0); } else { $prev_button->enabled(1); } if ($number == @demo/3 - 1) { $next_button->enabled(1); $next_button->text('Finish'); } elsif ($number == @demo/3) { # Close the window $window->notify('Destroy'); return; } else { $next_button->enabled(1); $next_button->text('Next'); } $number *= 3; # Set the section title and code $section_title_label->text($demo[$number]); $code_eval->text($demo[$number+2]); # Load the pod $text_pod->open_read; $text_pod->read("=pod\n\n$demo[$number+1]\n\n=cut"); $text_pod->close_read; # Run the demo $run_button->notify('Click'); } # This way, it can be invoked as "perl -MPDL::Demos::Prima" or as # "perl path/to/Prima.pm" if ($0 eq '-' or $0 eq __FILE__) { run; exit; } 1; __DATA__ =head2 use PDL::Graphics::Prima::Simple To get started, you will want to use L. This module provides a set of friendly wrappers for simple, first-cut data visualization. L, the underlying library, is a general-purpose 2D plotting library built as a widget in the L, but we don't need the full functionality for the purposes of this demo. use PDL::Graphics::Prima::Simple; my $x = sequence(100)/10; line_plot($x, $x->sin); =head2 More than just lines! In addition to numerous ways to plot x/y data, you can also plot distributions and images. The best run-down of the simple plotting routines can be found in L. $distribution = grandom(100); hist_plot($distribution); $x = sequence(100)/10; cross_plot($x, $x->sin); $image = rvals(100, 100); matrix_plot($image); =head2 Mouse Interaction Plots allow for L, herein referred to as twiddling. You can resize the window, zoom with the scroll wheel, or click and drag the canvas around. There is also a right-click zoom-rectangle, and a right-click context menu. hist_plot(grandom(100)); # Run this, then try using your mouse In your Perl scripts, and in the PDL shell for some operating systems and some versions of L, twiddling will cause your script to pause when you create a new plot. To resume your script or return execution to the shell, either close the window or press 'q'. # If your PDL shell supports simultaneous # input and plot interaction, running this # should display both plots simultaneously: $x = sequence(100)/10; cross_plot($x, $x->sin); line_plot($x, $x->cos); =head2 Multiple plots without blocking The blocking behavior just discussed is due to what is called autotwiddling. To turn this off, simply send a boolean false value to auto_twiddle. Then, be sure to invoke twiddling when you're done creating your plots. auto_twiddle(0); hist_plot(grandom(100)); matrix_plot(rvals(100, 100)); twiddle(); Once turned off, autotwiddling will remain off until you turn it back on. # autotwiddling still off hist_plot(grandom(100)); matrix_plot(rvals(100, 100)); twiddle(); =head2 Adding a title and axis labels Functions like L, L, and L actually create and return plot objects which you can subsequently modify. For example, adding a title and axis labels are pretty easy. For titles, you call the L. For axis labels, you call the L<label method on the axis objects|PDL::Graphics::Prima::Axis/label>. # Make sure autotwiddling is off in your script auto_twiddle(0); # Build the plot my $x = sequence(100)/10; my $plot = line_plot($x, $x->sin); # Add the title and labels $plot->title('Harmonic Oscillator'); $plot->x->label('Time [s]'); $plot->y->label('Displacement [cm]'); # Manually twiddle once everything is finished twiddle(); =head2 Saving to a file L<PDL::Graphics::Prima::Simple> excels at user interaction, but you can save your plots to a file using L<save_to_file|PDL::Graphics::Prima/save_to_file> or L<save_to_postscript|PDL::Graphics::Prima/save_to_postscript> methods, or by right-clicking and selecting the appropriate menu option. auto_twiddle(0); $x = sequence(100)/10; line_plot($x, $x->sin)->save_to_postscript; # You can supply a filename to the method if you like. # Also available is save_to_file, which saves to raster # file formats. Expect save_to_postscript to be merged # into save_to_file in the future. =head2 Adding additional data to the plot Once you have created a plot, you can L<add additional data to it|PDL::Graphics::Prima/dataSets>. You achieve this by adding a new L<DataSet|PDL::Graphics::Prima::DataSet> with the data you want displayed. auto_twiddle(0); my $plot = hist_plot(grandom(100)); # Add a Gaussian curve that "fits" the data use PDL::Constants qw(PI); my $fit_xs = zeroes(100)->xlinvals(-2, 2); my $fit_ys = exp(-$fit_xs**2 / 2) / sqrt(2*PI); $plot->dataSets->{fit_curve} = ds::Pair($fit_xs, $fit_ys); twiddle(); The default L<plot type|PDL::Graphics::Prima::PlotType/> for L<pairwise data|PDL::Graphics::Prima::DataSet/Pair> is L<Diamonds|PDL::Graphics::Prima::PlotType/ppair::Diamonds>. You can choose a L<different pairwise plot type|PDL::Graphics::Prima::PlotType/Pairs>, or even mix and match L<multiple pairwise plot types|PDL::Graphics::Prima::PlotType/SYNOPSIS>. auto_twiddle(0); my $plot = hist_plot(grandom(100)); # Add a Gaussian curve that "fits" the data use PDL::Constants qw(PI); my $fit_xs = zeroes(200)->xlinvals(-5, 5); my $fit_ys = exp(-$fit_xs**2 / 2) / sqrt(2*PI); $plot->dataSets->{fit_curve} = ds::Pair($fit_xs, $fit_ys, # Use lines plotTypes => [ ppair::Lines( # with a thickness of three pixels lineWidth => 3, # And the color red color => cl::LightRed, ), ppair::Diamonds, ], ); twiddle(); =head2 The plot command If you want to specify everything in one command, you can use the plot function. This lets you put everything together that we've already discussed, including multiple DataSets in a single command, title specification, and x and y axis options. # Generate some data: my $xs = sequence(100)/10 + 0.1; my $ys = $xs->sin + $xs->grandom / 10; my $y_err = $ys->grandom/10; # Plot the data and the fit plot( -data => ds::Pair($xs, $ys, plotTypes => [ ppair::Triangles(filled => 1), ppair::ErrorBars(y_err => $y_err), ], ), -fit => ds::Func(\&PDL::sin, lineWidth => 3, color => cl::LightRed, ), -note => ds::Note( pnote::Text('Incoming Signal', x => 0.2, y => sin(0.2) . '-3em', ), ), title => 'Noisey Sine Wave', x => { label => 'Time [s]', scaling => sc::Log, }, y => { label => 'Measurement [Amp]' }, ); =head2 Enjoy PDL::Graphics::Prima! I hope you've enjoyed the tour, and I hope you find L<PDL::Graphics::Prima|PDL::Graphics::Prima/> to be a useful plotting tool! # Thanks! =head1 AUTHOR David Mertens C<dcmertens.perl@gmail.com> =head1 LICENSE AND COPYRIGHT Copyright (c) 2013, David Mertens. All righs reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic>. =cut �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/Screen.pm���������������������������������������������������������������������������0000644�0601750�0601001�00000002765�12562522364�013241� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Perform pdl demos on terminals package PDL::Demos::Routines; # Copyright (C) 1998 Tuomas J. Lukka. # All rights reserved, except redistribution # with PDL under the PDL License permitted. use Carp; use PDL; @ISA="Exporter"; @EXPORT = qw/comment act actnw output/; $SIG{__DIE__} = sub {die Carp::longmess(@_);}; sub home() { if (-e '/usr/bin/tput') { system 'tput clear'; } elsif ( $^O eq 'MSWin32' ) { system 'cls'; } } sub comment($) { home(); print "----\n"; print $_[0]; my $prompt = "---- (press enter)"; defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> ); } sub act($) { home(); my $script = $_[0]; $script =~ s/^(\s*)output/$1print/mg; print "---- Code:"; print $script; print "---- Output:\n"; my $pack = (caller)[0]; # eval "package $pack; use PDL; $_[0]"; eval "package $pack; use PDL; $_[0]"; print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@; my $prompt = "---- (press enter)"; defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> ); } sub actnw($) { home(); my $script = $_[0]; $script =~ s/^(\s*)output/$1print/mg; print "---- Code:"; print $script; print "---- Output:\n"; my $pack = (caller)[0]; # eval "package $pack; use PDL; $_[0]"; eval "package $pack; use PDL; $_[0]"; print "----\n"; print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@; } sub output {print @_} �����������PDL-2.018/Demos/Transform_demo.pm�������������������������������������������������������������������0000644�0601750�0601001�00000025266�13036512174�014775� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# package PDL::Demos::Transform_demo; use PDL; use PDL::Graphics::PGPLOT::Window; use PDL::Transform; use File::Spec; PDL::Demos::Routines->import(); sub comment($); sub act($); sub output; sub run { local($PDL::debug) = 0; local($PDL::verbose) = 0; ##$ENV{PGPLOT_XW_WIDTH}=0.6; $ENV{PGPLOT_DEV} = $^O =~ /MSWin32/ ? '/GW' : defined($ENV{PGPLOT_DEV}) ? $ENV{PGPLOT_DEV} : "/XWIN"; # try and find m51.fits $d = File::Spec->catdir( "PDL", "Demos" ); $m51path = undef; foreach my $path ( @INC ) { my $check = File::Spec->catdir( $path, $d ); if ( -d $check ) { $m51path = $check; last; } } barf "Unable to find directory ${m51path} within the perl libraries.\n" unless defined $m51path; comment q| This demo illustrates the PDL::Transform module. It requires PGPLOT support in PDL and makes use of the image of M51 kindly provided by the Hubble Heritage group at the Space Telescope Science Institute. |; act q| # PDL::Transform objects embody coordinate transformations. use PDL::Transform; # set up a simple linear scale-and-shift relation $t = t_linear( Scale=>[2,-1], Post=>[100,0]); print $t; |; act q| # The simplest way to use PDL::Transform is to transform a set of # vectors. To do this you use the "apply" method. # Define a few 2-vectors: $xy = pdl([[0,1],[1,2],[10,3]]); print "xy: ", $xy; # Transform the 2-vectors: print "Transformed: ", $xy->apply( $t ); |; act q| # You can invert and compose transformations with 'x' and '!'. $u = t_linear( Scale=>10 ); # A new transformation (simple x10 scale) $xy = pdl([[0,1],[10,3]]); # Two 2-vectors print "xy: ", $xy; print "xy': ", $xy->apply( !$t ); # Invert $t from earlier. print "xy'': ", $xy->apply( $u x !$t ); # Hit the result with $u. |; act q| # PDL::Transform is useful for data resampling, and that's perhaps # the best way to demonstrate it. First, we do a little bit of prep work: # Read in an image ($m51path has been set up by this demo to # contain the location of the file). Transform is designed to # work well with FITS images that contain WCS scientific coordinate # information, but works equally well in pixel space. $m51 = rfits("$m51path/m51.fits",{hdrcpy=>1}); # we use a floating-point version of the image in some of the demos # to highlight the interpolation schemes. (Note that the FITS # header gets deep-copied automatically into the new variable). $m51_fl = $m51->float; # Define a nice, simple scale-by-3 transformation. $ts = t_scale(3); |; act q| #### Resampling with ->map and no FITS interpretation works in pixel space. ### Create a PGPLOT window, and display the original image $dev = $^O =~ /MSWin32/ ? '/GW' : defined($ENV{PGPLOT_DEV}) ? $ENV{PGPLOT_DEV} : "/XW"; $win = pgwin( dev=> $dev, nx=>2, ny=>2, Charsize=>2, J=>1, Size=>[8,6] ); $win->imag( $m51 , { DrawWedge=>0, Title=>"M51" } ); ### Grow m51 by a factor of 3; origin is at lower left # (the "pix" makes the resampling happen in pixel coordinate # space, ignoring the FITS header) $win->imag( $m51->map( $ts, {pix=>1} ) ); $win->label_axes("","","M51 grown by 3 (pixel coords)"); ### Shrink m51 by a factor of 3; origin still at lower left. # (You can invert the transform with a leading '!'.) $win->imag( $m51->map( !$ts, {pix=>1} ) ); $win->label_axes("","","M51 shrunk by 3 (pixel coords)"); |; act q| # You can work in scientific space (or any other space) by # wrapping your main transformation with something that translates # between the coordinates you want to act in, and the coordinates # you have. Here, "t_fits" translates between pixels in the data # and arcminutes in the image plane. ### Clear the panel and start over $win->panel(4); # (Clear whole window on next plot) $win->imag( $m51, { Title=>"M51" } ); ### Scale in scientific coordinates. # Here's a way to scale in scientific coordinates: # wrap our transformation in FITS-header transforms to translate # the transformation into scientific space. $win->imag( $m51->map( !$ts->wrap(t_fits($m51)), {pix=>1} ) ); $win->label_axes("","","M51 shrunk 3x (sci. coords)"); |; act q| # If you don't specify "pix=>1" then the resampler works in scientific # FITS coordinates (if the image has a FITS header): ### Scale in scientific coordinates (origin at center of galaxy) $win->fits_imag( $m51->map( $ts, $m51->hdr ), { Title=>"M51 3x" } ); ### Instead of setting up a coordinate transformation you can use the # implicit FITS header matching. Just tweak the template header: $tohdr = $m51->hdr_copy; $tohdr->{CDELT1} /= 3; # Magnify 3x in horiz direction $tohdr->{CDELT2} /= 3; # Magnify 3x in vert direction ### Resample to match the new FITS header # (Note that, although the image is scaled exactly the same as before, # this time the scientific coordinates have scaled too.) $win->fits_imag( $m51->map( t_identity(), $tohdr ), { Title=>"3x (FITS)" } ); |; act q| ### The three main resampling methods are "sample", "linear", and "jacobian". # Sampling is fastest, linear interpolation is better. Jacobian resampling # is slow but prevents aliasing under skew or reducing transformations. $win->fits_imag( $m51_fl , {Title=>"M51"} ); $win->fits_imag( $m51_fl->map( $ts, $m51_fl, { method=>"sample" } ), {Title=>"M51 x3 (sampled)"} ); $win->fits_imag( $m51_fl->map( $ts, $m51_fl, { method=>"linear" } ), { Title=>"M51 x3 (interp.)"} ); $win->fits_imag( $m51_fl->map( $ts, $m51_fl, { method=>"jacobian" } ), { Title=>"M51 x3 (jacob.)"} ); |; act q| ### Linear transformations are only the beginning. Here's an example # using a simple nonlinear transformation: radial coordinate transformation. ### Original image $win->fits_imag( $m51 ,{Title=>"M51"}); ### Radial structure in M51 (linear radial scale; origin at (0,0) by default) $tu = t_radial( u=>'degree' ); $win->fits_imag( $m51_fl->map($tu), { Title=>"M51 radial (linear)", J=>0}); ### Radial structure in M51 (conformal/logarithmic radial scale) $tu_c = t_radial( r0=>0.1 ); # Y axis 0 is at 0.1 arcmin $win->panel(3); $win->fits_imag( $m51_fl->map($tu_c), { Title=>"M51 radial (conformal)", YRange=>[0,4] } ); |; # NOTE: # need to 'double protect' the \ in the label_axes() # since it's being evaluated twice (I think) # act q| ##################### # Wrapping transformations allows you to work in a convenient # space for what you want to do. Here, we can use a simple # skew matrix to find (and remove) logarithmic spiral structures in # the galaxy. The "unspiraled" images shift the spiral arms into # approximate straight lines. $sp = 3.14159; # Skew by 3.14159 # Skew matrix $t_skew = t_linear(pre => [$sp * 130, 0] , matrix => pdl([1,0],[-$sp,1])); # When put into conformal radial space, the skew turns into 3.14159 # radians per scale height. $t_untwist = t_wrap($t_skew, $tu_c); # Press enter to see the result of these transforms... |; act q| ############################## # Note that you can use ->map and ->unmap as either PDL methods # or transform methods; what to do is clear from context. # Original image $win->fits_imag($m51, {Title => "M51"} ); # Skewed $win->fits_imag( $m51_fl->map( $t_skew ), { Title => "M51 skewed by \\\\gp in spatial coords" } ); # Untwisted -- show that m51 has a half-twist per scale height $win->fits_imag( $m51_fl->map( $t_untwist ), { Title => "M51 unspiraled (\\\\gp / r\\\\ds\\\\u)"} ); # Untwisted -- the jacobean method uses variable spatial filtering # to eliminate spatial artifacts, at significant computational cost # (This may take some time to complete). $win->fits_imag( $m51_fl->map( $t_untwist, {m=>jacobean}), { Title => "M51 unspiraled (\\\\gp / r\\\\ds\\\\u; antialiased)" } ); |; $win->close; act q| ### Native FITS interpretation makes it easy to view your data in ### your preferred coordinate system. Here we zoom in on a 0.2x0.2 ### arcmin region of M51, sampling it to 100x100 pixels resolution. $m51 = float $m51; $data = $m51->match([100,100],{or=>[[-0.05,0.15],[-0.05,0.15]]}); $s = "M51 closeup ("; $ss=" coords)"; $ps = " (pixels)"; $dev = $^O =~ /MSWin32/ ? '/GW' : defined($ENV{PGPLOT_DEV}) ? $ENV{PGPLOT_DEV} : "/XW"; $w1 = pgwin( dev=> $dev, size=>[4,4], charsize=>1.5, justify=>1 ); $w1->imag( $data, 600, 750, { title=>"${s}pixel${ss}", xtitle=>"X$ps", ytitle=>"Y$ps" } ); $w1->hold; $w2 = pgwin( dev=> $dev, size=>[4,4], charsize=>1.5, justify=>1 ); $w2->fits_imag( $data, 600, 750, { title=>"${s}sci.${ss}", dr=>0 } ); $w2->hold; # Now please separate the two X windows on your screen, and press ENTER. ############################### |; act q| ### Now rotate the image 360 degrees in 10 degree increments. ### The 'match' method resamples $data to the rotated scientific ### coordinate system in $hdr. The "pixel coordinates" window shows ### the resampled data in their new pixel coordinate system. ### The "sci. coordinates" window shows the data remaining fixed in ### scientific space, even though the pixels that represent them are ### moving and rotating. $hdr = $data->hdr_copy; for( $rot=0; $rot<=360; $rot += 10 ) { $hdr->{CROTA2} = $rot; $d = $data->match($hdr); $w1->imag( $d, 600, 750 ); $w2->fits_imag($d, 600, 750, {dr=>0}); } |; act q| ### You can do the same thing even with nonsquare coordinates. ### Here, we resample the same region in scientific space into a ### 150x50 pixel array. $data = $m51->match([150,50],{or=>[[-0.05,0.15],[-0.05,0.15]]}); $hdr = $data->hdr_copy; $w1->release; $w1->imag( $data, 600, 750, { title=>"${s}pixel${ss}", xtitle=>"X$ps", ytitle=>"Y$ps", pix=>1 } ); $w1->hold; for( $rot=0; $rot<=750; $rot += 5 ) { $hdr->{CROTA2} = $rot; $d = $data->match($hdr); $w1->imag($d, 600, 750); $w2->fits_imag($d, 600, 750, {dr=>0}); } |; comment q| This concludes the PDL::Transform demo. Be sure to check the documentation for PDL::Transform::Cartography, which contains common perspective and mapping coordinate systems that are useful for work on the terrestrial and celestial spheres, as well as other planets &c. |; $w1->release; $w1->close; undef $w1; $w2->release; $w2->close; undef $w2; undef $win; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/�������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�012274� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/mandel.pl����������������������������������������������������������������������0000644�0601750�0601001�00000002130�12562522364�014105� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������$|=1; use PDL; use PDL::Graphics::TriD; use Time::HiRes qw(sleep); # use PDL::Dbg; # PDL::Core::set_debugging(1); $size = 100; $a = zeroes(float,$size,$size); $res = $a->copy; $resc0 = $res->clump(2); $resc = $resc0; $resi = xvals $resc; $inds0 = $resi; $re00 = 2*(xvals $a)->clump(2)/$size-1.5; $im00 = 2*(yvals $a)->clump(2)/$size-0.5; $re0 = $re00; $im0 = $im00; $im = $im0; $re = $re0; $im2 = $im; $re2 = $re; for(1..60) { $rp = ($resc == 0) * ($im2 ** 2 + $re2 ** 2 > 2) * $_; $resc += $rp; if(1) { $inds = ($resc == 0)->which->long->sever; $inds1 = $inds0->index($inds)->sever; $inds0 = $inds1; $re0 = $re00->index($inds1)->sever; $im0 = $im00->index($inds1)->sever; $re = $re->index($inds)->sever; $im = $im->index($inds)->sever; $resi = $resi->index($inds)->sever; # Use inds1 here so that resc propagates back only one step. $resc = $resc0->index($inds1); } $re2 = $re ** 2 - $im ** 2; $im2 = 2 * $re * $im; $re2 += $re0; $im2 += $im0; $re = $re2; $im = $im2; nokeeptwiddling3d(); my $r = $res/max($res); imagrgb [$r,1-$r,$r] if $_ % 2 == 0; sleep 0.05; } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/test3.p������������������������������������������������������������������������0000644�0601750�0601001�00000004067�12562522364�013546� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; use Carp; $SIG{__DIE__} = sub {die Carp::longmess(@_);}; use PDL; #$PDL::Graphics::TriD::verbose=1; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; use PDL::IO::Pic; use PDL::Graphics::TriD::GoBoard; # Calculate some random function print "START\n"; sub snap { if(1) {return} my $ppdl = grabpic3d(); print "GOT PICTURE!\n"; wpic $ppdl,"$_[0].jpg"; system("xv $_[0].jpg"); } $gob = pdl [ [ [1, 0, 0, 0], [0, 1, 0, 0], [0, 0, 1, 0], [0, 0, 0, 1], ], [ [0.5, 0.5, 0, 0], [0.5, 0, 0.5, 0], [0.5, 0, 0, 0.5], [0, 0, 0.5, 0.5], ], [ [0.33, 0.33, 0.33, 0], [0.33, 0.33, 0, 0.33], [0.33, 0, 0.33, 0.33], [0, 0.33, 0.33, 0.33], ], [ [0.25, 0.25, 0.25, 0.25], [0.25, 0.25, 0.25, 0.25], [0.25, 0.25, 0.25, 0.25], [0.25, 0.25, 0.25, 0.25], ] ]; $gob2 = $gob->slice(":,1:2,1:2"); $gob3 = $gob->slice(":,2:3,2:3"); $b = new PDL::Graphics::TriD::GoBoard({Data => $gob}); $b->add_inlay($gob2,1,1,0.25); $b->add_inlay($gob3,2,2,0.5); if(1) { $win = PDL::Graphics::TriD::get_current_window(); $win->clear_objects(); $win->add_object($b); $win->twiddle(); } snap "pic0"; # $f = zeroes(10,10); # $foo = cos(xvals($f)/1.5) * cos(yvals($f)/1.5)/2; $t = xvals zeroes 30,30; $u = yvals zeroes 30,30; $x = sin($u*0.5 + $t * 0.1)/2+0.5; $y = cos($u*0.3 + $t * 0.27)/2+0.5; $z = cos($u*0.1 + $t * 0.56)/2+0.5; PDL::Graphics::TriD::imagrgb([$x,$y,$z]); snap "pic1.1"; $x .= $t / 30; $y .= $u / 30; $z .= 0.5*($t + $u)/30; $r = zeroes(4,4,4,4)+0.1; $g = zeroes(4,4,4,4); $b = zeroes(4,4,4,4); ($tmp = $r->slice(":,:,2,2")) .= 1; ($tmp = $r->slice(":,:,:,1")) .= 0.5; ($tmp = $g->slice("2,:,1,2")) .= 1; ($tmp = $b->slice("2,3,1,:")) .= 1; $t = 0.1 * xvals zeroes 300; $x = sin($t * 0.1)/2+0.5; $y = cos($t * 0.27)/2+0.5; $z = cos($t * 0.56)/2+0.5; line3d([$x,$y,$z],[$x,1-$x,0]); snap "pic4"; $f = zeroes(3,3); $foo = ((xvals $f) - 2) ** 2 + ((yvals $f) -2) ** 2; print $foo; print "TOIMAG\n"; PDL::Graphics::TriD::imag3d([$foo]); # Use default values to make a 3D plot. # Stops here for rotating until user presses 'q'. snap "pic5"; print "OUTOFIMAG\n"; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/test4.p������������������������������������������������������������������������0000644�0601750�0601001�00000002503�12562522364�013540� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� use blib; use Carp; $SIG{__DIE__} = sub {die Carp::longmess(@_);}; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; use PDL::IO::Pic; $s = 10; $k = zeroes($s,$s); $x = $k->xvals(); random($k->inplace); $x += $k; $y = $k->yvals(); random($k->inplace); $y += $k; random($k->inplace); $z = $k; $x /= $s; $y /= $s; $z /= $s; $a = new PDL::Graphics::TriD::Lattice([$x,$y,$z]); $b = new PDL::Graphics::TriD::Points([$x,$y,$z+1]); $win = PDL::Graphics::TriD::get_current_window(); $win->clear_objects(); $win->add_object($a); $win->add_object($b); #$PDL::Graphics::TriD::verbose=1; #$win->twiddle(); #exit; $nx = zeroes(3,20); $nc = zeroes(3,20); random($nx->inplace); random($nc->inplace); print "NX: $nx, NC: $nc\n"; use PDL::Graphics::OpenGL; # glShadeModel (&GL_FLAT); glShadeModel (&GL_SMOOTH); $lb = $win->glpRasterFont("5x8",0,255); print "LIST: $lb\n"; $win->add_object(new TOBJ()); $win->twiddle(); package TOBJ; BEGIN{@TOBJ::ISA = qw/PDL::Graphics::TriD::Object/;} use PDL::Graphics::OpenGLQ; use PDL::Graphics::OpenGL; sub new { bless {},$_[0]; } sub togl { glDisable(&GL_LIGHTING); line_3x_3c( # $::x->slice("0:2"),$::y->slice("0:2") $::nx,$::nc ); glColor3f(1,0,1); glRasterPos3f(0,0,0.5); PDL::Graphics::OpenGL::glpPrintString($::lb,"HELLO HELLO HELLO GLWORLD!!!"); glEnable(&GL_LIGHTING); } ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/test5.p������������������������������������������������������������������������0000644�0601750�0601001�00000002174�12562522364�013545� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� use blib; use Carp; $SIG{__DIE__} = sub {die Carp::longmess(@_);}; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; use PDL::IO::Pic; use PDL::Graphics::TriD::Graph; use PDL::Graphics::OpenGL; $g = new PDL::Graphics::TriD::Graph(); $g->default_axes(); $a = PDL->zeroes(3,1000); random($a->inplace); $g->add_dataseries(new PDL::Graphics::TriD::Points($a,$a),"pts"); $g->bind_default("pts"); $b = PDL->zeroes(3,30,30); axisvalues($b->slice("(0)")); axisvalues($b->slice("(1)")->xchg(0,1)); $b /= 30; random($b->slice("(2)")->inplace); ($tmp = $b->slice("(2)")) /= 5; $tmp += 2; $c = PDL->zeroes(3,30,30); random($c->inplace); $g->add_dataseries(new PDL::Graphics::TriD::SLattice($b,$c),"slat"); $g->bind_default("slat"); # $g->add_dataseries(new PDL::Graphics::TriD::Lattice($b,(PDL->pdl(0,0,0)->dummy(1)->dummy(1))), # "blat"); # $g->bind_default("blat"); $g->add_dataseries(new PDL::Graphics::TriD::SCLattice($b+1,$c->slice(":,0:-2,0:-2")), "slat2"); $g->bind_default("slat2"); $g->scalethings(); $win = PDL::Graphics::TriD::get_current_window(); $win->clear_objects(); $win->add_object($g); $win->twiddle(); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/test7.p������������������������������������������������������������������������0000644�0601750�0601001�00000001231�12562522364�013540� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; use Carp; $SIG{__DIE__} = sub {die Carp::longmess(@_);}; use PDL; use PDL::Graphics::TriD; $nx = 20; $t = (xvals zeroes $nx+1,$nx+1)/$nx; $u = (yvals zeroes $nx+1,$nx+1)/$nx; $x = sin($u*15 + $t * 3)/2+0.5 + 5*($t-0.5)**2; # Need to specify type first because points doesn't default to anything points3d([SURF2D,$x]); line3d([SURF2D,$x]); mesh3d([$x]); imag3d([$x],{Lines => 0}); imag3d([$x],{Lines => 0, Smooth => 1}); imag3d([$x]); # Then, see the same image twice... my $ox = $x->dummy(2,2)->zvals; # 0 for first, 1 for second surface. imag3d([$x * ($ox-0.5) + $ox ],{Smooth => 1}); imag3d([$x * ($ox-0.5) + $ox ],{Lines => 0,Smooth => 1}); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/test8.p������������������������������������������������������������������������0000644�0601750�0601001�00000004564�12562522364�013555� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; use Carp; $SIG{__DIE__} = sub {die Carp::longmess(@_);}; use PDL; use PDL::Graphics::TriD; use PDL::Opt::Simplex; use PDL::Dbg; my $asize = 5000; my $follow = zeroes(3,4,$asize); my $followc = zeroes(4,$asize); my $follows = $follow->oneslice(2,0,1,0); my $followcs = $followc->oneslice(1,0,1,0); my $folt = $follows->get_trans(); my $folct = $followcs->get_trans(); sub d2c { my($mf) = @_; $mf = $mf-min($mf); $mf += (100-$mf)*($mf > 100); $mf /= 100; return (1-$mf)**6; } sub func { my($x) = $_[0]->slice("(0)"); my($y) = $_[0]->slice("(1)"); my($z) = $_[0]->slice("(2)"); return $x**2 + ($y-$x**2)**2 + $z**2; } die << "EOD"; This example is disabled since the required 'foomethod' has been disabled in recent versions of PDL. Contact pdl-porters if you feel you need this functionality. EOD my $a = zeroes(3,10000); random $a->inplace; $a -= 0.5; $a *= 30; $mf = d2c(func($a)); points3d($a,[$mf]); PDL::Graphics::OpenGL::glShadeModel (&PDL::Graphics::OpenGL::GL_SMOOTH); $PDL::debug = 1; my $win = PDL::Graphics::TriD::get_current_window(); my $g = PDL::Graphics::TriD::get_current_graph(); $fcc = [$followcs,pdl(0.2),$followcs]; PDL::Graphics::TriD::Rout::combcoords(@$fcc,(my $fccs = PDL->null)); my $line = new PDL::Graphics::TriD::LineStrip($follows->px,$fccs->px); # $win->add_object($line); $g->add_dataseries($line,"line"); $g->bind_default("line"); my $ndone = 0; my $nrounds = 0; my $perround = 1; ($optimum,$simplex) = simplex( pdl(10.0,10.0,10.0), 0.9, 0.00000001, $asize*$perround+100, \&func, sub { $win->twiddle(1,1); # print $_[0],$_[1]; # print "NDONE: $ndone\n"; if($ndone == $asize) { return; } $nrounds++; # $follow->dump(); # $followc->dump(); # $followcs->dump(); ($tmp = $follow->slice(":,:,($ndone)")) .= $_[0]; ($tmp = $followc->slice(":,($ndone)")) .= d2c($_[1]); $ndone++; if($nrounds % $perround != 0) {return} # print "FOLLOW1:\n"; # $follow->dump(); $folt->call_trans_foomethod(0,1,$ndone); $folct->call_trans_foomethod(0,1,$ndone); # $fccs->dump; # $followc->dump; # $followcs->dump(); # print $fccs; # print "FOLLOW2:\n"; # $follow->dump(); $line->data_changed(); $win->twiddle(1); # print "FOLLOWS: \n"; # $follows->dump(); # print "NDONE: $ndone\n"; # print "FOLLOW:\n"; # $follow->dump(); # print "FOLSL: ",$follow->slice(":,:,0:6"); # print "FOLS: ",$follows; } ,0 ); $win->twiddle(); ��������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/test9.p������������������������������������������������������������������������0000644�0601750�0601001�00000000775�12562522364�013556� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; use Carp; # $SIG{__DIE__} = sub {die Carp::longmess(@_);}; use PDL; use PDL::Graphics::TriD; use PDL::IO::Pic; use PDL::Graphics::TriD::Polygonize; $orig = PDL->pdl(0,0,0)->float; sub func1 { my($x,$y,$z) = map {$_[0]->slice("($_)")} 0..2; $r = $x**2 + 1.5*$y**2 + 0.3 * $z**2 + 5*($x**2-$y)**2; $res = ($r - 1) * -1; # print $res; return $res; } $a = PDL::Graphics::TriD::StupidPolygonize::stupidpolygonize($orig, 5, 50, 10,\&func1) ; # print $a; imag3d $a,{Lines => 0, Smooth => 1}; ���PDL-2.018/Demos/TriD/testimg.p����������������������������������������������������������������������0000644�0601750�0601001�00000001255�12562522364�014154� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; use Carp; $SIG{__DIE__} = sub {die Carp::longmess(@_);}; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; use PDL::IO::Pic; $PDL::Graphics::TriD::verbose=0; $win = PDL::Graphics::TriD::get_current_window(); $vp = $win->new_viewport(0,0,1,1); # Here we show an 8-dimensional (!!!!!) RGB image to test Image.pm $r = zeroes(4,5,6,7,2,2,2,2)+0.1; $g = zeroes(4,5,6,7,2,2,2,2); $b = zeroes(4,5,6,7,2,2,2,2); ($tmp = $r->slice(":,:,2,2")) .= 1; ($tmp = $r->slice(":,:,:,1")) .= 0.5; ($tmp = $g->slice("2,:,1,2")) .= 1; ($tmp = $b->slice("2,3,1,:")) .= 1; $vp->clear_objects(); $vp->add_object(new PDL::Graphics::TriD::Image([$r,$g,$b])); $win->twiddle(); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/testvib.p����������������������������������������������������������������������0000644�0601750�0601001�00000003442�12562522364�014160� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib ; use PDL; use PDL::Graphics::TriD; # $PDL::Graphics::TriD::verbose=1; $offs = 0.0; $tc = 0.2; $fc = $tc * 0.4; $sc = $tc * 3.2;; $fric = 0.02; $bc = 1-$fric*$tc; $size = 80 ; $a = zeroes(float(),$size,$size); $b = ((rvals $a) < $size/2)->float; $c = (rvals ($size,$size,{Centre=>[$size/3,$size/3]}))->float ; $c2 = (rvals ($size,$size,{Centre=>[$size/3,$size/2]}))->float ; # $sdiv = 12/$size; $sdiv = 20/$size; $a .= exp(-($sdiv*$c) ** 2)->float; $a -= exp(-($sdiv*$c2) ** 2)->float; $a *= $b; if(0) { $a->set(8,8,0.3); $a->set(8,9,0.5); $a->set(9,8,0.5); $a->set(9,9,1); $a->set(10,8,0.3); $a->set(10,9,0.5); $a->set(8,10,0.3); $a->set(9,10,0.5); $a->set(10,10,0.3); } $asl1 = $a->slice("0:-3,1:-2"); $asl2 = $a->slice("1:-2,0:-3"); $asl3 = $a->slice("2:-1,1:-2"); $asl4 = $a->slice("1:-2,2:-1"); $ach = $a->slice("1:-2,1:-2"); $bch = $b->slice("1:-2,1:-2"); $s = $ach * 0; $round = 0; $win = PDL::Graphics::TriD::get_current_window(); # points3d([SURF2D,$a]); $g = PDL::Graphics::TriD::get_current_graph(); keeptwiddling3d(1); $surf = new PDL::Graphics::TriD::SLattice_S([$a]); if(0) { $g->add_dataseries($surf,"surf"); $g->bind_default("surf"); $g->scalethings(); $g->PDL::Graphics::TriD::Object::changed(); $win->add_object($g); $win->twiddle(); } else { $win->add_object($surf); } $a->set(0,0,$offs); $a->set(1,0,-$offs); # $as = $a->slice(""); # $as->doflow(1); while(1) { $aav = ($asl1 + $asl2 + $asl3 + $asl4)/4; $da = ($aav - $ach) * $fc; $da *= $bch; $s += $da; $s *= $bc; $ach += $s * $sc; print $round,"\n"; if($round % 5 == 0) { if(0) { $surf->data_changed(); # $g->data_changed(); $g->PDL::Graphics::TriD::Object::changed(); $win->changed(); $win->twiddle(1); } else { imag3d([$a],{KeepTwiddling => 0}); } } $round++; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/tmathgraph.p�������������������������������������������������������������������0000644�0601750�0601001�00000002003�12562522364�014627� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Graph; use PDL::Graphics::TriD::MathGraph; use PDL::Graphics::TriD::Labels; $g = PDL::Graphics::TriD::get_new_graph(); $g->default_axes(); $coords = [ [ 0,-1,0 ], [ -1,-1,-2], [3,5,2], [2,1,-3], [1,3,1], [1,1,2], ]; $from = PDL->pdl([0,1,2,3,4,4,4,5,5,5]); $to = PDL->pdl([1,2,3,1,0,2,3,0,1,2]); for(@$coords) { push @$names,join ",",@$_; } $e = new PDL::GraphEvolver(scalar @$coords); $e->set_links($from,$to,PDL->ones(1)); $c = $e->getcoords; $g->add_dataseries($lab = new PDL::Graphics::TriD::Labels($c,{Strings => $names}), "foo1"); $g->bind_default("foo1"); $g->add_dataseries($lin = new PDL::Graphics::TriD::MathGraph( $c, {From => $from, To => $to}),"foo2"); $g->bind_default("foo2"); $g->scalethings(); nokeeptwiddling3d(); twiddle3d(); while(1) { $e->step(); if(++$ind%2 == 0) { $lab->data_changed(); $lin->data_changed(); $g->scalethings() if (($ind % 200) == 0 or 1); print "C: $c\n" if $verbose; twiddle3d(); } } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/tvrml.p������������������������������������������������������������������������0000644�0601750�0601001�00000002560�12562522364�013644� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BEGIN { $PDL::Graphics::TriD::device = "VRML"; print "====================================\n"; print " VRML not available...stopping demo \n"; print "====================================\n"; exit; } use PDL::Graphics::TriD; use PDL::LiteF; use Carp; # $PDL::Graphics::TriD::verbose=1; $SIG{__DIE__} = sub {print Carp::longmess(@_); die;}; $set = tridsettings(); $set->browser_com('netscape/unix'); $nx = 5; $t = (xvals zeroes $nx+1,$nx+1)/$nx; $u = (yvals zeroes $nx+1,$nx+1)/$nx; $x = sin($u*15 + $t * 3)/2+0.5 + 5*($t-0.5)**2; $cx = PDL->zeroes(3,$nx+1,$nx+1); random($cx->inplace); $pdl = PDL->zeroes(3,20); $pdl->inplace->random; $cols = PDL->zeroes(3,20); $cols->inplace->random; $g = PDL::Graphics::TriD::get_new_graph; $name = $g->add_dataseries(new PDL::Graphics::TriD::Points($pdl,$cols)); $g->bind_default($name); $name = $g->add_dataseries(new PDL::Graphics::TriD::Lattice([SURF2D,$x])); $g->bind_default($name); $name = $g->add_dataseries(new PDL::Graphics::TriD::SLattice_S([SURF2D,$x+1],$cx, {Smooth=>1,Lines=>0})); $g->bind_default($name); $g->scalethings(); describe3d('A simple test of the current PDL 3D VRML module'); $win = PDL::Graphics::TriD::get_current_window(); use PDL::Graphics::TriD::Logo; $win->add_object(new PDL::Graphics::TriD::Logo); #use Data::Dumper; #my $out = Dumper($win); #print $out; $win->display('netscape'); ������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD/tvrml2.p�����������������������������������������������������������������������0000644�0601750�0601001�00000003413�12562522364�013724� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BEGIN { $PDL::Graphics::TriD::device = "VRML"; print "====================================\n"; print " VRML not available...stopping demo \n"; print "====================================\n"; exit; } BEGIN{ PDL::Graphics::VRMLNode->import(); PDL::Graphics::VRMLProto->import(); } use PDL::Graphics::TriD; use PDL::LiteF; use Carp; $SIG{__DIE__} = sub {print Carp::longmess(@_); die;}; $set = tridsettings(); $set->browser_com('netscape/unix'); #$set->set(Compress => 1); $nx = 20; $t = (xvals zeroes $nx+1,$nx+1)/$nx; $u = (yvals zeroes $nx+1,$nx+1)/$nx; $x = sin($u*15 + $t * 3)/2+0.5 + 5*($t-0.5)**2; $cx = PDL->zeroes(3,$nx+1,$nx+1); random($cx->inplace); $pdl = PDL->zeroes(3,20); $pdl->inplace->random; $cols = PDL->zeroes(3,20); $cols->inplace->random; $g = PDL::Graphics::TriD::get_new_graph; $name = $g->add_dataseries(new PDL::Graphics::TriD::Points($pdl,$cols)); $g->bind_default($name); $name = $g->add_dataseries(new PDL::Graphics::TriD::Lattice([SURF2D,$x])); $g->bind_default($name); $name = $g->add_dataseries(new PDL::Graphics::TriD::SLattice_S([SURF2D,$x+1],$cx, {Smooth=>1,Lines=>0})); $g->bind_default($name); $g->scalethings(); $win = PDL::Graphics::TriD::get_current_window(); require PDL::Graphics::VRML::Protos; PDL::Graphics::VRML::Protos->import(); #$win->{VRMLTop}->register_proto(PDL::Graphics::VRML::Protos::PDLBlockText10()); #$win->{VRMLTop}->uses('PDLBlockText10'); #$win->current_viewport()->add_object(new PDL::Graphics::TriD::VRMLObject( # vrn(Transform, # translation => '0 0 -1', # children => # [new PDL::Graphics::VRMLNode('PDLBlockText10') # ] # ) # )); $win->display('netscape'); exit; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD1.pm����������������������������������������������������������������������������0000644�0601750�0601001�00000007304�12562522364�012737� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright (C) 1998 Tuomas J. Lukka. # All rights reserved, except redistribution # with PDL under the PDL License permitted. package PDL::Demos::TriD1; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; PDL::Demos::Routines->import(); sub comment($); sub act($); sub actnw($); sub output; sub run { comment q| Welcome to a short tour of the capabilities of PDL::Graphics::TriD. Press 'q' in the graphics window for the next screen. Rotate the image by pressing mouse button one and dragging in the graphics window. Zoom in/out by pressing MB3 and drag up/down. Note that a standalone TriD script must start with use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; to work properly. |; actnw q| # Number of subdivisions for lines / surfaces. $size = 25; $cz = (xvals zeroes $size+1) / $size; # interval 0..1 $cx = sin($cz*12.6); # Corkscrew $cy = cos($cz*12.6); line3d [$cx,$cy,$cz]; # Draw a line # [press 'q' in the graphics window when done] |; actnw q| $r = sin($cz*6.3)/2 + 0.5; $g = cos($cz*6.3)/2 + 0.5; $b = $cz; line3d [$cx,$cy,$cz], [$r,$g,$b]; # Draw a colored line # [press 'q' in the graphics window when done] |; actnw q| $x = (xvals zeroes $size+1,$size+1) / $size; $y = (yvals zeroes $size+1,$size+1) / $size; $z = 0.5 + 0.5 * (sin($x*6.3) * sin($y*6.3)) ** 3; # Bumps line3d [$x,$y,$z]; # Draw several lines # [press 'q' in the graphics window when done] |; actnw q| $r = $x; $g = $y; $b = $z; line3d [$x,$y,$z], [$r,$g,$b]; # Draw several colored lines # [press 'q' in the graphics window when done] |; actnw q| lattice3d [$x,$y,$z], [$r,$g,$b]; # Draw a colored lattice # [press 'q' in the graphics window when done] |; actnw q| points3d [$x,$y,$z], [$r,$g,$b], {PointSize=>4}; # Draw colored points # [press 'q' in the graphics window when done] |; actnw q| imag3d_ns [$x,$y,$z], [$r,$g,$b]; # Draw a colored surface # [press 'q' in the graphics window when done] |; actnw q| imag3d [$x,$y,$z]; # Draw a shaded surface # [press 'q' in the graphics window when done] |; actnw q| hold3d(); # Leave the previous object in.. imag3d_ns [$x,$y,$z+1], [$r,$g,$b]; # ...and draw a colored surface on top of it... # [press 'q' in the graphics window when done] |; actnw q| lattice3d [$x,$y,$z-1], [$r,$g,$b]; # ...and draw a colored lattice under it... # [press 'q' in the graphics window when done] |; actnw q| nokeeptwiddling3d(); # Don't wait for user while drawing for(-2,-1,0,1,2) { line3d [$cx,$cy,$cz+$_]; # ... and corkscrews... } keeptwiddling3d(); # Do wait for user while drawing... twiddle3d(); # and actually, wait right now. release3d(); # [press 'q' in the graphics window when done] |; actnw q| # The reason for the [] around $x,$y,$z: # 1. You can give all the coordinates and colors in one piddle. $c = (zeroes 3,$size+1) / $size; $coords = sin((3+3*xvals $c)*yvals $c); $colors = $coords; line3d $coords, $colors; # Draw a curved line, colored # (this works also for lattices, etc.) # [press 'q' in the graphics window when done] |; actnw q| # 2. You can use defaults inside the brackets: lattice3d [$z], [$r]; # Note: no $x, $y, and $r is greyscale # [press 'q' in the graphics window when done] |; actnw q| # 3. You can plot in certain other systems as defaults imag3d_ns [POLAR2D, $z], [$r, $g, $b]; # Draw the familiar # bumpy surface in polar # coordinates # [press 'q' in the graphics window when done] |; actnw q| # One last thing: you can plot a color image like this imagrgb([$r,$g,$b]); # [press 'q' in the graphics window when done] |; comment q| '3d2' contains some of the more special constructions available in the PDL::Graphics::TriD modules. |; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriD2.pm����������������������������������������������������������������������������0000644�0601750�0601001�00000006031�12562522364�012734� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright (C) 1998 Tuomas J. Lukka. # All rights reserved, except redistribution # with PDL under the PDL License permitted. package PDL::Demos::TriD2; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; PDL::Demos::Routines->import(); sub comment($); sub act($); sub actnw($); sub output; sub run { comment q| Welcome to a short tour of the more esoteric capabilities of PDL::Graphics::TriD. As in '3d', press 'q' in the graphics window for the next screen. Rotate the image by pressing mouse button one and dragging in the graphics window. Note that the script must start with use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; to work. |; actnw q| # Number of subdivisions for lines / surfaces. $size = 25; # You remember this from the first 3d demo, right? $r = (xvals zeroes $size+1,$size+1) / $size; $g = (yvals zeroes $size+1,$size+1) / $size; $b = ((sin($r*6.3) * sin($g*6.3)) ** 3)/2 + 0.5; # Bumps imagrgb [$r,$g,$b]; # Draw an image # [press 'q' in the graphics window when done] |; actnw q| # How about this? imagrgb3d([$r,$g,$b]); # Draw an image on the lower plane # [press 'q' in the graphics window when done] |; actnw q| # Let's add the real image on top of this... hold3d(); imag3d([$r,$g,$b+0.1], [$r,$g,$b]); # For the next demo, please rotate this so that much # of the image is visible. # Don't make your window too big or you might run out of memory # at the next step. # [press 'q' in the graphics window when done] |; actnw q| # Warning: your mileage will vary based on which # OpenGL implementation you are using :( # Let's grab this picture... $pic = grabpic3d(); # Lighten it up a bit so you see the background, # black on black is confusing $l = 0.3; $pic = ($pic + $l) / (1 + $l); # And plot it in the picture ;) ;) hold3d(); # You remember, we leave the previous one in... $o0 = imagrgb3d($pic, {Points => [[0,0,0],[0,1,0],[0,1,1],[0,0,1]]}); # Because we have the data in $pic, we could just as easily # save it in a jpeg using the PDL::Io::Pic module - or read # it from one. # [press 'q' in the graphics window when done] |; actnw q| # That was fun - let's do that again! $pic1 = grabpic3d(); # Lighten it up $pic1 = ($pic1 + $l) / (1 + $l); # And plot it in the picture ;) ;) hold3d(); # You remember, we leave the previous one in... $o1 = imagrgb3d($pic1, {Points => [[0,0,0],[1,0,0],[1,0,1],[0,0,1]]}); # [press 'q' in the graphics window when done] |; actnw q| # Now, let's update them in real time! nokeeptwiddling3d(); # Don't wait for user while drawing while(1) { $p = grabpic3d(); $p = ($p + $l) / (1 + $l); $pic .= $p; $pic1 .= $p; $o0->data_changed(); $o1->data_changed(); last if twiddle3d(); # exit from loop when 'q' pressed } # [press 'q' in the graphics window when done] |; actnw q| # Finally, leave 3d in a sane state keeptwiddling3d(); # Don't wait for user while drawing release3d(); # [press 'q' in the graphics window when done] |; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Demos/TriDGallery.pm����������������������������������������������������������������������0000644�0601750�0601001�00000014316�13036512174�014172� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright (C) 1998 Tuomas J. Lukka. # All rights reserved, except redistribution # with PDL under the PDL License permitted. package PDL::Demos::TriDGallery; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Image; PDL::Demos::Routines->import(); sub comment($); sub act($); sub actnw($); sub output; sub run { comment q| Welcome to the TriD Gallery The following selection of scripts demonstrates that you can generate interesting images with PDL (and the TriD modules) with just a few lines of code. These are the rules for scripts to be accepted for this category: 1) Must be legal Perl with a recent PDL version - may come with a patch to PDL if the patch is general enough to be included in the next release and usable outside the demo (e.g. $x=mandelbrot($c) is NOT), i.e. you can introduce new commands 2) The code must fit in 4 lines, 72 columns. 3) It must create an interesting image when fed to perl. If you have an interesting new TriD M4LS (Maximal-4-lines-script) submit it to the PDL mailing list (pdl-general@lists.sourceforge.net) and there is a good chance it will soon be included in the gallery Press 'q' in the graphics window for the next screen. Rotate the image by pressing mouse button one and dragging in the graphics window. Zoom in/out by pressing MB3 and drag up/down. |; actnw q| # B/W Mandelbrot... [Tjl] use PDL; use PDL::Graphics::TriD; $s=150;$a=zeroes $s,$s;$r=$a->xlinvals(-1.5,0.5);$i=$a->ylinvals(-1,1); $t=$r;$u=$i; for(0..12){$q=$r**2-$i**2+$t;$h=2*$r*$i+$u;($r,$i)=map{$_->clip(-5,5)}($q,$h);} imagrgb[($r**2+$i**2)>2.0]; # [press 'q' in the graphics window when done] |; if(0) { actnw q| # Greyscale Mandelbrot [Tjl] use PDL; use PDL::Graphics::TriD;$a=zeroes 300,300;$r=$a->xlinvals(-1.5, 0.5);$i=$a->ylinvals(-1,1);$t=$r;$u=$i;for(1..30){$q=$r**2-$i**2+$t;$h=2 *$r*$i+$u;$d=$r**2+$i**2;$a=lclip($a,$_*($d>2.0)*($a==0));($r,$i)=map{$_ ->clip(-5,5)}($q,$h);}imagrgb[$a/30]; # [press 'q' in the graphics window when done] |; actnw q| # Color Mandelbrot anim (nokeeptwiddling3d removed -> fits) [Tjl] use PDL; use PDL::Graphics::TriD; nokeeptwiddling3d(); $a=zeroes 300,300;$r=$a->xlinvals(-1.5, 0.5);$i=$a->ylinvals(-1,1);$t=$r;$u=$i;for(1..30){$q=$r**2-$i**2+$t;$h=2 *$r*$i+$u;$d=$r**2+$i**2;$a=lclip($a,$_*($d>2.0)*($a==0));($r,$i)=map{$_ ->clip(-5,5)}$q,$h;imagrgb[($a==0)*($r/2+0.75),($a==0)*($i+1)/2,$a/30]} # [press 'q' in the graphics window when done] |; } if(0){ actnw q| # Torus... (barrel) [Tjl] use PDL; use PDL::Graphics::TriD; $s=40;$a=zeroes $s,$s;$t=$a->xlinvals(0,6.284); $u=$a->ylinvals(0,6.284);$o=5;$i=1;$v=$o+$i*sin$u; imag3d([$v*sin$t,$v*cos$t,$i*cos$u]); |; actnw q| # Ripply torus [Tjl] use PDL; use PDL::Graphics::TriD; $s=40;$a=zeroes 2*$s,$s/2;$t=$a->xlinvals(0,6.284); $u=$a->ylinvals(0,6.284); $o=5;$i=1;$v=$o+$i*sin$u; imag3d([$v*sin$t,$v*cos$t,$i*cos($u)+$o*sin(3*$t)]); |; actnw q| # Ripply torus distorted [Tjl] use PDL; use PDL::Graphics::TriD; $s=40;$a=zeroes 2*$s,$s/2;$t=$a->xlinvals(0,6.284);$u=$a->ylinvals(0, 6.284); $o=5;$i=1;$v=$o-$o/2*sin(3*$t)+$i*sin$u; imag3d([$v*sin$t,$v*cos$t,$i*cos($u)+$o*sin(3*$t)]); |; actnw q~ # Game of life [Robin Williams (edited by Tjl)] use PDL; use PDL::Image2D; use PDL::Graphics::TriD;nokeeptwiddling3d; $d=byte(random(zeroes(40,40))>0.85);$k=byte [[1,1,1],[1,0,1],[1,1,1]]; do{ imagrgb [$d]; $s=conv2d($d,$k); $d&=($s<4);$d&=($s>1);$d|=($s==3);} while (!twiddle3d); ~; actnw q~ # Dewdney's voters (parallelized) [Tjl, inspired by the above 'life'] use PDL; use PDL::Image2D; use PDL::Graphics::TriD;nokeeptwiddling3d;$d= byte(random(zeroes(100,100))>0.5);do{$k=float [[1,1,1],[1,0,1],[1,1,1]]; imagrgb[$d]; $s=conv2d($d,$k)/8; $r = $s->float->random; $e = ($s>$r); $d .= $e; }while(!twiddle3d) ~; } actnw q| # Volume rendering [Robin Williams] use PDL; use PDL::Graphics::TriD; keeptwiddling3d(); $b=zeroes(50,50,50);$b=sin(0.3*$b->rvals)*cos(0.3*$b->xvals);$c=0; $a=byte($b>$c);foreach(1,2,4){$t=($a->slice("0:-2")<<$_);$t+=$a->slice("1:-1"); $a = $t->mv(0,2);} points3d [whichND(($a != 0) & ($a != 255))]; |; actnw q| # Lucy deconvolution (AJ 79, 745) [Robin Williams (=> TriD by Tjl)] use PDL; use PDL::Graphics::TriD; nokeeptwiddling3d(); sub smth {use PDL::Image2D; conv2d($_[0],exp(-(rvals ones(3,3))**2));} $a=rfits("m51.fits")->float; $c=$d=avg($a)+0*$a; while(max $c>1.1) {$c=smth($a/smth($d));$d*=$c;imagrgb[$d/850];} |; # use PDL; use PDL::Image2D; use PDL::Graphics::TriD;nokeeptwiddling3d; # $d=byte(random(zeroes(90,90))>0.5);do{$k=byte [[1,1,1],[1,0,1],[1,1,1]]; # imagrgb[$d]if($k++%2); $s=conv2d($d,$k)/8;$i=90*90*random(50);$t=$d-> # clump(2)-> index($i);$t.=($s->clump(2)->index($i)>.5);}while(!twiddle3d) actnw q| # spherical dynamics [Mark R Baker] use PDL;use PDL::Graphics::TriD;for $c(1..99){$n=6.28*$c; $g=$c*rvals( sin(zeros(5000))*$c);$cz=-1**$g*$c;$cy=$g*cos$g*$c;$cx=$c*rvals($g)*$c; $g=cos($w=$cz+$cy+$cx);$r=sin$cy+$c+$cz;$b=sin$w;nokeeptwiddling3d(); $i=$cz-$cx-$cy;$q=$i*$n;points3d[$b*sin$q,$r*cos$q,$g*sin$q],[$r,$g,$b]} |; actnw q~ # Fractal mountain range [Tuomas Lukka] use PDL;use PDL::Image2D;use PDL::Graphics::TriD; keeptwiddling3d(); $k=ones(5,5) / 25; $a=5;$b=ones(1,1)/2;for(1..7){$c=$b->dummy(0,2)->clump(2)->xchg(0,1)-> dummy(0,2)->clump(2)->xchg(0,1)->copy;$c+=$a*$c->random;$a/=3; $b=conv2d($c,$k); imag3d[$b],{Lines => 0}; } ~; comment q| We hope you did like that and got a feeling of the power of PDL. Now it's up to you to submit even better TriD M4LSs. |; } if(0) { # one possible addition to volume rendering... use PDL; use PDL::Graphics::TriD; $b=zeroes(50,50,50);$b=sin(0.3*$b->rvals)*cos(0.3*$b->xvals);$c=0; $a=byte($b>$c);foreach(1,2,4){$t=($a->slice("0:-2")<<$_);$t+=$a->slice("1:-1"); $a = $t->mv(0,2);}points3d[map{$_+$_->float->random}whichND(($a!=0)&($a != 255))]; } # Neat, but too big variation of color mandelbrot if(0) { use PDL; use PDL::Graphics::TriD; nokeeptwiddling3d(); sub f {return abs(sin($_[0]*30))} $a=zeroes 300,300;$r=$a->xlinvals(-1.5, 0.5);$i=$a->ylinvals(-1,1);$t=$r;$u=$i;for(1..30){$q=$r**2-$i**2+$t;$h=2 *$r*$i+$u;$d=$r**2+$i**2;$a=lclip($a,$_*($d>2.0)*($a==0));($r,$i)=map{$_ ->clip(-5,5)}$q,$h;imagrgb[f(($a==0)*($r/2+0.75)),f(($a==0)*($i+1)/2),$a/30]} } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/DEPENDENCIES������������������������������������������������������������������������������0000644�0601750�0601001�00000023421�13107151226�012145� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������+----------------------------------------------------------------------------+ | PDL Module Dependencies | +----------------------------------------------------------------------------+ This file lists dependencies of PDL modules on external programs or libraries. Some of the modules will build ok without the external software but in general are not very useful without it. Others require certain libraries/include files to be installed. See INSTALL on hints how to enable/disable building of some modules in the distribution if required. The easiest way to resolve dependencies on other Perl modules is to use the CPAN module to install PDL. Installation should be as simple as cpan install PDL # if the cpan script is in your path or if you don't have the cpan script try perl -MCPAN -e shell cpan> install PDL +----------------+---------------------+-------------------------------------+ | MODULE | DEPENDS ON | COMMENT | +----------------+---------------------+-------------------------------------+ PDL (all) perl >= 5.10.x PDL requires at least this version of perl to build and run. Devel::CheckLib >= 1.01 File::Spec >= 0.6 perl5 core module. File::Temp >= 0 perl5 core module. Pod::Parser >= 0 perl5 core module. Pod::Select >= 0 perl5 core module. ExtUtils::MakeMaker >= 6.56 This version of EU::MM is the first with support for CONFIGURE_REQUIRES. Test::Exception >= 0 Needed for test suite. PDL::NiceSlice Text::Balanced >= 1.89 A nicer way to index piddles. Filter::Util::Call Filter::Simple Required for new PDL::NiceSlice Module::Compile implementation under development. Inline::Pdlpp Inline >= 0.68 This module allows defining fast Inline::C >= 0.62 PP code inline in your scripts. NOTE: Though Inline is listed as as PDL prerequisite for CPAN, you can build PDL manually without it. PDL::ParallelCPU pthreads library Multi-CPU support will be enabled if libpthreads is detected and built against. A pthreads for win32 can be found at http://sourceware.org/pthreads-win32/ PDL::IO::Dumper Data::Dumper >= 2.121 Convert::UU Convert::UU is required. uuencode/uudecode (Optional) Better performance on unix flavor platforms! They will be used instead of Convert::UU if detected. PDL::IO::Storable Storable >=1.03 perl >= 5.10.x Will build but won't work for perl versions prior to 5.10.0 pdl2 (shell) Devel::REPL >= 1.003011 and Term::ReadLine::Perl or Term::ReadLine::Gnu Devel::REPL requires Data::Dump::Streamer and Sys::SigAction to support pdl2. They may need to be hand-installed if you are doing a manual PDL build. perldl (shell) Term::ReadLine::Perl or Term::ReadLine::Gnu pdl2 (and perldl) will be installed by default. If Devel::REPL is not installed, pdl2 uses perldl. The same thing if a Term::ReadLine::Perl or Term::ReadLine::Gnu is not installed. PDL::GIS::Proj PDL::Transform::Proj A PDL interface to the PROJ4 geographic projection library and the PDL::Transform interface to PROJ4. See http://trac.osgeo.org/proj/ Module will be built if the PROJ4 library is installed and detected. PDL::Graphics::TriD Requires the perl OpenGL module be installed. See the POGL_VERSION entry in perldl.conf for the minimum required version. Perl OpenGL requires you have the OpenGL graphics library and FreeGLUT (Apple GLUT on Mac OS X) installed. PDL::Graphics::TriD will be built if Perl OpenGL is detected and of version greater than the POGL_VERSION in perldl.conf. To disable the build, edit perldl.conf and set WITH_3D => 0. PDL::Graphics::PGPLOT Requires both the PGPLOT perl module **and** the PGPLOT fortran library. See http://astro.caltech.edu/~tjp/pgplot for the library and http://search.cpan.org/search%3fmodule=PGPLOT for the perl module (on CPAN). NOTE: These are two separate items to be installed. PDL::Graphics::PGPLOT Module builds ok without PGPLOT module and library. PDL::Graphics::IIS To be useful an application that supports the 'IIS' protocol must be installed, e.g. SAOimage or Ximtool, see http://tdc-www.harvard.edu/software/saoimage.html http://iraf.noao.edu/iraf/web/projects/x11iraf/ PDL::Graphics::IIS builds without viewers. PDL::GSL modules Needs the GSL (Gnu Scientific Library) to build. Version >= 1.0 is required See http://www.gnu.org/software/gsl/ Will not be built unless an appropriate GSL version is installed and detected. PDL::IO::Browser Requires a 'curses'-compatible library. You'll need to enable in perldl.conf if you wish to try the new configure and build, no guarantees... Not built by default. PDL::IO::FastRaw PDL::IO::FlexRaw Memory-mapped file IO functions (mapfraw and mapflex) require File::Map 0.47 or higher. (Systems with POSIX mmap routines will work without File::Map but it is expected that the less-flexible, legacy implementation will be deprecated) Built by default if File::Map or mmap dependencies are met. PDL::IO::FITS Needs Astro::FITS::Header for full support of all FITS header features. Will build ok, and run, without it but for given that Astro::FITS::Header is a Perl only module, you should install it unless you specifically need not. NOTE: It is currently listed as an official prerequisite module for the purposes of building with the cpan shell. PDL::IO::GD PDL interface to the GD image library. See http://www.libgd.org Will not be built unless libgd is already installed and detected. PDL::IO::HDF PDL interface to HDF4 library. See PDL::IO::HDF5 on CPAN for HDF5 bindings. Not all HDF4 types are supported. See http://www.hdfgroup.org/products/hdf4/ Will not be built unless the HDF4 libraries are detected. PDL::IO::Pic rpic/wpic: NetPBM converters See http://netpbm.sourceforge.net/ wmpeg: requires the ffmpeg program See http://ffmpeg.org/ Module builds ok without converters. Recommend at least version 10.58.00 of NetPBM. PDL::Minuit PDL interface to Minuit minimization routines in the CERN library, http://wwwasdoc.web.cern.ch/wwwasdoc/minuit/minmain.html The Minuit library code is included. A fortran compiler is required and ExtUtils:F77 (version >= 1.03). Will not be built unless ExtUtils::F77 is installed *and* supports your platform. PDL::Slatec Linear algebra routines. Several other PDL modules use PDL::Slatec Slatec fortran lib is included but requires a fortran compiler and ExtUtils::F77 (version >= 1.03). Will not be built unless ExtUtils::F77 is installed *and* supports your platform. �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/DEVELOPMENT�������������������������������������������������������������������������������0000644�0601750�0601001�00000020722�13036512174�012106� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������This file has some information on how to get access to the latest PDL sources (mainly of interest for potential developers). This should not be confused with the latest public release which will always be available from CPAN (if you don't know what that is check the FAQ). Public Git repository at sourceforge.net -------------------------------------------- From version PDL-2.4.4 onwards the source distribution is in a publicly accessible Git repository. The project is hosted at the sourceforge site at http://sourceforge.net/projects/pdl/ Starting from the above URL you will find directions on how to check out the current sources, browse the Git repository online, etc. If you would like to actively contribute to PDL development don't hesitate to contact one of the project admins (listed at the above URL) to apply for write access to the repository. We strongly believe in the power of open source development! If you do not know how to use Git try 'man git' or have a look at some of the online tutorials available on the web. The main Git home page is at http://www.git-scm.org/ and two good online Git references are the Git User's Manual at http://www.kernel.org/pub/software/scm/git/docs/user-manual.html and Git Magic at http://www-cs-students.stanford.edu/~blynn/gitmagic/ PDL Developer Guidelines: ------------------------- The following guidelines are for any developer that has access to the PDL Git repository. 1) Before committing a change with new files to the repository you should update: - MANIFEST (if files were added, using 'make manifest') - MANIFEST.SKIP (if applicable) 2) Make sure you add a test case in the 't' directory for any significant additional capability you add to PDL. Please use Test::More or one the of the Test modules available via perl modules rather than doing-it-yourself! 3) Please include POD documentation for any functions you add to the distribution. - See Basic/Core/Core.pm for an example of including POD documentation in .pm files. - See Basic/Core/Primitive/Primitive.pd for an example of including POD documentation in PDL .pd files. - read the documentation in PDL::Doc for a detailed description of the PDL documentation conventions. 4) Don't commit before you successfully built and passed 'make test'. 5) Bugs reported on the list should be entered into the bug database and bugs closed when a patch has been committed as a fix. (Primary responsibility for this task is the pumpking, but other devels should be able to help.) PDL Developer Recommended Workflow: ----------------------------------- The actual workflow is a little more complicated. This is because GitHub also hosts a mirror of PDL's SF repository, to enable automatic multi-platform build checks. If you are just starting out you need to clone the repository: $ git clone ssh://your_sf_username@git.code.sf.net/p/pdl/code pdl-code Or if you already have a repository and haven't updated in awhile, do that, and follow the rest of the workflow below: $ git pull origin master #update local repository $ git checkout -b problembranch #create a local branch (use a more descriptive name!) #fix a problem $ git add filename(s) #add files to staging area $ git commit #commit the changes to the local branch $ git push origin problembranch #push the branch to SF #after a few minutes, log into GitHub, go to problembranch and initiate a pull request #(or ask somebody to do it for you if you don't have a GitHub account). #Wait for the automatic build tests to run and pass. #Wait for somebody to look at and approve the code if it is complicated. #Do NOT merge and delete the branch on GitHub (it will get restored #the next time the SF repository is mirrored). $ git rebase master #rebase the branch onto master $ git checkout master #still rebasing $ git merge problembranch --ff-only #finally done rebasing $ git push origin master #push to SF $ git push origin :problembranch #delete the remote branch $ git branch -d problembranch #delete the local branch You have just created, pushed, checked, rebased, and deleted a branch. PDL Developer Notes: -------------------- A (small) collection of random musings to note if you feel the need to improve or add to PDL (please do): *) git supports file-by-file commits so it is helpful to commit your changes to git a little at a time where each commit corresponds to a single change. This makes it easy in the log to determine what was done and to locate any desired commit in case of issues that need to be resolved. *) Need help? See the pdl-devel email list; details for subscription and access to the archives can be found on the PDL web page at: http://pdl.perl.org/?page=mailing-lists *) Access to PDL's configuration If you need to access the configuration for PDL then use the %PDL::Config variable. Prior to 2.4.1 this was a mess since you had to use %PDL_CONFIG within Makefile.PL and PDL::Config from *.pm/tests. The build process has been changed (I hesitate to say "cleaned up" ;) to just use %PDL::Config consistently throughout. - %PDL::Config is automatically available to you when you are in a Makefile.PL within the PDL distribution. You can change the hash and these changes will be stored in the PDL::Config module. You should only change values when it makes sense (e.g. if the user has specified that a module should be built but you find out this is not possible). - use PDL; now loads PDL::Config by default - Otherwise you can say 'use PDL::Config;' or - perhaps something like eval 'require "' . whereami_any() . '/Core/Config.pm";'; where whereami_any() is from PDL::Core::Dev; *) Location of temporary files Please use $PDL::Config{TEMPDIR} for the directory in which to place temporary files (e.g. when IO::File::new_tmpfile() is not appropriate). This will make it easier for distributions to package PDL since there will only be one place they need to change if the default value causes problems. This *includes* test cases as well as for Makefile.PL's! ------------------------------------------------------------- Notes on transferring an external PDL module to the PDL source tree for distribution with PDL. ------------------------------------------------------------- Suppose you have developed a PDL module that resides in a standalone source tree. You typically will need to have PDL installed on your system before you can build this module. If you wish to migrate the module into the PDL distribution you will need to make certain changes to the module source in order to built in the PDL distribution. You will need to removed dependecies on a pre-existing PDL installation for configuration and build of your module. This is because as part of the PDL distribution, it is possible that PDL has never been installed. Build processes based on PDL will then fail. Following is some specific advice that can help you do this. [ These notes are very preliminary and are expected to be ] [ revised and/or replaced by improved documentation. ] Changes that must be made to files in your module source tree if you are building the module from a .pd file : Makefile.PL: -- You must remove the line 'use PDL::Core::Dev;'. -- The line 'PDL::Core::Dev->import();' must be present -- You must change the call from 'pdlpp_postamble' to a call to 'pdlpp_postamble_int' (with the same arguments.) -- It seems that most modules in the PDL source use VERSION_FROM => '../../Basic/Core/Version.pm', but not all of them in order that their version tracks the PDL release version. It is possible to maintain separate versioning even within the PDL source tree but it may make things confusing. Make certain that you make these changes to each 'Makefile.PL' in your source tree. Changes to the existing PDL source tree: -- Edit the 'Makefile.PL' in the directory above your module source to add your module directory name to 'DIR => [ qw/Module1 AnotherModule / ]'. -- Add your test files (.t files) to the PDL/t directory renaming if required to avoid namespace conflicts. -- Does your module depend on any libraries or external programs ? If so, doocument the required programs with version numbers in PDL/DEPENDENCIES and add the PREREQ_* option to the main Makefile.PL if required. -- If your module requires external libraries or header files, add a section to perldl.conf. The hash values with be available in your module's 'Makefile.PL' as $PDL::Config{WITH_MYMODULE},... ����������������������������������������������PDL-2.018/Doc/��������������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�011070� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/Doc/����������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402045�011574� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/Doc/Config.pm.PL����������������������������������������������������������������������0000644�0601750�0601001�00000002531�12562522364�013673� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/local/bin/perl use Config; use File::Basename qw(&basename &dirname); # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; chmod 0775, $file; # In this section, perl variables will be expanded during extraction. # You can use $Config{...} to use Configure variables. print OUT "# automatically built from ".basename($0)."\n"; print OUT "# don't modify, all changes will be lost !!!!\n"; print OUT <<'!NO!SUBS!'; package PDL::Doc::Config; !NO!SUBS! print OUT <<"EOC"; \$PDL::Doc::pager = \'$Config{'pager'}\'; \$PDL::Doc::pager = \$ENV{PAGER} if defined \$ENV{PAGER}; \$PDL::Doc::pager = \$ENV{PERLDOC_PAGER} if defined \$ENV{PERLDOC_PAGER}; \$PDL::Doc::DefaultFile = \'$Config{'man1direxp'}\'; 1; EOC �����������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/Doc/Perldl.pm�������������������������������������������������������������������������0000644�0601750�0601001�00000042302�13036512174�013371� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Doc::Perldl - commands for accessing PDL doc database from 'perldl' shell =head1 DESCRIPTION This module provides a simple set of functions to access the PDL documentation of database, for use from the I<perldl> or I<pdl2> shells as well as the I<pdldoc> command-line program. Autoload files are also matched, via a search of the PDLLIB autoloader tree. That behavior can be switched off with the variable C<$PERLDL::STRICT_DOCS> (true: don't search autoload tree; false: search the autoload tree.) Currently, multiple matches are not handled very well. =head1 SYNOPSIS use PDL::Doc::Perldl; # Load all documentation functions =head1 BUGS The description contains the misleading word "simple". =head1 FUNCTIONS =cut package PDL::Doc::Perldl; use Exporter; use strict; use vars qw(@ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw( apropos aproposover usage help sig badinfo whatis ); use PDL::Doc; use Pod::Select; use IO::File; use Pod::PlainText; $PDL::onlinedoc = undef; $PDL::onlinedoc = PDL::Doc->new(FindStdFile()); use PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; # Find std file sub FindStdFile { my ($d,$f); for $d (@INC) { $f = $d."/PDL/pdldoc.db"; if (-f $f) { print "Found docs database $f\n" if $PDL::verbose; print "Type 'help' for online help\n" if $PDL::verbose; return $f; } } warn "Unable to find PDL/pdldoc.db in ".join(":",@INC)."\n"; } # used to find out how wide the screen should be # for printmatch() - really should check for a # sensible lower limit (for printmatch >~ 40 # would be my guess) # # taken from Pod::Text (v1.0203), then hacked to get it # to work (at least on my solaris and linux # machines) # sub screen_width() { return $ENV{COLUMNS} || (($ENV{TERMCAP} =~ /co#(\d+)/) and $1) || ($^O ne 'MSWin32' and $^O ne 'dos' and (`stty -a 2>/dev/null` =~ /columns\s*=?\s*(\d+)/) and $1) || 72; } sub printmatch { my @match = @_; if (@match) { foreach my $t ( format_ref( @_ ) ) { print $t; } } else { print "no match\n\n"; } } # sub: print_match() # return a string containing a formated version of the Ref string # for the given matches # sub format_ref { my @match = @_; my @text = (); my $width = screen_width()-17; my $parser = new Pod::PlainText( width => $width, indent => 0, sentence => 0 ); for my $m (@match) { my $ref = $m->[1]{Ref} || ( (defined $m->[1]{CustomFile}) ? "[No ref avail. for `".$m->[1]{CustomFile}."']" : "[No reference available]" ); $ref = $parser->interpolate( $ref ); $ref = $parser->reformat( $ref ); # remove last new lines (so substitution doesn't append spaces at end of text) $ref =~ s/\n*$//; $ref =~ s/\n/\n /g; my $name = $m->[0]; if ( length($name) > 15 ) { push @text, sprintf "%s ...\n %s\n", $name, $ref; } else { push @text, sprintf "%-15s %s\n", $name, $ref; } } return wantarray ? @text : $text[0]; } # sub: format_ref() =head2 apropos =for ref Regex search PDL documentation database =for usage apropos 'text' =for example pdl> apropos 'pic' rpic Read images in many formats with automatic format detection. rpiccan Test which image formats can be read/written wmpeg Write an image sequence ((x,y,n) piddle) as an MPEG animation. wpic Write images in many formats with automatic format selection. wpiccan Test which image formats can be read/written To find all the manuals that come with PDL, try apropos 'manual:' and to get quick info about PDL modules say apropos 'module:' You get more detailed info about a PDL function/module/manual with the C<help> function =cut sub aproposover { die "Usage: aproposover \$funcname\n" unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $func = shift; $func =~ s:\/:\\\/:g; search_docs("m/$func/",['Name','Ref','Module'],1); } sub apropos { die "Usage: apropos \$funcname\n" unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $func = shift; printmatch aproposover $func; } =head2 PDL::Doc::Perldl::search_docs =for ref Internal routine to search docs database and autoload files =cut sub search_docs { my ($func,$types,$sortflag,$exact) = @_; my @match; @match = $PDL::onlinedoc->search($func,$types,$sortflag); push(@match,find_autodoc( $func, $exact ) ); @match; } =head2 PDL::Doc::Perldl::finddoc =for ref Internal interface to the PDL documentation searcher =cut sub finddoc { local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager die 'Usage: doc $topic' unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $topic = shift; # See if it matches a PDL function name my $subfield = $1 if( $topic =~ s/\[(\d*)\]$// ); (my $t2 = $topic) =~ s/([^a-zA-Z0-9_])/\\$1/g; my @match = search_docs("m/^(PDL::)?".$t2."\$/",['Name'],0); unless(@match) { print "No PDL docs for '$topic'. Using 'whatis'. (Try 'apropos $topic'?)\n\n"; whatis($topic); return; } # print out the matches my $out = IO::File->new( "| pod2text | $PDL::Doc::pager" ); if($subfield) { if($subfield <= @match) { @match = ($match[$subfield-1]); $subfield = 0; } else { print $out "\n\n=head1 PDL HELP: Ignoring out-of-range selector $subfield\n\n=head1\n\n=head1 --------------------------------\n\n"; $subfield = undef; } } my $num_pdl_pod_matches = scalar @match; my $pdl_pod_matchnum = 0; while (@match) { $pdl_pod_matchnum++; if ( @match > 1 and !$subfield ) { print $out "\n\n=head1 MULTIPLE MATCHES FOR HELP TOPIC '$topic':\n\n=head1\n\n=over 3\n\n"; my $i=0; for my $m ( @match ) { printf $out "\n=item [%d]\t%-30s %s%s\n\n", ++$i, $m->[0], $m->[1]{Module} && "in ", $m->[1]{CustomFile} || $m->[1]{Module}; } print $out "\n=back\n\n=head1\n\n To see item number \$n, use 'help ${topic}\[\$n\]'. \n\n=cut\n\n"; } if (@match > 0 and $num_pdl_pod_matches > 1) { print $out "\n=head1 Displaying item $pdl_pod_matchnum:\n\n=head1 --------------------------------------\n\n=cut\n\n"; } my $m = shift @match; my $Ref = $m->[1]{Ref}; if ( $Ref =~ /^(Module|Manual|Script): / ) { # We've got a file name and we have to open it. With the relocatable db, we have to reconstitute the absolute pathname. my $relfile = $m->[1]{File}; my $absfile = undef; my @scnd = @{$PDL::onlinedoc->{Scanned}}; for my $dbf(@scnd){ $dbf =~ s:\/[^\/]*$::; # Trim file name off the end of the database file to get just the directory $dbf .= "/$relfile"; $absfile = $dbf if( -e $dbf ); } unless ($absfile) { die "Documentation error: couldn't find absolute path to $relfile\n"; } my $in = IO::File->new("<$absfile"); print $out join("",<$in>); } else { if(defined $m->[1]{CustomFile}) { my $parser= Pod::Select->new; print $out "=head1 Autoload file \"".$m->[1]{CustomFile}."\"\n\n"; $parser->parse_from_file($m->[1]{CustomFile},$out); print $out "\n\n=head2 Docs from\n\n".$m->[1]{CustomFile}."\n\n"; } else { print $out "=head1 Module ",$m->[1]{Module}, "\n\n"; $PDL::onlinedoc->funcdocs($m->[0],$out); } } } } =head2 find_autodoc =for ref Internal helper routine that finds and returns documentation in the autoloader path, if it exists. You feed in a topic and it searches for the file "${topic}.pdl". If that exists, then the filename gets returned in a match structure appropriate for the rest of finddoc. =cut # Yuck. Sorry. At least it works. -CED sub find_autodoc { my $topic = shift; my $exact = shift; my $matcher; # Fix up regexps and exact matches for the special case of # searching the autoload dirs... if($exact) { $topic =~ s/\(\)$//; # "func()" -> "func" $topic .= ".pdl" unless $topic =~ m/\.pdl$/; } else { $topic =~ s:([^\$])(.)$:$1\.\*\$$2:; # Include explicit ".*$" at end of # vague matches -- so that we can # make it a ".*\.pdl$" below. $topic =~ s:\$(.)$:\.pdl\$$1:; # Force ".pdl" at end of file match $matcher = eval "sub { ${topic}i && \$\_ };"; # Avoid multiple compiles } my @out; return unless(@main::PDLLIB); @main::PDLLIB_EXPANDED = PDL::AutoLoader::expand_path(@main::PDLLIB) unless(@main::PDLLIB_EXPANDED); for my $dir(@main::PDLLIB_EXPANDED) { if($exact) { my $file = $dir . "/" . "$topic"; push(@out, [$file, {CustomFile => "$file", Module => "file '$file'"}] ) if(-e $file); } else { opendir(FOO,$dir) || next; my @dir = readdir(FOO); closedir(FOO); for my $file( grep( &$matcher, @dir ) ) { push(@out, [$file, {CustomFile => "$dir/$file", Module => "file '$dir/$file'"}] ); } } } @out; } =head2 usage =for ref Prints usage information for a PDL function =for usage Usage: usage 'func' =for example pdl> usage 'inner' inner inner prodcuct over one dimension (Module PDL::Primitive) Signature: inner(a(n); b(n); [o]c(); ) =cut sub usage { die 'Usage: usage $funcname' unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; print usage_string(@_); } sub usage_string{ my $func = shift; my $str = ""; my @match = search_docs("m/^(PDL::)?$func\$/",['Name']); unless (@match) { $str = "\n no match\n" } else { $str .= "\n" . format_ref( $match[0] ); my ($name,$hash) = @{$match[0]}; $str .= sprintf ( (' 'x16)."(Module %s)\n\n", $hash->{Module} ); die "No usage info found for $func\n" if !defined $hash->{Example} && !defined $hash->{Sig} && !defined $hash->{Usage}; $str .= " Signature: $name($hash->{Sig})\n\n" if defined $hash->{Sig}; for (['Usage','Usage'],['Opt','Options'],['Example','Example']) { $str .= " $_->[1]:\n\n".&allindent($hash->{$_->[0]},10)."\n\n" if defined $hash->{$_->[0]}; } } return $str; } =head2 sig =for ref prints signature of PDL function =for usage sig 'func' The signature is the normal dimensionality of the function's arguments. Calling with different dimensions doesn't break -- it causes threading. See L<PDL::PP|PDL::PP> for details. =for example pdl> sig 'outer' Signature: outer(a(n); b(m); [o]c(n,m); ) =cut sub sig { die "Usage: sig \$funcname\n" unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $func = shift; my @match = search_docs("m/^(PDL::)?$func\$/",['Name']); unless (@match) { print "\n no match\n" } else { my ($name,$hash) = @{$match[0]}; die "No signature info found for $func\n" if !defined $hash->{Sig}; print " Signature: $name($hash->{Sig})\n" if defined $hash->{Sig}; } } sub allindent { my ($txt,$n) = @_; my ($ntxt,$tspc) = ($txt,' 'x8); $ntxt =~ s/^\s*$//mg; $ntxt =~ s/\t/$tspc/g; my $minspc = length $txt; for (split '\n', $txt) { if (/^(\s*)/) { $minspc = length $1 if length $1 < $minspc } } $n -= $minspc; $tspc = ' 'x abs($n); $ntxt =~ s/^/$tspc/mg if $n > 0; return $ntxt; } =head2 whatis =for ref Describe a perl and/or PDL variable or expression. Useful for determining the type of an expression, identifying the keys in a hash or a data structure, or examining WTF an unknown object is. =for usage Usage: whatis $var whatis <expression> =cut sub whatis { my $topic; if(@_ > 1) { whatis_r('',0,[@_]); } else { whatis_r('',0,shift); } } $PDL::Doc::Perldl::max_strlen = 55; $PDL::Doc::Perldl::max_arraylen = 1; $PDL::Doc::Perldl::max_keylen = 8; $PDL::Doc::Perldl::array_indent=5; $PDL::Doc::Perldl::hash_indent=3; sub whatis_r { my $prefix = shift; my $indent = shift; my $a = shift; unless(defined $a) { print $prefix,"<undef>\n"; return; } unless(ref $a) { print "${prefix}'". substr($a,0,$PDL::Doc::Perldl::max_strlen). "'".((length $a > $PDL::Doc::Perldl::max_strlen) && '...'). "\n"; return; } if(ref $a eq 'ARRAY') { print "${prefix}Array (".scalar(@$a)." elements):\n"; my($el); for $el(0..$#$a) { my $pre = sprintf("%s %2d: "," "x$indent,$el); whatis_r($pre,$indent + $PDL::Doc::Perldl::array_indent, $a->[$el]); last if($el == $PDL::Doc::Perldl::max_arraylen); } printf "%s ... \n"," " x $indent if($#$a > $PDL::Doc::Perldl::max_arraylen); return; } if(ref $a eq 'HASH') { print "${prefix}Hash (".scalar(keys %$a)." elements)\n"; my $key; for $key(sort keys %$a) { my $pre = " " x $indent . " $key: " . (" "x($PDL::Doc::Perldl::max_keylen - length($key))) ; whatis_r($pre,$indent + $PDL::Doc::Perldl::hash_indent, $a->{$key}); } return; } if(ref $a eq 'CODE') { print "${prefix}Perl CODE ref\n"; return; } if(ref $a eq 'SCALAR' | ref $a eq 'REF') { whatis_r($prefix." Ref -> ",$indent+8,$$a); return; } if(UNIVERSAL::can($a,'px')) { my $b; local $PDL::debug = 1; $b = ( (UNIVERSAL::isa($a,'PDL') && $a->nelem < 5 && $a->ndims < 2) ? ": $a" : ": *****" ); $a->px($prefix.(ref $a)." %7T (%D) ".$b); } else { print "${prefix}Object: ".ref($a)."\n"; } } =head2 help =for ref print documentation about a PDL function or module or show a PDL manual In the case of multiple matches, the first command found is printed out, and the remaining commands listed, along with the names of their modules. =for usage Usage: help 'func' =for example pdl> help 'PDL::Tutorials' # show the guide to PDL tutorials pdl> help 'PDL::Slices' # show the docs in the PDL::Slices module pdl> help 'slice' # show docs on the 'slice' function =cut sub help_url { local $_; foreach(@INC) { my $a = "$_/PDL/HtmlDocs/PDL/Index.html"; if(-e $a) { return "file://$a"; } } } sub help { if ($#_>-1) { require PDL::Dbg; my $topic = shift; if (PDL::Core::blessed($topic) && $topic->can('px')) { local $PDL::debug = 1; $topic->px('This variable is'); } else { $topic = 'PDL::Doc::Perldl' if $topic =~ /^\s*help\s*$/i; if ($topic =~ /^\s*vars\s*$/i) { PDL->px((caller)[0]); } elsif($topic =~ /^\s*url\s*/i) { my $a = help_url(); if($a) { print $a; } else { print "Hmmm. Curious: I couldn't find the HTML docs anywhere in \@INC...\n"; } } elsif($topic =~ /^\s*www(:([^\s]+))?\s*/i) { my $browser; my $url = help_url(); if($2) { $browser = $2; } elsif($ENV{PERLDL_WWW}) { $browser = $ENV{PERLDL_WWW}; } else { $browser = 'mozilla'; } chomp($browser = `which $browser`); if(-e $browser && -x $browser) { print "Spawning \"$browser $url\"...\n"; `$browser $url`; } } else { finddoc($topic); } } } else { print <<'EOH'; The following commands support online help in the perldl shell: help 'thing' -- print docs on 'thing' (func, module, manual, autoload-file) help vars -- print information about all current piddles help url -- locate the HTML version of the documentation help www -- View docs with default web browser (set by env: PERLDL_WWW) whatis <expr> -- Describe the type and structure of an expression or piddle. apropos 'word' -- search for keywords/function names usage -- print usage information for a given PDL function sig -- print signature of PDL function ('?' is an alias for 'help'; '??' is an alias for 'apropos'.) EOH print " badinfo -- information on the support for bad values\n" if $bvalflag; print <<'EOH'; Quick start: apropos 'manual:' -- Find all the manual documents apropos 'module:' -- Quick summary of all PDL modules help 'help' -- details about PDL help system help 'perldl' -- help about this shell EOH } } =head2 badinfo =for ref provides information on the bad-value support of a function And has a horrible name. =for usage badinfo 'func' =cut # need to get this to format the output - want a format_bad() # subroutine that's like - but much simpler - than format_ref() # sub badinfo { my $func = shift; die "Usage: badinfo \$funcname\n" unless defined $func; die "PDL has not been compiled with support for bad values.\n" . "Recompile with WITH_BADVAL set to 1 in config file!.\n" unless $bvalflag; die "no online doc database" unless defined $PDL::onlinedoc; local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager my @match = search_docs("m/^(PDL::)?$func\$/",['Name']); if ( @match ) { my ($name,$hash) = @{$match[0]}; my $info = $hash->{Bad}; if ( defined $info ) { my $out = new IO::File "| pod2text | $PDL::Doc::pager"; print $out "=head1 Bad value support for $name\n\n$info\n"; } else { print "\n No information on bad-value support found for $func\n"; } } else { print "\n no match\n"; } } # sub: badinfo() 1; # OK ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/Doc.pm��������������������������������������������������������������������������������0000644�0601750�0601001�00000065554�13036512174�012165� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# the filter for the PDL pod format (which is a valid general perl # pod format but with special interpretation of some =for directives) package PDL::PodParser; use PDL::Core ''; use Pod::Select; use File::Spec; use File::Basename; @ISA = qw(Pod::Select); %Title = ('Example' => 'Example', 'Ref' => 'Reference', 'Sig' => 'Signature', 'Opt' => 'Options', 'Usage' => 'Usage', 'Bad' => 'Bad value support', ); sub new { my $class = shift; my $parser = $class->SUPER::new(@_); bless $parser,$class; # just in case $parser->select("METHODS|OPERATORS|CONTRUCTORS|FUNCTIONS|NAME"); $parser->{CURFUNC} = undef; $parser->{SYMHASH} = {}; $parser->{INBLOCK} = 0; $parser->{Mode} = ""; $parser->{verbose} = 0; $parser->{NAME} = 'UNKNOWN'; return $parser; } sub command { my ($this,$cmd,$txt,$line_num,$pod_para) = @_; $this->{Parmode} = 'Body'; if ($cmd eq 'head1') { $this->{Mode} = $txt; $this->{Parmode} = 'Body'; $this->{Parmode} = 'NAME' if $txt =~ /NAME/; } elsif ($this->{Mode} =~ /NAME/) { # do nothing (was 'last' but that was probably a mistake) } elsif ($cmd eq 'head2') { # A function can have multiple names (ex: zeros and zeroes), # so split at the commas my @funcs = split(',',$txt); # Remove parentheses (so myfunc and myfunc() both work) my @names = map {$1 if m/\s*([^\s(]+)\s*/} @funcs; barf "error parsing function list '$txt'" unless $#funcs == $#names; # check for signatures my $sym = $this->{SYMHASH}; for (@funcs) { $sym->{$1}->{Module} = $this->{NAME} if m/\s*([^\s(]+)\s*/; $sym->{$1}->{Sig} = $2 if m/\s*([^\s(]+)\s*\(\s*(.+)\s*\)\s*$/; } # make the first one the current function $sym->{$names[0]}->{Names} = join(',',@names) if $#names > 0; my $name = shift @names; # Make the other names cross-reference the first name $sym->{$_}->{Crossref} = $name for (@names); my $sig = $sym->{$name}->{Sig}; # diagnostic output print "\nFunction '".join(',',($name,@names))."'\n" if $this->{verbose}; print "\n\tSignature: $sig\n" if defined $sig && $this->{verbose}; $this->{CURFUNC} = $name; } elsif ($cmd eq 'for') { $this->check_for_mode($txt,$pod_para) if $cmd eq 'for'; } local $this->{Parmode} = 'Body'; $this->SUPER::command($cmd,$txt,$line_num,$pod_para); } sub check_for_mode { my ($this,$txt,$pod_para) = @_; if ($txt =~ /^(sig|example|ref|opt|usage|bad|body)/i) { $this->{Parmode} = ucfirst lc $1; print "switched now to '$1' mode\n" if $this->{VERBOSE}; print "\n\t$Title{$this->{Parmode}}\n" unless $this->{Parmode} =~ /Body/ || !$this->{verbose}; } } sub textblock { my $this = shift; my $txt = shift; $this->checkmode($txt); local $this->{INBLOCK} = 1; $this->SUPER::textblock($txt,@_); $this->{Parmode} = 'Body'; # and reset parmode } sub checkmode { my ($this,$txt,$verbatim) = @_; if ($this->{Mode} =~ /NAME/ && $this->{Parmode} =~ /NAME/) { $this->{NAME} = $1 if $this->trim($txt) =~ /^\s*(\S+)\s*/; print "\nNAME\t$this->{NAME}\n" if $this->{verbose}; $this->{Parmode} = 'Body'; return; } unless ($this->{Parmode} =~ /Body/ || $this->{INBLOCK}) { my $func = $this->{CURFUNC}; barf "no function defined" unless defined $func; local $this->{INBLOCK} = 1; # can interpolate call textblock? my $itxt = $verbatim ? $txt : $this->interpolate($txt); $this->{SYMHASH}->{$func}->{$this->{Parmode}} .= $this->trim($itxt,$verbatim); my $cr = ($verbatim && $this->{Parmode} ne 'Sig') ? "\n" : ""; my $out = "\n\t\t$cr".$this->trim($itxt,$verbatim); print "$out\n$cr" if $this->{verbose}; } $this->{Parmode} = 'Body'; } sub verbatim { my $this = shift; my $txt = shift; $this->checkmode($txt,1); $this->SUPER::verbatim($txt,@_); } # this needs improvement # and any formatting information should be removed? # it probably depends sub trim { my ($this,$txt,$verbatim) = @_; my $ntxt = ""; $txt =~ s/(signature|usage):\s*//i if $this->{Parmode} eq 'Sig' || $this->{Parmode} eq 'Usage'; if ($this->{Parmode} eq 'Sig') { $txt =~ s/^\s*//; $txt =~ s/\s*$//; while( $txt =~ s/^\((.*)\)$/$1/ ) {}; # Strip BALANCED brackets } for (split "\n", $txt) { s/^\s*(.*)\s*$/$1/ unless $verbatim; $ntxt .= "$_\n" unless m/^\s*$/; } # $txt =~ s/^\s*(.*)\s*$/$1/; chomp $ntxt; return $ntxt; } =head1 NAME PDL::Doc - support for PDL online documentation =head1 SYNOPSIS use PDL::Doc; $onlinedc = new PDL::Doc ($docfile); @match = $onlinedc->search('m/slice|clump/'); =head1 DESCRIPTION An implementation of online docs for PDL. =head1 Using PDL documentation PDL::Doc's main use is in the "help" (synonym "?") and "apropos" (synonym "??") commands in the perldl shell. PDL:Doc provides the infrastrucure to index and access PDL's documentation through these commands. There is also an API for direct access to the documentation database (see below). The PDL doc system is built on Perl's pod (Plain Old Documentation), included inline with each module. The PDL core modules are automatically indexed when PDL is built and installed, and there is provision for indexing external modules as well. To include your module's pod into the Perl::Doc index, you should follow the documentation conventions below. =head1 PDL documentation conventions For a package like PDL that has I<a lot> of functions it is very desirable to have some form of online help to make it easy for the user to remind himself of names, calling conventions and typical usage of the multitude of functions at his disposal. To make it straightforward to extract the relevant information from the POD documentation in source files that make up the PDL distribution certain conventions have been adopted in formatting this documentation. The first convention says that all documentation for PDL functions appears in the POD section introduced by one of the following: =head1 FUNCTIONS =head1 OPERATORS =head1 METHODS =head1 CONSTRUCTORS If you're documenting an object-oriented interface to a class that your module defines, you should use METHODS and CONSTRUCTORS as appropriate. If you are simply adding functions to PDL, use FUNCTIONS and OPERATORS as appropriate. Individual functions or methods in these section are introduced by =head2 funcname where signature is the argumentlist for a PP defined function as explained in L<PDL::PP>. Generally, PDL documentation is in valid POD format (see L<perlpod|perlpod>) but uses the C<=for> directive in a special way. The C<=for> directive is used to flag to the PDL Pod parser that information is following that will be used to generate online help. The PDL Pod parser recognises the following C<=for> directives: =over 5 =item Ref indicates that the one line reference for this function follows, e.g., =for ref Returns a piddle of lags to parent. =item Sig the signature for the current function follows, e.g., =for sig Signature: (a(n), [o]b(), [t]tmp(n)) =item Usage an indication of the possible calling conventions for the current function, e.g., =for usage wpic($pdl,$filename[,{ options... }]) =item Opt lists options for the current function, e.g., =for options CONVERTER => 'ppmtogif', # explicitly specify pbm converter FLAGS => '-interlaced -transparent 0', # flags for converter IFORM => 'PGM', # explicitly specify intermediate format XTRAFLAGS => '-imagename iris', # additional flags to defaultflags FORMAT => 'PCX', # explicitly specify output image format COLOR => 'bw', # specify color conversion LUT => $lut, # use color table information =item Example gives examples of typical usage for the current function: =for example wpic $pdl, $file; $im->wpic('web.gif',{LUT => $lut}); for (@images) { $_->wpic($name[0],{CONVERTER => 'ppmtogif'}) } =item Bad provides information on how the function handles bad values (if C<$PDL:Config{WITH_BADVAL}> is set to 1). The documentation under this directive should indicate if this function accepts piddles with bad values and under what circumstances this function might return piddles with bad values. =back The PDL podparser is implemented as a simple state machine. Any of the above C<=for> statements switches the podparser into a state where the following paragraph is accepted as information for the respective field (C<Ref>, C<Usage>, C<Opt>, C<Example> or C<Bad>). Only the text up to the end of the current paragraph is accepted, for example: =for example ($x,$y) = $a->func(1,3); # this is part of the accepted info $x = func($a,0,1); # this as well $x = func($a,$b); # but this isn't To make the resulting pod documentation also easily digestible for the existing pod filters (pod2man, pod2text, pod2html, etc) the actual textblock of information must be separated from the C<=for> directive by at least one blank line. Otherwise, the textblock will be lost in the translation process when the "normal" podformatters are used. The general idea behind this format is that it should be easy to extract the information for online documentation, automatic generation of a reference card, etc but at the same time the documentation should be translated by the standard podformatters without loss of contents (and without requiring any changes in the existing POD format). The preceding explanations should be further explained by the following example (extracted from PDL/IO/Misc/misc.pd): =head2 rcols() =for ref Read ASCII whitespaced cols from file into piddles efficiently. If no columns are specified all are assumed Will optionally only process lines matching a pattern. Can take file name or *HANDLE. =for usage Usage: ($x,$y,...) = rcols(*HANDLE|"filename", ["/pattern/",$col1, $col2,] ...) e.g., =for example ($x,$y) = rcols 'file1' ($x,$y,$z) = rcols 'file2', "/foo/",3,4 $x = PDL->rcols 'file1'; Note: currently quotes are required on the pattern. which is translated by, e.g, the standard C<pod2text> converter into: rcols() Read ASCII whitespaced cols from file into piddles efficiently. If no columns are specified all are assumed Will optionally only process lines matching a pattern. Can take file name or *HANDLE. Usage: ($x,$y,...) = rcols(*HANDLE|"filename", ["/pattern/",$col1, $col2,] ...) e.g., ($x,$y) = rcols 'file1' ($x,$y,$z) = rcols 'file2', "/foo/",3,4 $x = PDL->rcols 'file1'; Note: currently quotes are required on the pattern. It should be clear from the preceding example that readable output can be obtained from this format using the standard converters and the reader will hopefully get a feeling how he can easily intersperse the special C<=for> directives with the normal POD documentation. =head2 Which directives should be contained in the documentation The module documentation should start with the =head1 NAME PDL::Modulename -- do something with piddles section (as anyway required by C<pod2man>) since the PDL podparser extracts the name of the module this function belongs to from that section. Each function that is I<not> only for internal use by the module should be documented, introduced with the C<=head2> directive in the C<=head1 FUNCTIONS> section. The only field that every function documented along these lines should have is the I<Ref> field preceding a one line description of its intended functionality (suitable for inclusion in a concise reference card). PP defined functions (see L<PDL::PP>) should have a I<Sig> field stating their signature. To facilitate maintenance of this documentation for such functions the 'Doc' field has been introduced into the definition of C<pp_def> (see again L<PDL::PP>) which will take care that name and signature of the so defined function are documented in this way (for examples of this usage see, for example, the PDL::Slices module, especially F<slices.pd> and the resulting F<Slices.pm>). Similarly, the 'BadDoc' field provides a means of specifying information on how the routine handles the presence of bad values: this will be autpmatically created if C<BadDoc> is not supplied, or set to C<undef>. Furthermore, the documentation for each function should contain at least one of the I<Usage> or I<Examples> fields. Depending on the calling conventions for the function under consideration presence of both fields may be warranted. If a function has options that should be given as a hash reference in the form {Option => Value, ...} then the possible options (and aproppriate values) should be explained in the textblock following the C<=for Opt> directive (see example above and, e.g., PDL::IO::Pic). It is well possible that some of these conventions appear to be clumsy at times and the author is keen to hear of any suggestions for better alternatives. =cut package PDL::Doc; use PDL::Core ''; use IO::File; # for file handles use File::Basename; use PDL::Doc::Config; =head1 INSTANCE METHODS =head2 new $onlinedc = new PDL::Doc ('file.pdl',[more files]); =cut sub new { my ($type,@files) = @_; my $this = bless {},$type; $this->{File} = [@files]; $this->{Scanned} = []; $this->{Outfile} = $files[0]; return $this; } =head2 addfiles add another file to the online database associated with this object. =cut sub addfiles { my ($this,@files) = @_; push @{$this->{File}}, @files; } =head2 outfile set the name of the output file for this online db =cut sub outfile { my ($this,$file) = @_; $this->{Outfile} = $file if defined $file; return $this->{Outfile}; } =head2 ensuredb Make sure that the database is slurped in =cut sub ensuredb { my ($this) = @_; while (my $fi = pop @{$this->{File}}) { open IN, $fi or barf "can't open database $fi, scan docs first"; binmode IN; my ($plen,$txt); while (read IN, $plen,2) { my ($len) = unpack "S", $plen; read IN, $txt, $len; my (@a) = split chr(0), $txt; push(@a, "") unless(@a % 2); # Add null string at end if necessary -- solves bug with missing REF section. my ($sym, %hash) = @a; $hash{Dbfile} = $fi; # keep the origin pdldoc.db path $this->{SYMS}->{$sym} = {%hash}; } close IN; push @{$this->{Scanned}}, $fi; } return $this->{SYMS}; } =head2 savedb save the database (i.e., the hash of PDL symbols) to the file associated with this object. =cut sub savedb { my ($this) = @_; my $hash = $this->ensuredb(); open OUT, ">$this->{Outfile}" or barf "can't write to symdb $this->{Outfile}"; binmode OUT; while (my ($key,$val) = each %$hash) { next if 0 == scalar(%$val); my $fi = $val->{File}; if (File::Spec->file_name_is_absolute($fi) && -f $fi) { #store paths to *.pm files relative to pdldoc.db $val->{File} = File::Spec->abs2rel($fi, dirname($this->{Outfile})) ; } delete $val->{Dbfile}; # no need to store Dbfile my $txt = "$key".chr(0).join(chr(0),%$val); print OUT pack("S",length($txt)).$txt; } } =head2 gethash Return the PDL symhash (e.g. for custom search operations) The symhash is a multiply nested hash with the following structure: $symhash = { function_name => { Module => 'module::name', Sig => 'signature string', Bad => 'bad documentation string', ... }, function_name => { Module => 'module::name', Sig => 'signature string', Bad => 'bad documentation string', ... }, }; The possible keys for each function include: Module - module name Sig - signature Crossref - the function name for the documentation, if it has multiple names (ex: the documentation for zeros is under zeroes) Names - a comma-separated string of the all the function's names Example - example text (optional) Ref - one-line reference string Opt - options Usage - short usage explanation Bad - explanation of behavior when it encounters bad values =cut sub gethash { return $_[0]->ensuredb(); } =head2 search Search a PDL symhash =for usage $onldc->search($regex, $fields [, $sort]) Searching is by default case insensitive. Other flags can be given by specifying the regexp in the form C<m/regex/ismx> where C</> can be replaced with any other non-alphanumeric character. $fields is an array reference for all hash fields (or simply a string if you only want to search one field) that should be matched against the regex. Valid fields are Name, # name of the function Module, # module the function belongs to Ref, # the one-line reference description Example, # the example for this function Opt, # options File, # the path to the source file these docs have been extracted from If you wish to have your results sorted by function name, pass a true value for C<$sort>. The results will be returned as an array of pairs in the form @results = ( [funcname, {SYMHASH_ENTRY}], [funcname, {SYMHASH_ENTRY}], ... ); See the example at the end of the documentation to see how you might use this. =cut sub search { my ($this,$pattern,$fields,$sort) = @_; $sort = 0 unless defined $sort; my $hash = $this->ensuredb; my @match = (); # Make a single scalar $fields work $fields = [$fields] if ref($fields) eq ''; $pattern = $this->checkregex($pattern); while (my ($key,$val) = each %$hash) { FIELD: for (@$fields) { if ($_ eq 'Name' and $key =~ /$pattern/i or defined $val->{$_} and $val->{$_} =~ /$pattern/i) { $val = $hash->{$val->{Crossref}} if defined $val->{Crossref} && defined $hash->{$val->{Crossref}}; push @match, [$key,$val]; last FIELD; } } } @match = sort {$a->[0] cmp $b->[0]} @match if (@match && $sort); return @match; } # parse a regexp in the form # m/^[a-z]+/ismx # where the pairs of '/' can be replaced by any other pair of matching # characters # if the expression doesn't start with 'm' followed by a nonalphanumeric # character, return as-is sub checkregex { my ($this,$regex) = @_; return "(?i)$regex" unless $regex =~ /^m[^a-z,A-Z,0-9]/; my $sep = substr($regex,1,1); substr($regex,0,2) = ''; $sep = '(?<!\\\\)\\'.$sep; # Avoid '\' before the separator my ($pattern,$mod) = split($sep,$regex,2); barf "unknown regex modifiers '$mod'" if $mod && $mod !~ /[imsx]+/; $pattern = "(?$mod)$pattern" if $mod; return $pattern; } =head2 scan Scan a source file using the PDL podparser to extract information for online documentation =cut sub scan { my ($this,$file,$verbose) = @_; $verbose = 0 unless defined $verbose; barf "can't find file '$file'" unless -f $file; # First HTMLify file in the tree # Does not work yet #if (system ("pod2html $file")!=0) { # warn "Failed to execute command: pod2html $file2\n"; #} #else{ # Rename result (crummy pod2html) # rename ("$file.html","$1.html") if $file =~ /^(.*)\.pm$/; #} # Now parse orig pm/pod my $infile = new IO::File $file; # XXXX convert to absolute path # my $outfile = '/tmp/'.basename($file).'.pod'; open my $outfile, '>', \(my $outfile_text); # Handle RPM etc. case where we are building away from the final # location. Alright it's a hack - KGB my $file2 = $file; $file2 =~ s/^$ENV{BUILDROOTPREFIX}// if $ENV{BUILDROOTPREFIX} ne ""; my $parser = new PDL::PodParser; $parser->{verbose} = $verbose; eval { $parser->parse_from_filehandle($infile,$outfile) }; warn "cannot parse '$file'" if $@; $this->{SYMS} = {} unless defined $this->{SYMS}; my $hash = $this->{SYMS}; my @stats = stat $file; $this->{FTIME}->{$file2} = $stats[9]; # store last mod time # print "mtime of $file: $stats[9]\n"; my $phash = $parser->{SYMHASH}; my $n = 0; while (my ($key,$val) = each %$phash) { #print "adding '$key'\n"; $n++; $val->{File} = $file2; $hash->{$key} = $val } # KGB pass2 - scan for module name and function # alright I admit this is kludgy but it works # and one can now find modules with 'apropos' $infile = new IO::File $file; $outfile_text = ''; $parser = new PDL::PodParser; $parser->select('NAME'); eval { $parser->parse_from_filehandle($infile,$outfile) }; warn "cannot parse '$file'" if $@; my @namelines = split("\n",$outfile_text); my ($name,$does); for (@namelines) { if (/^(PDL) (-) (.*)/ or /^\s*(Inline::Pdlpp)\s*(-*)?\s*(.*)\s*$/ or /\s*(PDL::[\w:]*)\s*(-*)?\s*(.*)\s*$/) { $name = $1; $does = $3; } if (/^\s*([a-z][a-z0-9]*) (-+) (.*)/) { # lowercase shell script name $name = $1; $does = $3; ($name,$does) = (undef,undef) unless $does =~ /shell|script/i; } } $does = 'Hmmm ????' if $does =~ /^\s*$/; my $type = ($file =~ /\.pod$/ ? ($does =~ /shell|script/i && $name =~ /^[a-z][a-z0-9]*$/) ? 'Script:' : 'Manual:' : 'Module:'); $hash->{$name} = {Ref=>"$type $does",File=>$file2} if $name !~ /^\s*$/; return $n; } =head2 scantree Scan whole directory trees for online documentation in C<.pm> (module definition) and C<*.pod> (general documentation) files (using the File::Find module). =cut sub scantree { my ($this,$dir,$verbose) = @_; $verbose = 0 unless defined $verbose; require File::Find; print "Scanning $dir ... \n\n"; my $ntot = 0; my $sub = sub { if (($File::Find::name =~ /[.]pm$/ && $File::Find::name !~ /PP.pm/ && $File::Find::name !~ m|Pod/Parser.pm| && $File::Find::dir !~ m#/PP|/Gen#) or ( $File::Find::name =~ /[.]pod$/ && $File::Find::name !~ /Index[.]pod$/)){ printf "%-20s", $_.'...'; my $n = $this->scan($File::Find::name,$verbose); # bind $this lexically print "\t$n functions\n"; $ntot += $n; } }; File::Find::find($sub,$dir); print "\n\nfound $ntot functions\n"; } =head2 funcdocs extract the complete documentation about a function from its source file using the PDL::Pod::Parser filter. =cut sub funcdocs { my ($this,$func,$fout) = @_; my $hash = $this->ensuredb; barf "unknown function '$func'" unless defined($hash->{$func}); my $file = $hash->{$func}->{File}; my $dbf = $hash->{$func}->{Dbfile}; if (!File::Spec->file_name_is_absolute($file) && $dbf) { $file = File::Spec->rel2abs($file, dirname($dbf)); } funcdocs_fromfile($func,$file,$fout); } =head1 FUNCTIONS =cut sub funcdocs_fromfile { my ($func,$file) = @_; barf "can't find file '$file'" unless -f $file; local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager my $in = new IO::File $file; my $out = ($#_ > 1 && defined($_[2])) ? $_[2] : new IO::File "| pod2text | $PDL::Doc::pager"; barf "can't open file $file" unless $in; barf "can't open output handle" unless $out; getfuncdocs($func,$in,$out); if (ref $out eq 'GLOB') { print $out "Docs from $file\n\n"; } else { $out->print("Docs from $file\n\n"); } } sub extrdoc { my ($func,$file) = @_; open my $out, '>', \(my $out_text); funcdocs_fromfile($func,$file,$out); return $out_text; } sub getfuncdocs { my ($func,$in,$out) = @_; my $parser = Pod::Select->new; # $parser->select("\\(METHODS\\|OPERATORS\\|CONSTRUCTORS\\|FUNCTIONS\\|METHODS\\)/$func(\\(.*\\)*\\s*"); foreach my $foo(qw/FUNCTIONS OPERATORS CONSTRUCTORS METHODS/) { seek $in,0,0; $parser->select("$foo/$func(\\(.*\\))*\\s*"); $parser->parse_from_filehandle($in,$out); } } =head2 add_module =for usage use PDL::Doc; PDL::Doc::add_module("my::module"); =for ref The C<add_module> function allows you to add POD from a particular Perl module that you've installed somewhere in @INC. It searches for the active PDL document database and the module's .pod and .pm files, and scans and indexes the module into the database. C<add_module> is meant to be added to your module's Makefile as part of the installation script. =cut package PDL::Doc; sub add_module { my($module) = shift; use File::Copy qw{copy}; my($dir, $file, $pdldoc); local($_); DIRECTORY: for(@INC){ $dir = $_; $file = $dir."/PDL/pdldoc.db"; if( -f $file) { if(! -w "$dir/PDL") { die "No write permission at $dir/PDL - not updating docs database.\n"; } print "Found docs database $file\n"; $pdldoc = new ("PDL::Doc",($file)); last DIRECTORY; } } die "Unable to find docs database - therefore not updating it.\n" unless($pdldoc); my $mfile = $module; $mfile =~ s/\:\:/\//g; for(@INC){ my $postfix; my $hit = 0; for $postfix(".pm",".pod") { my $f = "$_/$mfile$postfix"; if( -e $f ){ $pdldoc->ensuredb(); $pdldoc->scan($f); eval { $pdldoc->savedb(); }; warn $@ if $@; print "PDL docs database updated - added $f.\n"; $hit = 1; } } return if($hit); } die "Unable to find a .pm or .pod file in \@INC for module $module\n"; } 1; =head1 PDL::DOC EXAMPLE Here's an example of how you might use the PDL Doc database in your own code. use PDL::Doc; # Find the pdl documentation my ($dir,$file,$pdldoc); DIRECTORY: for $dir (@INC) { $file = $dir."/PDL/pdldoc.db"; if (-f $file) { print "Found docs database $file\n"; $pdldoc = new PDL::Doc ($file); last DIRECTORY; } } die ("Unable to find docs database!\n") unless $pdldoc; # Print the reference line for zeroes: print $pdldoc->gethash->{zeroes}->{Ref}; # See which examples use zeroes $pdldoc->search('zeroes', 'Example', 1); # All the functions that use zeroes in their example: my @entries = $pdldoc->search('zeroes', 'Example', 1); print "Functions that use 'zeroes' in their examples include:\n"; foreach my $entry (@entries) { # Unpack the entry my ($func_name, $sym_hash) = @$entry; print "$func_name\n"; } print "\n"; # Let's look at the function 'mpdl' @entries = $pdldoc->search('mpdl', 'Name'); # I know there's only one: my $entry = $entries[0]; my ($func_name, $sym_hash) = @$entry; print "mpdl info:\n"; foreach my $key (keys %$sym_hash) { # Unpack the entry print "---$key---\n$sym_hash->{$key}\n"; } =head2 Finding Modules How can you tell if you've gotten a module for one of your entries? The Ref entry will begin with 'Module:' if it's a module. In code: # Prints: # Module: fundamental PDL functionality my $sym_hash = $pdldoc->gethash; print $pdldoc->gethash->{'PDL::Core'}->{Ref}, "\n" =head1 BUGS Quite a few shortcomings which will hopefully be fixed following discussions on the pdl-devel mailing list. =head1 AUTHOR Copyright 1997 Christian Soeller E<lt>c.soeller@auckland.ac.nzE<gt> and Karl Glazebrook E<lt>kgb@aaoepp.aao.gov.auE<gt> Further contributions copyright 2010 David Mertens E<lt>dcmertens.perl@gmail.comE<gt> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut 1; ����������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/Makefile.PL���������������������������������������������������������������������������0000644�0601750�0601001�00000002200�12562522364�013054� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Doc', 'VERSION_FROM' => '../Basic/Core/Version.pm', 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' 'dist' => { SUFFIX => "gz", COMPRESS => "gzip -f"}, 'PM' => { 'Doc.pm' => '$(INST_LIBDIR)$(DFSEP)Doc.pm', 'Doc$(DFSEP)Config.pm' => '$(INST_LIBDIR)$(DFSEP)Doc$(DFSEP)Config.pm', # left side must be same as PL_FILES right side 'Doc$(DFSEP)Perldl.pm' => '$(INST_LIBDIR)$(DFSEP)Doc$(DFSEP)Perldl.pm', }, 'PL_FILES' => {q[Doc$(DFSEP)Config.pm.PL]=>q[Doc$(DFSEP)Config.pm]}, 'clean' => { 'FILES' => q[Doc/Config.pm] }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); package MY; # this corrects EUMM not knowing about subdirs separated by $(DFSEP) sub init_MANPODS { my ($self) = @_; $self->SUPER::init_MANPODS; for my $doc (sort keys %{ $self->{MAN3PODS} }) { $self->{MAN3PODS}->{$doc} =~ s#\Q$(DFSEP)\E#::#g; } } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/mkhtmldoc.pl��������������������������������������������������������������������������0000644�0601750�0601001�00000016705�12562522364�013440� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # Should be called like # # perl mkhtmldoc.pl [FULLPATH_TO_SOURCE] [FULLPATH_TO_HTMLDIR] # # for example # # perl mkhtmldoc.pl `pwd`/blib/lib `pwd`/html # # reverted to use Pod::Html from normal perl distrib # Christian # # (mod. by Tjl) use File::Find; use File::Basename; use File::Basename; use Getopt::Std; use Pod::Html; use Cwd; use IO::File; # for hack_links() $opt_v = 0; $opt_s = ''; getopts('vs:'); my $verbose = $opt_v; my ($strip_path,$add_path) = split(/,/,$opt_s); ############################################################## ## Subroutines sub has_pod # does file contain HTML-able pod? { my $line; #mustn't clobber $_ during find open(POD,shift) || return 0; while ($line=<POD>) {return 1 if $line =~ /^=head/} # only a guess, avoids "=for nobody", etc. return 0; } sub mkdir_p ($$$) { return if -d $_[0]; # my @dirs = File::Spec->splitdir($_[0]); my @dirs = split '/', $_[0]; pop @dirs; if(!@dirs) {die "Couldn't create directory $_[2]"} # my $dir = File::Spec->catdir( @dirs ); my $dir = join '/', @dirs; mkdir_p ($dir, $_[1], $_[2]); print "Creating directory $_[0]\n" if $verbose; mkdir $_[0], $_[1] or die "Couldn't create directory $_[0]"; } sub fix_pdl_dot_html ($) { ##Links to PDL.html sensibly try to go up one too many directories ##(e.g., to "../PDL.html" instead of "PDL.html"). This hopefully ##fixes that. Shamelessly ripped off hack_html(). my $infile = shift; my $outfile = "${infile}.n"; my $ifh = new IO::File "<$infile" or die "ERROR: Unable to read from <$infile>\n"; my $ofh = new IO::File ">$outfile" or die "ERROR: Unable to write to <$outfile>\n"; # assume that links do not break across a line while ( <$ifh> ) { # fix the links s{\.\.\/PDL\.html}{PDL.html}g; print $ofh $_; } $ifh->close; $ofh->close; rename $outfile, $infile or die "ERROR: Unable to rename $outfile\n"; } sub fix_html_path ($) { my $infile = shift; my $outfile = "${infile}.n"; my $ifh = new IO::File "<$infile" or die "ERROR: Unable to read from <$infile>\n"; my $ofh = new IO::File ">$outfile" or die "ERROR: Unable to write to <$outfile>\n"; # assume that links do not break across a line while ( <$ifh> ) { # fix the links s{a href="$strip_path}{a href="$add_path}g; print $ofh $_; } $ifh->close; $ofh->close; rename $outfile, $infile or die "ERROR: Unable to rename $outfile\n"; } sub fix_pp_inline ($) { my $infile = shift; my $outfile = "${infile}.n"; my $ifh = new IO::File "<$infile" or die "ERROR Unable to read from <$infile>\n"; my $ofh = new IO::File ">$outfile" or die "ERROR: Unable to write to <$outfile>\n"; # assume that links do not break across a line while ( <$ifh> ) { #fix the links s|a href="../Inline/Pdlpp.html"|a href="./PP-Inline.html"|g; print $ofh $_; } $ifh->close; $ofh->close; rename $outfile, $infile or die "ERROR: Unable to rename $outfile\n"; } ############################################################## ## Code $SIG{__DIE__} = sub {print Carp::longmess(@_); die;}; $back = getcwd; $startdir = shift @ARGV; #$ARGV[0]; unless (defined $startdir) { require PDL; ($startdir = $INC{'PDL.pm'}) =~ s/\.pm$//i; umask 0022; } die "couldn't find directory '$startdir'" unless -d $startdir; chdir $startdir or die "can't change to $startdir"; $startdir = getcwd; # Hack to get absolute pathname chdir $back; $htmldir = shift @ARGV; #$ARGV[1]; #$htmldir = File::Spec->catdir( $startdir, "HtmlDocs", "PDL" ) $htmldir = "${startdir}/HtmlDocs/PDL" unless defined $htmldir; mkdir_p $htmldir, 0777, $htmldir; chdir $htmldir or die "can't change to $htmldir"; $htmldir = getcwd; # Hack to get absolute pathname chdir $back; #my $updir = File::Spec->updir; print "Making HTML docs...\n\n"; print "Put HTML $htmldir\n" if $verbose; print "Scanning $startdir ... \n\n" if $verbose; $sub = sub { return unless $File::Find::name =~ /[.]pod$/ or ($File::Find::name =~ /[.]pm$/ and $File::Find::name !~ /PP.pm/ and $File::Find::dir !~ m{/PP|/Gen}); # if (($File::Find::name =~ /[.]pm$/ and # $File::Find::name !~ /PP.pm/ and # $File::Find::dir !~ m#/PP|/Gen#) or # $File::Find::name =~ /[.]pod$/) { if (!&has_pod($File::Find::name)) { printf STDERR "%-30s\n", $_ ."... skipped (no pod)" if $verbose; return; } my $re = "\Q$startdir\E"; # ach: '+' in $outdir here! my $outdir = $File::Find::dir; # $outdir =~ s/$re/$htmldir/; $outdir =~ s/$re//; $outdir =~ /(^\/)?(.*)$/; my $basename = basename($File::Find::name); my $outfi; # Special case for needed for PDL.pm file since it is in a # different location than the other .pm and pod files. if( $basename eq 'PDL.pm'){ $outfi = $basename; } else { $outfi = $2.($2 =~ /^\s*$/ ? '' : '/').$basename; # # with the following substitution, everything gets stored in the same directory - # so PDL/Graphics/LUT -> PDL_Graphics_LUT for example # #$outfi =~ s|/|_|g; } # create the output directory, if required if ( $outdir ne "" ) { # $outdir = File::Spec->catdir( $htmldir, $outdir ); $outdir = "${htmldir}/${outdir}"; mkdir_p $outdir, 0777, $outdir; } # print "outdir = $outdir, making $outfi\n"; return; # mkdir_p $outdir, 0777, $outdir; my $file = $File::Find::name; # my $outfile = File::Spec->catfile( $htmldir, $outfi ); my $outfile = "${htmldir}/${outfi}"; $outfile =~ s/[.](pm|pod)$//; $outfile .= ".html"; printf STDERR "%-30s\n", $_ ."..."; # > $outfile"; chdir $htmldir; # reuse our pod caches my $topPerlDir = $startdir; # get Directory just above PDL for podroot arg $topPerlDir = $1 if ($startdir =~ /^(.+?)\/PDL$/); print "startdir: $startdir, podroot: $topPerlDir\n" if $verbose; # instead of having htmlroot="../../.." # (or even File::Spec->catdir( $updir, $updir, $updir ) ) # calculate it from the known location of the # file we're creating my $htmlrootdir = $htmldir; $htmlrootdir =~ s|PDL$||; my $verbopts = $verbose ? "--verbose" : "--quiet"; my @pod2html_args = ( "--podpath=.", "--podroot=$topPerlDir", "--htmldir=$htmlrootdir", "--recurse", "--infile=$file", "--outfile=$outfile", $verbopts, ); if($] <= 5.015) { # With perl 5.15.x (for some value of x) and later, '--libpods' is invalid # and hence needs to be removed. # Beginning with 5.15.x, the generated PDL html docs are a little different # (missing some underlining of headings and some <b></b> tagging), though # this appears to have nothing to do with the removal of --libpods. Rather, # it seems to be the result of some other change to pod2html. Perhaps this # can be addressed over time. SIS 23-Feb-2012 # Cut out "PDL" from the podpath as it crashes the podscan(!) - It doesn't # seem to help either -- it looks for cached docs in .../HtmlDocs/pdl/PDL, # which is silly. I left this note because pod paths are pretty arcane to # me. CED 11-Mar-2009 # pod2html("--podpath=PDL:.", unshift @pod2html_args, "--libpods=perlfaq"; } pod2html(@pod2html_args); fix_pdl_dot_html( $outfile); fix_html_path( $outfile); fix_pp_inline( $outfile); chdir $File::Find::dir; # don't confuse File::Find }; #File::Find::find($sub,$startdir,File::Spec->catdir( $startdir, $updir, "PDL.pm")); File::Find::find( $sub, $startdir, "${startdir}/../PDL.pm" ); ## End �����������������������������������������������������������PDL-2.018/Doc/mkpdlfuncpod��������������������������������������������������������������������������0000644�0601750�0601001�00000004317�12562522364�013526� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use PDL::Doc; use PDL::Doc::Perldl; # @dontmod = qw/ PDL::Graphics::TriD::Tk /; %Category = ( IO => '^PDL::IO', Graphics => '^PDL::Graphics', Core => '^PDL::Core| ^PDL::Primitive| ^PDL::Slices| ^PDL::Math| ^PDL::Basic', Lib => '^PDL::Image |^PDL::Slatec |^PDL::FFT |^PDL::Filter |^PDL::Fit |^PDL::Gaussian |^PDL::GSL', Dev => '^PDL::Types |^PDL::Dbg |^PDL::Options |^PDL::Autoloader |^PDL::Callext |^PDL::Doc::Perldl', Derived => '^PDL::Complex |^PDL::Char |^PDL::Func', ); sub nofunc { my ($func,$hash) = @_; if ($func =~ /AUTOLOAD |MainLoop /xs || $hash->{Ref} =~ /^internal$/) { print STDERR "skipping $func\n"; return 1 } else { return 0 } } # a very simple script to generate a huge manpage of all documented # PDL functions # mainly to demonstrate what we can do with the new doc format print << 'EOD'; =head1 NAME pdlfunc - Functions in the PDL distribution =head1 DESCRIPTION This is a listing of all documented functions in the PDL distribution. =head2 Alphabetical Listing of PDL Functions =over 8 EOD $onldc = $PDL::onlinedoc; # new PDL::Doc ('/tmp/pdlhash.dbtxt'); $db = $onldc->ensuredb; while (my ($key,$val) = each %$db) { my $strip = $key; $strip =~ s/PDL.*::(.*)$/$1/; $val->{Stripped} = $strip; } @match = $onldc->search('.*',['Name'],1); @match = sort {lc $a->[1]->{Stripped} cmp lc $b->[1]->{Stripped}} @match; for (@match) { next if $_->[1]->{Ref} =~ /(Module|Manual):/ || nofunc $_->[1]->{Stripped}, $_->[1]; $sh = new StrHandle; print STDERR "function $_->[0] ($_->[1]->{Stripped})\n"; $onldc->funcdocs($_->[0],$sh); $mod = "\n\nModule: $_->[1]->{Module}\n\n"; $stripped = $_->[1]->{Stripped}; $txt = $sh->text; $txt =~ s/=head2 (.*)$/=item $stripped$mod/mg; $txt =~ s/^=cut\s*$//mg; $txt =~ s/^=for.*$//mg; $txt =~ s/Docs from .*$//mg; print $txt; } print <<'EOD'; =back EOD �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/README��������������������������������������������������������������������������������0000644�0601750�0601001�00000005762�12562522364�012002� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������This is a first try to get something like online help for PDL. Building proceeds as usual: perl Makefile.PL make Then there are a few things you should try: 1) Scan the current PDL distribution (PDL-1.94_05 + PATCHES) for online help info: perl -Mblib scantree.pl and specify the location of your *installed* PDL distribution (either the default or YOUR_PDL_DIR/blib/lib/PDL if you haven't installed it) when asked to do so. 2) Try the online doc support from within perldl (in the root directory of the PDL-Doc distribution): perldl and at the perldl prompt, type 'help': perldl> help and proceed from there. For details check the supplied file 'local.perldlrc'. 3) If you want to see which info has been picked from your POD documentation try perl -Mblib docscan <filename> in the root directory of the PDL-Doc distribution. 4) Once you have built the online info database (see step 1) try the example that builds a 'pdlfunc' manpage by saying: perl -Mblib mkpdlfuncpod >pdlfunc.pod This is just a demonstration of what should become possible once the online docs work correctly. 5) If you prefer the itemised listing of PDL functions in the manpage version, try perl -Mblib pdlhead2item <filename.pm> > <tmpname.pod> pod2man <tmpname.pod> | nroff -man | more that translates the <=head2> directives into an itemised list. This is again just a demo what can be done. For info about the POD format conventions used by the PDL podparser to identify the online documentation check the docs in Doc.pm. There are still quite a few shortcomings in the implementation: 1) the podparser code is currently a bit messy 2) scanning is done very naively. No real checks are made if a function is documented in several files, etc. Needs to be done once integerated with the PDL distrib. 3) Scanning and database updating should be integerated with the build process. An updating policy should be developed. 4) The PP changes to support the new doc style are poorly documented, for the moment refer to the examples supplied in the patches to PDL-1.94_05. Briefly, the 'Doc' key has been introduced and PP will generate the =head2 funcname =for sig Signature: (...) entries automatically. No docs are generated if you say pp_def('XXXXfunc', Doc => 'internal',... ); pp_addpm has been changed to optionally accept an option hash ref to specify if the pm text should be inserted at the top, in the middle or at the bottom. I'm not sure of this is necessary/a good solution yet. 6) If the symhash should grow beyond the point where it is practical to hold it all in memory the implementation should use some kind of cached AnyDBM inplementation. 7) and probably lots of other things... Christian Soeller <c.soeller@auckland.ac.nz> Changes for intergration in to PDL distribution - changed scantree.pl to take args for directory, database. - moved local.perldlrc into PDL::Doc::Perldl module - Made "borrowed" Pod:: stuff into PDL::Pod:: for now. Karl Glazebrook <kgb@aaoepp.aao.gov.au> ��������������PDL-2.018/Doc/scantree.pl���������������������������������������������������������������������������0000644�0601750�0601001�00000005322�13036512174�013246� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use PDL::Doc; use Getopt::Std; use Config; use Cwd; require PDL; # always needed to pick up PDL::VERSION $opt_v = 0; getopts('v'); $dirarg = shift @ARGV; $outdb = shift @ARGV; $outindex = shift @ARGV; unless (defined $dirarg) { ($dirarg = $INC{'PDL.pm'}) =~ s/PDL\.pm$//i; umask 0022; print "DIR = $dirarg\n"; } my @dirs = split /,/,$dirarg; unless (defined $outdb) { $outdb = "$dirs[0]/PDL/pdldoc.db"; print "DB = $outdb\n"; } $currdir = getcwd; unlink $outdb if -e $outdb; $onldc = new PDL::Doc(); $onldc->outfile($outdb); foreach $dir (@dirs) { chdir $dir or die "can't change to $dir"; $dir = getcwd; $onldc->scantree($dir."/PDL",$opt_v); $onldc->scan($dir."/PDL.pm",$opt_v) if (-s $dir."/PDL.pm"); chdir $currdir; } print STDERR "saving...\n"; $onldc->savedb(); @mods = $onldc->search('module:',['Ref'],1); @mans = $onldc->search('manual:',['Ref'],1); @scripts = $onldc->search('script:',['Ref'],1); $outdir = "$dirs[0]/PDL"; # ($outdir = $INC{'PDL.pm'}) =~ s/\.pm$//i; $outindex="$outdir/Index.pod" unless (defined $outindex); unlink $outindex if -e $outindex; # Handle read only file open POD, ">$outindex" or die "couldn't open $outindex"; print POD <<'EOPOD'; =head1 NAME PDL::Index - an index of PDL documentation =head1 DESCRIPTION A meta document listing the documented PDL modules and the PDL manual documents =head1 PDL manuals EOPOD #print POD "=over ",$#mans+1,"\n\n"; print POD "=over 4\n\n"; for (@mans) { my $ref = $_->[1]->{Ref}; $ref =~ s/Manual:/L<$_->[0]|$_->[0]> -/; ## print POD "=item L<$_->[0]>\n\n$ref\n\n"; # print POD "=item $_->[0]\n\n$ref\n\n"; print POD "=item *\n\n$ref\n\n"; } print POD << 'EOPOD'; =back =head1 PDL scripts EOPOD #print POD "=over ",$#mods+1,"\n\n"; print POD "=over 4\n\n"; for (@scripts) { my $ref = $_->[1]->{Ref}; $ref =~ s/Script:/L<$_->[0]|PDL::$_->[0]> -/; ## print POD "=item L<$_->[0]>\n\n$ref\n\n"; # print POD "=item $_->[0]\n\n$ref\n\n"; print POD "=item *\n\n$ref\n\n"; } print POD << 'EOPOD'; =back =head1 PDL modules EOPOD #print POD "=over ",$#mods+1,"\n\n"; print POD "=over 4\n\n"; for (@mods) { my $ref = $_->[1]->{Ref}; next unless $_->[0] =~ /^PDL/; if( $_->[0] eq 'PDL'){ # special case needed to find the main PDL.pm file. $ref =~ s/Module:/L<PDL::PDL|PDL::PDL> -/; ## print POD "=item L<PDL::PDL>\n\n$ref\n\n"; # print POD "=item PDL::PDL\n\n$ref\n\n"; print POD "=item *\n\n$ref\n\n"; next; } $ref =~ s/Module:/L<$_->[0]|$_->[0]> -/; ## print POD "=item L<$_->[0]>\n\n$ref\n\n"; # print POD "=item $_->[0]\n\n$ref\n\n"; print POD "=item *\n\n$ref\n\n"; } print POD << "EOPOD"; =back =head1 HISTORY Automatically generated by scantree.pl for PDL version $PDL::VERSION. EOPOD close POD; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Doc/TODO����������������������������������������������������������������������������������0000644�0601750�0601001�00000000247�12562522364�011603� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������- rearrange hash structure to root->{Module}->{Funcname} to avoid name clashes - warn about duplicate documentation - policy to integrate with build process ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/����������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�011756� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Benchmark/������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013650� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Benchmark/Bench.pm����������������������������������������������������������������0000644�0601750�0601001�00000001731�12562522364�015247� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Old results: approx. 1.91_03: 34 secs (512, 10 iter) # With simply folded-out threading: 3.4 secs (10fold!) # For 512,30iter: package PDL::Bench; use vars qw(@ISA @EXPORT $AUTOLOAD); require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @EXPORT = qw( do_benchmark ); bootstrap PDL::Bench; use Benchmark; sub do_benchmark { $size = 512; $niter = 80; $piddle = (PDL->zeroes($size,$size)); $dref = ${$piddle->get_dataref()}; timethese($niter, { # 'With double piddle' => 'for($i=0; $i<100; $i++) {$piddle++}', 'With double piddle' => '$piddle++;', 'C using ++' => 'c_use_pp($dref)', 'C using foo = bar + baz' => 'c_use_add($dref,$dref,$dref)', 'C using incrs and foo = bar + baz' => 'c_use_add_incr($dref,$dref,$dref,1,1,1)' }); } 1; ���������������������������������������PDL-2.018/Example/Benchmark/Bench.xs����������������������������������������������������������������0000644�0601750�0601001�00000002001�12562522364�015254� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif MODULE = PDL::Bench PACKAGE = PDL::Bench void c_use_pp(sv) SV *sv; CODE: /* Let's hope the C compiler isn't smart enough to optimize * away everything */ double *p = (double *) SvPV(sv,PL_na); int i = SvCUR(sv) / sizeof(double); while(i--) { (*p)++; p++; } void c_use_add(sv1,sv2,sv3) SV *sv1; SV *sv2; SV *sv3; CODE: double *p1 = (double *) SvPV(sv1,PL_na); int i = SvCUR(sv1) / sizeof(double); double *p2 = (double *) SvPV(sv2,PL_na); double *p3 = (double *) SvPV(sv3,PL_na); while(i--) { *p1 = *p2 + *p3; p1 ++; p2 ++; p3 ++; } void c_use_add_incr(sv1,sv2,sv3,i1,i2,i3) SV *sv1; SV *sv2; SV *sv3; int i1; int i2; int i3; CODE: double *p1 = (double *) SvPV(sv1,PL_na); int i = SvCUR(sv1) / sizeof(double); double *p2 = (double *) SvPV(sv2,PL_na); double *p3 = (double *) SvPV(sv3,PL_na); while(i--) { *p1 = *p2 + *p3; p1 += i1; p2 += i2; p3 += i3; } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Benchmark/Makefile.PL�������������������������������������������������������������0000644�0601750�0601001�00000000463�12562522364�015645� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Bench', 'VERSION_FROM' => '../../Basic/Core/Version.pm', # finds $VERSION 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' ); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Benchmark/README������������������������������������������������������������������0000644�0601750�0601001�00000000300�12562522364�014541� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Just say "perl Makefile.PL" and run time.pl to obtain timing data for your machine. You can edit Bench.pm for different parameters / running times if your machine is very slow or very fast. ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Benchmark/time.pl�����������������������������������������������������������������0000644�0601750�0601001�00000000200�12562522364�015153� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib "."; use blib "../.."; use PDL; # use PDL::Bench; BEGIN{ require "Bench.pm"; PDL::Bench->import(); } do_benchmark(); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Fit/������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�012500� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Fit/lmfit_example.pl��������������������������������������������������������������0000644�0601750�0601001�00000005341�13036512174�015701� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use PDL; use PDL::Math; use PDL::Fit::LM; use strict; ### fit using pdl's lmfit (Marquardt-Levenberg non-linear least squares fitting) ### ### `lmfit' Syntax: ### ### ($ym,$finalp,$covar,$iters) ### = lmfit $x, $y, $sigma, \&fn, $initp, {Maxiter => 300, Eps => 1e-3}; ### ### Explanation of variables ### ### OUTPUT ### $ym = pdl of fitted values ### $finalp = pdl of parameters ### $covar = covariance matrix ### $iters = number of iterations actually used ### ### INPUT ### $x = x data ### $y = y data ### $sigma = piddle of y-uncertainties for each value of $y (can be set to scalar 1 for equal weighting) ### \&fn = reference to function provided by user (more on this below) ### $initp = initial values for floating parameters ### (needs to be explicitly set prior to use of lmfit) ### Maxiter = maximum iterations ### Eps = convergence criterion (maximum normalized change in Chi Sq.) ### Example: # make up experimental data: my $xdata = pdl sequence 5; my $ydata = pdl [1.1,1.9,3.05,4,4.9]; # set initial prameters in a pdl (order in accord with fit function below) my $initp = pdl [0,1]; # Weight all y data equally (else specify different uncertainties in a pdl) my $sigma = 1; # Use lmfit. Fourth input argument is reference to user-defined # subroutine ( here \&linefit ) detailed below. my ($yf,$pf,$cf,$if) = lmfit $xdata, $ydata, $sigma, \&linefit, $initp; # Note output print "\nXDATA\n$xdata\nY DATA\n$ydata\n\nY DATA FIT\n$yf\n\n"; print "Slope and Intercept\n$pf\n\nCOVARIANCE MATRIX\n$cf\n\n"; print "NUMBER ITERATIONS\n$if\n\n"; # simple example of user defined fit function. Guidelines included on # how to write your own function subroutine. sub linefit { # leave this line as is my ($x,$par,$ym,$dyda) = @_; # $m and $b are fit parameters, internal to this function # call them whatever make sense to you, but replace (0..1) # with (0..x) where x is equal to your number of fit parameters # minus 1 my ($m,$b) = map { $par->slice("($_)") } (0..1); # Write function with dependent variable $ym, # independent variable $x, and fit parameters as specified above. # Use the .= (dot equals) assignment operator to express the equality # (not just a plain equals) $ym .= $m * $x + $b; # Edit only the (0..1) part to (0..x) as above my (@dy) = map {$dyda -> slice(",($_)") } (0..1); # Partial derivative of the function with respect to first # fit parameter ($m in this case). Again, note .= assignment # operator (not just "equals") $dy[0] .= $x; # Partial derivative of the function with respect to next # fit parameter ($b in this case) $dy[1] .= 1; # Add $dy[ ] .= () lines as necessary to supply # partial derivatives for all floating parameters. } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/����������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�014174� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/inlpp.pl��������������������������������������������������������������0000644�0601750�0601001�00000001242�12562522364�015672� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; use PDL; # this must be called before (!) 'use Inline Pdlpp' calls use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $a = sequence 10; print $a->inc,"\n"; print $a->inc->dummy(1,10)->tcumul,"\n"; __DATA__ __Pdlpp__ # a rather silly increment function pp_def('inc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); # a cumulative product # essentially the same functionality that is # already implemented by prodover # in the base distribution pp_def('tcumul', Pars => 'in(n); float+ [o] mul()', Code => '$mul() = 1; loop(n) %{ $mul() *= $in(); %}', ); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/inlppminimal.pl�������������������������������������������������������0000644�0601750�0601001�00000001024�12562522364�017237� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; # we're inside the dist tree use PDL; # this must be called before (!) 'use Inline Pdlpp' calls use PDL::NiceSlice; # only used to demonstrate how to switch off below use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $a = sequence 10; print $a(0:4),"\n"; print $a->inc->(0:4),"\n"; # important! no PDL::NiceSlice; # disable NiceSlice before(!) the data section __END__ __Pdlpp__ # a silly function, really ;) pp_def('inc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/inlpp_link.pl���������������������������������������������������������0000644�0601750�0601001�00000002003�12562522364�016703� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use blib; # when using inside the dist tree use PDL; # this must be called before (!) 'use Inline Pdlpp' calls # for this example you need the numerical recipes library # edit the INC and LIBS info below to point # Inline towards the location of include and library files use Inline Pdlpp => Config => INC => "-I$ENV{HOME}/include", LIBS => "-L$ENV{HOME}/lib -lnr -lm", AUTO_INCLUDE => <<'EOINC', #include <math.h> #include "nr.h" /* for poidev */ #include "nrutil.h" /* for err_handler */ static void nr_barf(char *err_txt) { fprintf(stderr,"Now calling croak...\n"); croak("NR runtime error: %s",err_txt); } EOINC BOOT => 'set_nr_err_handler(nr_barf);'; # catch errors at the perl level use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $a = zeroes(10) + 30;; print $a->poidev(-3),"\n"; __DATA__ __Pdlpp__ # poisson deviates pp_def('poidev', Pars => 'xm(); [o] pd()', GenericTypes => [L,F,D], OtherPars => 'long idum', Code => '$pd() = poidev((float) $xm(), &$COMP(idum));', ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/Module/���������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402045�015420� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/Module/Makefile.PL����������������������������������������������������0000644�0601750�0601001�00000000517�12562522364�017416� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Inline::MakeMaker; # to allow us to install the inlined code ! # Note use of 'WriteInlineMakefile' in place of the normal # 'WriteMakefile' call! Syntax of args is identical to MakeMaker. WriteInlineMakefile( 'NAME' => 'PDL::MyInlineMod', 'VERSION_FROM' => 'MyInlineMod.pm', # finds $VERSION ); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/Module/MyInlineMod.pm�������������������������������������������������0000644�0601750�0601001�00000005136�12562522364�020170� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Below is the stub of documentation for your module. You better edit it! =head1 NAME PDL::MyInlineMod - a simple PDL module containing inlined Pdlpp code =head1 SYNOPSIS use PDL::MyInlineMod; $a = zeroes 10, 10; $twos = $a->plus2; # a simple function =head1 DESCRIPTION A simple example module that demonstrates the usage of inlined Pdlpp in a module that can be installed in the usual way. =head1 FUNCTIONS =cut package PDL::MyInlineMod; # use strict; # strict results in trouble with barewords when using Inline :( # no strict 'vars'; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); require PDL::Exporter; @ISA = qw(PDL::Exporter); # functions you want to export into the caller's name space @EXPORT_OK = qw(myinc plus2); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); BEGIN { # in BEGIN to make sure we can use $VERSION in the # 'use Inline...' call below $VERSION = '0.60'; # Inline requires this to be a *string* that matches # /^\d\.\d\d$/ # see Inline-FAQ for more info } use PDL::LiteF; # quirk 1 follows use Inline::MakePdlppInstallable; # allow installation of this module use Inline Pdlpp => DATA => # inlined PP code is below in DATA section NAME => PDL::MyInlineMod, # required info for module installation VERSION => $VERSION; # ditto, see Inline-FAQ for more info # quirk 2 follows Inline->init; # you need this if you want to 'use' your module # from within perldl or pdl2 and your Pdlpp code # resides in the DATA section (as in this example) # following required to make exported functions work! # PDL::PP used to make these automatically but now we have # to make them manually since *we* are writing the pm-file *myinc = \&PDL::myinc; # make alias in this module's name space *plus2 = \&PDL::plus2; # ditto 1; __DATA__ __Pdlpp__ # some simple functions to test the whole thing =head2 myinc =for ref a very simple pp function that increments its argument =for sig myinc(i();[o] o()) =cut pp_def('myinc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); =head2 plus2 =for ref a very simple pp function that increments its argument by 2 =for sig plus2(i();[o] o()) =cut pp_def('plus2', Pars => 'i();[o] o()', Code => '$o() = $i() + 2;', ); =head1 AUTHOR C. Soeller (C) 2002. All rights reserved. This code can be distributed under the same terms as PDL itself (see the file COPYING in the PDL distribution). =head1 SEE ALSO perl(1). L<Inline>. L<Inline::Pdlpp>. =cut ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/Module/t/�������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402044�015662� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/InlinePdlpp/Module/t/myinlinemod.t������������������������������������������������0000644�0601750�0601001�00000001537�12562522364�020423� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..3\n"; } END {print "not ok 1\n" unless $loaded;} use PDL::MyInlineMod; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): use PDL::LiteF; my $a = zeroes 10; my $b = $a->myinc; print "$b\n"; print 'not ' unless all $b == 1; print "ok 2\n"; my $c = $a->plus2; print "$c\n"; print 'not ' unless all $c == 2; print "ok 3\n"; �����������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/IO/�������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402045�012264� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/IO/wmpeg.pl�����������������������������������������������������������������������0000644�0601750�0601001�00000003612�12562522364�013763� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl # # Created on: Wed 28 Jul 2010 03:41:45 PM # Last saved: Thu 10 Feb 2011 05:10:44 PM use PDL; use PDL::IO::Pic; use PDL::NiceSlice; # This is a simple program to create a demo MPEG-1 # movie via the wmpeg() routine in PDL::IO::Pic # and to test the functionality of using ffmpeg # in place of the outdated mpeg_encoder. # a simple parabolic trajectory ("bouncing ball") # for 30 128x80 image frames our $coords = pdl( q[ [ 0 1 0] [ 4 9 1] [ 8 17 2] [ 12 25 3] [ 16 32 4] [ 20 38 5] [ 24 43 6] [ 28 48 7] [ 32 53 8] [ 36 57 9] [ 40 60 10] [ 44 62 11] [ 48 64 12] [ 52 66 13] [ 56 66 14] [ 60 66 15] [ 64 66 16] [ 68 65 17] [ 72 63 18] [ 76 60 19] [ 80 57 20] [ 84 54 21] [ 88 50 22] [ 92 45 23] [ 96 39 24] [100 33 25] [104 27 26] [108 19 27] [112 11 28] [116 3 29] ] ); our $frames = zeros byte, 128, 80, 30; our $val = pdl(byte,250); # start with white # make the square ball bounce $frames->range($coords,[10,10,1]) .= $val; # now make the movie $frames = $frames->(*3)->copy; # the encoding type is from the suffix # .mp4 seems to work better than .mpg on # Windows Media Player $frames->wmpeg('bounce.mp4'); # use bounce.gif for animated GIF # output (uncompressed => big) ����������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/PGPLOT/���������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�012763� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/PGPLOT/pgplot.pl������������������������������������������������������������������0000644�0601750�0601001�00000020574�12562522364�014655� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME std_pgplot - Examples of PGPLOT routines. =head1 SYNOPSIS std_pgplot.pl =head1 DESCRIPTION This file is intended to show the use of PGPLOT routines using the object-oriented approach. =cut use PDL; use PDL::Graphics::PGPLOT::Window; ## ## Test all PGPLOT routines. ## my $random = grandom(1000); my ($xc, $yc)=hist $random; my $x=zeroes(100)->xlinvals(-5,5); my $y=exp(-$x*$x/2); print "First we will test all functions in PGPLOT.\n"; print "We also will show most of the options\n"; print "After each plot - please press <CR> to proceed - type q<CR> to quit.\n"; function_to_do ('dev(), env(), hold(), release(), bin(), line()'); # # Create a window object to which we will subsequently plot. # my $w = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 1, WindowWidth => 7}); # Note how we call the functions via the window object. This particular # call will set the axis colour to Red. $w->env(-5, 5, 0, max($yc)*1.1, {Axiscolour => 'Red'}); # Plot a histogram. $w->bin($xc, $yc); # Hold the plot. You can subsequently test whether the plot is held # by calling held() - which returns true (1) if the plot is held. $w->hold(); # This draws a line plot on top of the histogram. Note that you can # refer to options using only the first part of their name - and case # doesn't matter either. It is advised however to use the full name # for options since in some cases you could imagine getting the # wrong result. $w->line($x, $y*max($yc), {LineSty => 'Dashed', Color => 'Blue', LineWidth => 5}); # Release your connection so that the next plotting command will # erase the screen and create a new plot. $w->release(); # These two are just a convenience functions for this demo.. next_plot(); function_to_do ('errb() & points()'); # Create some more data - this time for plots with errorbars. my $xd = pdl(1,3,7,10); my $yd = pdl(2, 7,5,7); my $dy = sqrt($yd**2/12+0.2**2); # This is how you set titles on plots. If you forget to you can # use the label_axes() command (see below) to set them later. $w->env(0, 15, 0, 10, {Xtitle => 'X-data', Ytitle=>'Y-data', Title => 'An example of errb and points', Font => 'Italic'}); # Plot the data as points $w->points($xd, $yd); # Overplot (implicit) the points with error-bars. $w->errb($xd, $yd, $dy); $w->release(); next_plot(); function_to_do('line() poly(), cont(), label_axes() and text()'); # Create an image. my $im = rvals(100, 100); # Draw contours - and hold the plot because will clutter it some more. $w->cont($im, {NCOn => 4}); $w->hold(); # Note that the colours can be specified also in upper case. They can # also be referred to with numbers in keeping with the PGPLOT tradition. $w->line(pdl(0, 50), pdl(0, 50), {Color => 'RED'}); # The corners of a polygon - note that the last should be equal to the # first to get the expected results. my $px = pdl(20, 40, 40, 20, 20); my $py = pdl(80, 80, 100, 100, 80); # The poly function draws polygons - note that we set the fill using # the numerical notation here - this sets a hatched fill. $w->poly($px, $py, {Fill => 3}); # Pay attention to the hatching command as it sets the properties using # an anonymous hash again. I would normally construct this separately # and use a variable for this for readability. $w->poly($px, $py, {Color=>'Red', Fill => 3, Hatch => {Phase => 0.5}}); # label_axes() is a separate function to set the axis titles. This is # often clearer although less compact than setting it directly in the # env() function. $w->label_axes('X-direction', 'Y-direction', 'Title', {Color => 'Yellow'}); # The text() command puts text on the display and can be displayed using # different justifications, angles and fonts as well as colours. $w->text('Towards the centre', 24, 25, {Justification => 0.5, Angle=>45, Font => 'Italic'}); next_plot(); function_to_do('imag(), ctab(), hi2d and several panels'); # # We now create a new window for image display since we want several # panels in the plot window. This requires a new window to be created # at present - changes to the code welcome. # $w->close(); $w = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 0.5, NX => 2, NY => 2, CharSize => 2}); # Display the image using a transform between the pixel coordinates # and the display coordinates. $w->imag($im, {Transform => pdl([0, 0.1, 0, 0, 0, 0.1])}); # This command will go in the next panel and will display the image using # a square root transfer function and square pixels (PIX => 1) $w->imag1($im, {PIX => 1, ITF=>'Sqrt'}); # You set the colour table using ctab() $w->ctab('Fire'); $w->imag($im); # A hold command in a multi-panel situation keeps you in the same panel. $w->hold(); # So that you can overplot a contour plot for instance... $w->cont($im, {Color => 'Yellow'}); $w->release(); # The hi2d() function draws a 2D histogram of the data and could very # likely be improved by someone with some extra time on their hands. $w->hi2d($im->slice('0:-1:10,0:-1:10')); next_plot(); function_to_do('Several plot windows. focus_window(), window_list()'); # # Multiple windows - the secret unveiled... Well, it is easy actually # at least when you use the OO interface! # $w->close(); my $w1 = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 1, AxisColour => 'Blue', WindowName => 'First', WindowWidth => 6}); my $w2 = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 0.618, AxisColour => 'Red', WindowWidth => 6}); # First draw something in Window 1 $w1->line($x, $x**2); $w1->hold(); # Then switch to window 2... my $ii = which($x>=0); $w2->points($x->index($ii), sqrt($x->index($ii))); $w2->hold(); $w2->line($x->index($ii), sqrt($x->index($ii)), {Color => 'Red', Linestyle => 'dashed'}); $w2->release(); # Switch back to window 1 - note how easier it is with the OO interface. $w1->points($x, $x**2+$x->grandom()); $w1->release(); # In the OO interface there is no built-in way to keep track of different # windows in the way that the non-OO interface does, but on the other hand # you don't really need it. # See the std_pgplot.pl file for an example of this. next_plot(); function_to_do('legend(), cursor()'); # Let's close Window2 and continue our examples in window 1. $w2->close(); # The legend function draws legends on plots which can be for different # symbols, linestyles, widths and mixtures. $w1->legend(['Parabola', 'Scatter points'], -2, 20, {Width => 5, LineStyle => ['Solid', undef], Symbol => [undef, 'Default']}); # # Now read the cursor - different types of cursor can be chosen print "Select a point using the cursor:\n"; my ($xp, $yp)=$w1->cursor({Type => 'CrossHair'}); print "(X, Y)=($xp, $yp)\n"; next_plot(); function_to_do('circle(), ellipse(), rectangle() and arrow()'); # The circle, ellipse and rectangle functions do not take note of the # intrinsic display aspect ratio so if you want a really round circle, # you must make sure that the aspect ratio is 1. $w1->close(); $w1 = PDL::Graphics::PGPLOT::Window->new({Device => '/xs', Aspect => 1, WindowWidth => 6}); $w1->env(0, 100, 0,100); # Draw a circle - at the moment the default fill-style is solid so we need # to specify the outline fill to get a non-filled circle.. $w1->circle(50, 50, 10, {Fill => 'Outline'}); # The ellipse can be specified with major and minor axis and the rotation # angle for the ellipse, but note that the angle must be specified in radians.. $w1->ellipse(40, 20, {MajorAxis => 30, MinorAxis=> 10, Theta => 30*3.14/180, Colour => 'Red'}); # The angle must be specified in radians for the rectangle too.... $w1->rectangle(70, 70, {XSide => 10, Angle => 45*3.14/180}); # And finally draw an arrow... $w1->arrow(40, 20, 70, 20, {Color => 'Green'}); next_plot(); $w1->close(); $w1 = PDL::Graphics::PGPLOT::Window->new({Device => '/xs', Aspect => 1, NX => 2, NY => 2}); $w1->line($x, $y); # The important thing here is to show that you can jump directly to a given # panel and start drawing in this.. $w1->bin($xc, $yc, {Panel => 3}); $w1->env(0, 1, 0, 1, {Axis => 'Box'}); $w1->text("That's all folks!", 0.5, 0.5, {Justification => 0.5, CharSize => 5, Color => 'Yellow'}); next_plot(); sub function_to_do { print "\n**************************\n"; print "* $_[0]\n"; print "**************************\n\n"; } sub next_plot { my $message = shift; $message ||=''; print $message."\n"; my $in = <STDIN>; if ($in =~ /^q/i) { exit; } } ������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/PGPLOT/std_pgplot.pl��������������������������������������������������������������0000644�0601750�0601001�00000010007�12562522364�015515� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME std_pgplot - Examples of PGPLOT routines. =head1 SYNOPSIS std_pgplot.pl =head1 DESCRIPTION This file is intended to show the use of PGPLOT routines using the standard interface. See the C<pgplot.pl> file for an object-oriented version of the same (the object-oriented interface is strongly recommended.) =cut use PDL; use PDL::Graphics::PGPLOT; ## ## Test all PGPLOT routines. ## my $random = grandom(1000); my ($xc, $yc)=hist $random; my $x=zeroes(100)->xlinvals(-5,5); my $y=exp(-$x*$x/2); print "First we will test all functions in PGPLOT.\n"; print "We also will show most of the options\n"; print "After each plot - please press <CR> to proceed - type q<CR> to quit.\n"; function_to_do ('dev(), env(), hold(), release(), bin(), line()'); my $win1 = dev('/xw', {Aspect => 1, WindowWidth => 7}); env(-5, 5, 0, max($yc)*1.1, {Axiscolour => 'Red'}); bin $xc, $yc; hold; line $x, $y*max($yc), {LineSty => 'Dashed', Color => 'Blue', LineWidth => 5}; release; #close_window($win); next_plot(); function_to_do ('errb() & points()'); my $xd = pdl(1,3,7,10); my $yd = pdl(2, 7,5,7); my $dy = sqrt($yd**2/12+0.2**2); env(0, 15, 0, 10, {Xtitle => 'X-data', Ytitle=>'Y-data', Title => 'An example of errb and points', Font => 'Italic'}); points $xd, $yd; errb $xd, $yd, $dy; release; next_plot(); function_to_do('line() poly(), cont(), label_axes() and text()'); my $im = rvals(100, 100); cont $im, {NCOn => 4}; hold; line pdl(0, 50), pdl(0, 50), {Color => 'RED'}; my $px = pdl(20, 40, 40, 20, 20); my $py = pdl(80, 80, 100, 100, 80); poly $px, $py, {Fill => 3}; poly $px, $py, {Color=>'Red', Fill => 3, Hatch => {Phase => 0.5}}; label_axes('X-direction', 'Y-direction', 'Title', {Color => 'Yellow'}); text 'Towards the centre', 24, 25, {Justification => 0.5, Angle=>45, Font => 'Italic'}; next_plot(); function_to_do('imag(), ctab(), hi2d and several panels'); $win1= dev('/xw', 2, 2, {Aspect => 0.5, CharSize => 2}); imag $im, {Transform => pdl([0, 0.1, 0, 0, 0, 0.1])}; imag1 $im, {PIX => 1, ITF=>'Sqrt'}; ctab('Fire'); imag $im; hold; cont $im, {Color => 'Yellow'}; release; hi2d $im->slice('0:-1:10,0:-1:10'); next_plot(); function_to_do('Several plot windows. focus_window(), window_list()'); close_window($win1); $win1 = dev('/xw', {Aspect => 1, AxisColour => 'Blue', WindowName => 'First', WindowWidth => 6}); my $win2 = dev('/xw', {Aspect => 0.618, AxisColour => 'Red', WindowWidth => 6, NewWindow => 1}); focus_window('First'); line $x, $x**2; hold; focus_window($win2); my $ii = which($x>=0); points $x->index($ii), sqrt($x->index($ii)); hold; line $x->index($ii), sqrt($x->index($ii)), {Color => 'Red', Linestyle => 'dashed'}; release; focus_window($win1); points $x, $x**2+$x->grandom(); release; my ($nums, $names)=window_list(); print "Window list:\n"; for (my $i=0; $i <= $#$nums; $i++) { print " $$nums[$i]: $$names[$i]\n"; } next_plot(); function_to_do('legend(), cursor()'); close_window($win2); legend ['Parabola', 'Scatter points'], -2, 20, {Width => 5, LineStyle => ['Solid', undef], Symbol => [undef, 'Default']}; print "Select a point using the cursor:\n"; my ($xp, $yp)=cursor({Type => 'CrossHair'}); print "(X, Y)=($xp, $yp)\n"; next_plot(); function_to_do('circle(), ellipse(), rectangle() and arrow()'); dev('/xs', {Aspect => 1, WindowWidth => 6}); env(0, 100, 0,100); circle(50, 50, 10, {Fill => 'Outline'}); ellipse(40, 20, {MajorAxis => 30, MinorAxis=> 10, Theta => 30*3.14/180, Colour => 'Red'}); rectangle(70, 70, {XSide => 10, Angle => 45*3.14/180}); next_plot(); close_window($win1); $win1 = dev('/xw', 2, 2, {Aspect => 1}); line $x, $y; bin $xc, $yc, {Panel => 3}; env(0, 1, 0, 1, {Axis => 'Box'}); text "That's all folks!", 0.5, 0.5, {Justification => 0.5, CharSize => 3, Color => 'Yellow'}; next_plot(); sub function_to_do { print "\n**************************\n"; print "* $_[0]\n"; print "**************************\n\n"; } sub next_plot { my $message = shift; $message ||=''; print $message."\n"; my $in = <STDIN>; if ($in =~ /^q/i) { exit; } } �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Simplex/��������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013377� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/Simplex/tsimp2.pl�����������������������������������������������������������������0000644�0601750�0601001�00000003721�12562522364�015175� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use PDL; use PDL::Opt::Simplex; # # Simplex Demo - Alison Offer (aro@aaocbn.aao.gov.au) # # # this is some sort of convergence criterion $minsize = 1.e-6; # max number of iterations ? $maxiter = 100; # # number of evaluation $count = 0; print " \n 1: least squares gaussian fit to data + noise \n 32 *exp (-((x-10)/6)^2) + noise 2: minimise polynomial \n (x-3)^2 + 2.*(x-3)*(y-2.5) + 3.*(y-2.5)^2 \n Please make your choice (1 or 2):"; chop($choice = <>); if ($choice == 1) { print "Please enter noise factor (small number, 0-6):"; chop($factor = <>); # # data : gaussian + noise # foreach $j (0..19) { $data[$j] = 32*exp(-(($j-10)/6)**2) + $factor * (rand() - 0.5); } # # initial guess - $initsize controls the size of the initial simplex (I think) # $init = pdl [ 33, 9, 12 ]; $initsize = 2; # # ($optimum,$ssize,$optval) = simplex($init,$initsize,$minsize,$maxiter, # this sub returns the function to be minimised. sub {my ($xv) =@_; my $a = $xv->slice("(0)"); my $b = $xv->slice("(1)"); my $c = $xv->slice("(2)"); $count += $a->dim(0); my $sum = $a * 0.0; foreach $j (0..19) { $sum += ($data[$j] - $a*exp(-(($j-$b)/$c)**2))**2; } return $sum; }); } else { $init = pdl [ 2 , 2 ]; $initsize = 2; ($optimum,$ssize,$optval) = simplex($init,$initsize,$minsize,$maxiter, sub {my ($xv) =@_; my $x = $xv->slice("(0)"); my $y = $xv->slice("(1)"); $count += $x->dim(0); return ($x-3)**2 + 2.*($x-3)*($y-2.5) + 3.*($y-2.5)**2; }); } print "N_EVAL = $count\n"; print "OPTIMUM = $optimum \n"; print "SSIZE = $ssize\n"; print "OPTVAL = $optval\n"; �����������������������������������������������PDL-2.018/Example/Simplex/tsimp_needs_pgplot.pl�����������������������������������������������������0000644�0601750�0601001�00000001345�12562522364�017656� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#use blib; use PDL; use PDL::Primitive; use PDL::Graphics::PGPLOT; use PDL::Opt::Simplex; use Carp; $SIG{__DIE__} = sub {print Carp::longmess(@_); die FOO}; # First, a 1-dimensional test: sub func1 { my($x) = @_; return ($x**2)->slice('(0)'); } sub logs1 { print "NOW: $_[0],$_[1]\n\n"; } simplex(ones(1)*10,0.3,0.01,15,\&func1,\&logs1); # Try a simple ellipsoid: my $mult = pdl 4,1; dev "/XSERVE"; env -15,5,-15,5; hold; sub func { my($x) = @_; my $b = ($mult * $x) ** 2; sumover($b,(my $res = null)); $res; } sub logs { print "NOW: $_[0],$_[1]\n\n"; line($_[0]->slice("(0)"),$_[0]->slice("(1)")); line($_[0]->slice("(0),0:2:2"),$_[0]->slice("(1),0:2:2")); } simplex(pdl(-10,-10), 0.5, 0.01, 30, \&func, \&logs ); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/TriD/�����������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402045�012617� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/TriD/3dtest.pl��������������������������������������������������������������������0000644�0601750�0601001�00000000533�12562522364�014404� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl # # This program is a simple diagnostic example to # check if TriD imagrgb is working # use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; # $PDL::debug_trid=1; # $PDL::Graphics::TriD::verbose = 100; $im = sequence(640,480)/640.0/480.0; $im3 = $im->dummy(0,3); # print "\$im3 has dims of @{[$im3->dims()]}\n"; imagrgb $im3; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/TriD/line3d.pl��������������������������������������������������������������������0000644�0601750�0601001�00000000600�12562522364�014347� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl # # This program is a simple diagnostic example to # check if TriD line3d is working # use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; # $PDL::debug_trid=1; # $PDL::Graphics::TriD::verbose = 100; $size = 25; $cz = (xvals zeroes $size+1) / $size; # interval 0..1 $cx = sin($cz*12.6); # Corkscrew $cy = cos($cz*12.6); line3d [$cx,$cy,$cz]; # Draw a line ��������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Example/TriD/old_trid_clip.pl�������������������������������������������������������������0000644�0601750�0601001�00000005616�12562522364�016014� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/local/bin/perl # # This is an example program from the legacy TriD/OpenGL/examples # directory moved here for reference. It only uses OpenGL features # so can probably be deprecated in favor of the Perl OpenGL # examples eventually. # # clip # # This program demonstrates arbitrary clipping planes. # Based on the "clip.c" program in the # OpenGL Programming Guide, Chapter 3, page 108, Listing 3-5. # However this program clips the front part of a rotating cube # with flat shaded faces instead of a wire frame sphere. # # the C synopsis of glClipPlane is # # void glClipPlane(GLenum plane,const GLdouble *equation ) # # For PERL the routine glpClipPlane was added, and the synopsis is: # # void glpClipPlane(GLenum plane,GLdouble a,GLdouble b,GLdouble c,GLdouble d) # # and the 4 double vector (equasion) is packaged by the XSUB. # Or you can still use glClipPlane but then you have to pack() the structure # # note: the statement f(@a) is equivalent to f($a[0],$a[1], ... $a[n]) # i.e. elements of a list are put on the call stack # use PDL::Graphics::OpenGL::Perl::OpenGL; use OpenGL qw(:all); sub tacky_cube { local($s) = @_; local(@x,@y,@z,@f); local($i,$j,$k); local(@r,@g,@b); $s = $s/2.0; @x=(-$s,-$s,-$s,-$s,$s,$s,$s,$s); @y=(-$s,-$s,$s,$s,-$s,-$s,$s,$s); @z=(-$s,$s,$s,-$s,-$s,$s,$s,-$s); @f=( 0, 1, 2, 3, 3, 2, 6, 7, 7, 6, 5, 4, 4, 5, 1, 0, 5, 6, 2, 1, 7, 4, 0, 3, ); @r=(1.0, 0, 0, 1.0, 1.0, 0); @g=(0, 1.0, 0, 1.0, 0, 1.0); @b=(0, 0, 1.0, 0, 1.0, 1.0); for($i=0;$i<6;$i++){ glColor3f($r[$i],$g[$i],$b[$i]); glBegin(GL_POLYGON); for($j=0;$j<4;$j++){ $k=$f[$i*4+$j]; glVertex3d($x[$k],$y[$k],$z[$k]); } glEnd(); } } sub add_clip_plane { # give the plane a slight tilt-away to prove we're not just # clipping against the view volume @eqn = (0.0, -0.3, -1.0, 1.2); OpenGL::glpClipPlane(GL_CLIP_PLANE0, @eqn); glEnable(GL_CLIP_PLANE0); } sub display{ glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); glPushMatrix(); glRotatef($spin, 0.0, 1.0, 0.0); tacky_cube(3.0); glPopMatrix(); glFlush(); glXSwapBuffers; } sub myReshape { # glViewport(0, 0, w, h); glMatrixMode(GL_PROJECTION); glLoadIdentity(); gluPerspective(60.0, 1.0 , 1.0, 20.0); glMatrixMode(GL_MODELVIEW); glLoadIdentity (); } OpenGL::glpOpenWindow(width => 400, height => 400, attributes => [GLX_RGBA,GLX_DOUBLEBUFFER]); glClearColor(0,0,0,1); glShadeModel (GL_FLAT); myReshape(); glDisable(GL_CULL_FACE); glEnable(GL_DEPTH_TEST); glLoadIdentity (); glTranslatef (0.0, 0.0, -5.0); add_clip_plane; # test glGetClipPlane() ($a,$b,$c,$d)=OpenGL::glpGetClipPlane(GL_CLIP_PLANE0); print "Clipping plane (a,b,c,d) = ($a,$b,$c,$d)\n"; $spin=0; while(1) {$spin += 1.0; display;} ������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/��������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402051�011655� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/����������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402067�012303� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Bad.pm����������������������������������������������������������������������0000644�0601750�0601001�00000042377�13110402053�013337� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Bad; @EXPORT_OK = qw( badflag check_badflag badvalue orig_badvalue nbad nbadover ngood ngoodover setbadat PDL::PP isbad PDL::PP isgood PDL::PP nbadover PDL::PP ngoodover PDL::PP setbadif PDL::PP setvaltobad PDL::PP setnantobad PDL::PP setbadtonan PDL::PP setbadtoval PDL::PP copybad ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Bad ; =head1 NAME PDL::Bad - PDL does process bad values =head1 DESCRIPTION PDL has been compiled with WITH_BADVAL set to 1. Therefore, you can enter the wonderful world of bad value support in PDL. This module is loaded when you do C<use PDL>, C<Use PDL::Lite> or C<PDL::LiteF>. Implementation details are given in L<PDL::BadValues>. =head1 SYNOPSIS use PDL::Bad; print "\nBad value support in PDL is turned " . $PDL::Bad::Status ? "on" : "off" . ".\n"; Bad value support in PDL is turned on. and some other things =head1 VARIABLES There are currently three variables that this module defines which may be of use. =over 4 =item $PDL::Bad::Status Set to 1 =item $PDL::Bad::UseNaN Set to 1 if PDL was compiled with C<BADVAL_USENAN> set, 0 otherwise. =item $PDL::Bad::PerPdl Set to 1 if PDL was compiled with the I<experimental> C<BADVAL_PER_PDL> option set, 0 otherwise. =back =cut =head1 FUNCTIONS =cut # really should be constants $PDL::Bad::Status = 1; $PDL::Bad::UseNaN = 0; $PDL::Bad::PerPdl = 0; use strict; use PDL::Types; use PDL::Primitive; ############################################################ ############################################################ ############################################################ ############################################################ *badflag = \&PDL::badflag; *badvalue = \&PDL::badvalue; *orig_badvalue = \&PDL::orig_badvalue; ############################################################ ############################################################ =head2 badflag =for ref getter/setter for the bad data flag =for example if ( $a->badflag() ) { print "Data may contain bad values.\n"; } $a->badflag(1); # set bad data flag $a->badflag(0); # unset bad data flag When called as a setter, this modifies the piddle on which it is called. This always returns a Perl scalar with the final value of the bad flag. A return value of 1 does not guarantee the presence of bad data in a piddle; all it does is say that we need to I<check> for the presence of such beasties. To actually find out if there are any bad values present in a piddle, use the L<check_badflag|/check_badflag> method. =for bad This function works with piddles that have bad values. It always returns a Perl scalar, so it never returns bad values. =head2 badvalue =for ref returns the value used to indicate a missing (or bad) element for the given piddle type. You can give it a piddle, a PDL::Type object, or one of C<$PDL_B>, C<$PDL_S>, etc. =for example $badval = badvalue( float ); $a = ones(ushort,10); print "The bad data value for ushort is: ", $a->badvalue(), "\n"; This can act as a setter (e.g. C<< $a->badvalue(23) >>) if the data type is an integer or C<$PDL::Bad::UseNaN == 0>. Note that this B<never touches the data in the piddle>. That is, if C<$a> already has bad values, they will not be changed to use the given number and if any elements of C<$a> have that value, they will unceremoniously be marked as bad data. See L</setvaltobad>, L</setbadtoval>, and L</setbadif> for ways to actually modify the data in piddles If the C<$PDL::Bad::PerPdl> flag is set then it is possible to change the bad value on a per-piddle basis, so $a = sequence (10); $a->badvalue (3); $a->badflag (1); $b = sequence (10); $b->badvalue (4); $b->badflag (1); will set $a to be C<[0 1 2 BAD 4 5 6 7 8 9]> and $b to be C<[0 1 2 3 BAD 5 6 7 8 9]>. If the flag is not set then both $a and $b will be set to C<[0 1 2 3 BAD 5 6 7 8 9]>. Please note that the code to support per-piddle bad values is I<experimental> in the current release, and it requires that you modify the settings under which PDL is compiled. =for bad This method does not care if you call it on an input piddle that has bad values. It always returns a Perl scalar with the current or new bad value. =head2 orig_badvalue =for ref returns the original value used to represent bad values for a given type. This routine operates the same as L<badvalue|/badvalue>, except you can not change the values. It also has an I<awful> name. =for example $orig_badval = orig_badvalue( float ); $a = ones(ushort,10); print "The original bad data value for ushort is: ", $a->orig_badvalue(), "\n"; =for bad This method does not care if you call it on an input piddle that has bad values. It always returns a Perl scalar with the original bad value for the associated type. =head2 check_badflag =for ref Clear the bad-value flag of a piddle if it does not contain any bad values Given a piddle whose bad flag is set, check whether it actually contains any bad values and, if not, clear the flag. It returns the final state of the bad-value flag. =for example print "State of bad flag == ", $pdl->check_badflag; =for bad This method accepts piddles with or without bad values. It returns a Perl scalar with the final bad-value flag, so it never returns bad values itself. =cut *check_badflag = \&PDL::check_badflag; sub PDL::check_badflag { my $pdl = shift; $pdl->badflag(0) if $pdl->badflag and $pdl->nbad == 0; return $pdl->badflag; } # sub: check_badflag() # note: # if sent a piddle, we have to change it's bad values # (but only if it contains bad values) # - there's a slight overhead in that the badflag is # cleared and then set (hence propagating to all # children) but we'll ignore that) # - we can ignore this for float/double types # since we can't change the bad value # sub PDL::badvalue { no strict 'refs'; my ( $self, $val ) = @_; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; if ( $num < $PDL_F && defined($val) && $self->badflag ) { $self->inplace->setbadtoval( $val ); $self->badflag(1); } if ($PDL::Config{BADVAL_PER_PDL}) { my $name = "PDL::_badvalue_per_pdl_int$num"; if ( defined $val ) { return &{$name}($self, $val )->sclr; } else { return &{$name}($self, undef)->sclr; } } } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } my $name = "PDL::_badvalue_int$num"; if ( defined $val ) { return &{$name}( $val )->sclr; } else { return &{$name}( undef )->sclr; } } # sub: badvalue() sub PDL::orig_badvalue { no strict 'refs'; my $self = shift; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } my $name = "PDL::_default_badvalue_int$num"; return &${name}(); } # sub: orig_badvalue() ############################################################ ############################################################ =head2 isbad =for sig Signature: (a(); int [o]b()) =for ref Returns a binary mask indicating which values of the input are bad values Returns a 1 if the value is bad, 0 otherwise. Similar to L<isfinite|PDL::Math/isfinite>. =for example $a = pdl(1,2,3); $a->badflag(1); set($a,1,$a->badvalue); $b = isbad($a); print $b, "\n"; [0 1 0] =for bad This method works with input piddles that are bad. The output piddle will never contain bad values, but its bad value flag will be the same as the input piddle's flag. =cut *isbad = \&PDL::isbad; =head2 isgood =for sig Signature: (a(); int [o]b()) =for ref Is a value good? Returns a 1 if the value is good, 0 otherwise. Also see L<isfinite|PDL::Math/isfinite>. =for example $a = pdl(1,2,3); $a->badflag(1); set($a,1,$a->badvalue); $b = isgood($a); print $b, "\n"; [1 0 1] =for bad This method works with input piddles that are bad. The output piddle will never contain bad values, but its bad value flag will be the same as the input piddle's flag. =cut *isgood = \&PDL::isgood; =head2 nbadover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of bad elements along the 1st dimension. This function reduces the dimensionality of a piddle by one by finding the number of bad elements along the 1st dimension. In this sense it shares much in common with the functions defined in L<PDL::Ufunc>. In particular, by using L<xchg|PDL::Slices/xchg> and similar dimension rearranging methods, it is possible to perform this calculation over I<any> dimension. =for usage $a = nbadover($b); =for example $spectrum = nbadover $image->xchg(0,1) =for bad nbadover processes input values that are bad. The output piddle will not have any bad values, but the bad flag will be set if the input piddle had its bad flag set. =cut *nbadover = \&PDL::nbadover; =head2 ngoodover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of good elements along the 1st dimension. This function reduces the dimensionality of a piddle by one by finding the number of good elements along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $a = ngoodover($b); =for example $spectrum = ngoodover $image->xchg(0,1) =for bad ngoodover processes input values that are bad. The output piddle will not have any bad values, but the bad flag will be set if the input piddle had its bad flag set. =cut *ngoodover = \&PDL::ngoodover; *nbad = \&PDL::nbad; sub PDL::nbad { my($x) = @_; my $tmp; $x->clump(-1)->nbadover($tmp=PDL->nullcreate($x) ); return $tmp->at(); } *ngood = \&PDL::ngood; sub PDL::ngood { my($x) = @_; my $tmp; $x->clump(-1)->ngoodover($tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 nbad =for ref Returns the number of bad values in a piddle =for usage $x = nbad($data); =for bad Accepts good and bad input piddles; output is a Perl scalar and therefore is always good. =head2 ngood =for ref Returns the number of good values in a piddle =for usage $x = ngood($data); =for bad Accepts good and bad input piddles; output is a Perl scalar and therefore is always good. =head2 setbadat =for ref Set the value to bad at a given position. =for usage setbadat $piddle, @position C<@position> is a coordinate list, of size equal to the number of dimensions in the piddle. This is a wrapper around L<set|PDL::Core/set> and is probably mainly useful in test scripts! =for example pdl> $x = sequence 3,4 pdl> $x->setbadat 2,1 pdl> p $x [ [ 0 1 2] [ 3 4 BAD] [ 6 7 8] [ 9 10 11] ] =for bad This method can be called on piddles that have bad values. The remainder of the arguments should be Perl scalars indicating the position to set as bad. The output piddle will have bad values and will have its badflag turned on. =cut *setbadat = \&PDL::setbadat; sub PDL::setbadat { barf 'Usage: setbadat($pdl, $x, $y, ...)' if $#_<1; my $self = shift; PDL::Core::set_c ($self, [@_], $self->badvalue); $self->badflag(1); return $self; } =head2 setbadif =for sig Signature: (a(); int mask(); [o]b()) =for ref Set elements bad based on the supplied mask, otherwise copy across the data. =for example pdl> $a = sequence(5,5) pdl> $a = $a->setbadif( $a % 2 ) pdl> p "a badflag: ", $a->badflag, "\n" a badflag: 1 pdl> p "a is\n$a" [ [ 0 BAD 2 BAD 4] [BAD 6 BAD 8 BAD] [ 10 BAD 12 BAD 14] [BAD 16 BAD 18 BAD] [ 20 BAD 22 BAD 24] ] Unfortunately, this routine can I<not> be run inplace, since the current implementation can not handle the same piddle used as C<a> and C<mask> (eg C<< $a->inplace->setbadif($a%2) >> fails). Even more unfortunate: we can't catch this error and tell you. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L<check_badflag|/check_badflag> to check whether there are any bad values in the output). The input piddle can have bad values: any bad values in the input piddles are copied across to the output piddle. Also see L<setvaltobad|/setvaltobad> and L<setnantobad|/setnantobad>. =cut *setbadif = \&PDL::setbadif; =head2 setvaltobad =for sig Signature: (a(); [o]b(); double value) =for ref Set bad all those elements which equal the supplied value. =for example $a = sequence(10) % 3; $a->inplace->setvaltobad( 0 ); print "$a\n"; [BAD 1 2 BAD 1 2 BAD 1 2 BAD] This is a simpler version of L<setbadif|/setbadif>, but this function can be done inplace. See L<setnantobad|/setnantobad> if you want to convert NaN/Inf to the bad value. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L<check_badflag|/check_badflag> to check whether there are any bad values in the output). Any bad values in the input piddles are copied across to the output piddle. =cut *setvaltobad = \&PDL::setvaltobad; =head2 setnantobad =for sig Signature: (a(); [o]b()) =for ref Sets NaN/Inf values in the input piddle bad (only relevant for floating-point piddles). Can be done inplace. =for usage $b = $a->setnantobad; $a->inplace->setnantobad; =for bad This method can process piddles with bad values: those bad values are propagated into the output piddle. Any value that is not finite is also set to bad in the output piddle. If all values from the input piddle are good and finite, the output piddle will B<not> have its bad flag set. One more caveat: if done inplace, and if the input piddle's bad flag is set, it will no =cut *setnantobad = \&PDL::setnantobad; =head2 setbadtonan =for sig Signature: (a(); [o] b();) =for ref Sets Bad values to NaN This is only relevant for floating-point piddles. The input piddle can be of any type, but if done inplace, the input must be floating point. =for usage $b = $a->setbadtonan; $a->inplace->setbadtonan; =for bad This method processes input piddles with bad values. The output piddles will not contain bad values (insofar as NaN is not Bad as far as PDL is concerned) and the output piddle does not have its bad flag set. As an inplace operation, it clears the bad flag. =cut *setbadtonan = \&PDL::setbadtonan; =head2 setbadtoval =for sig Signature: (a(); [o]b(); double newval) =for ref Replace any bad values by a (non-bad) value. Can be done inplace. Also see L<badmask|PDL::Math/badmask>. =for example $a->inplace->setbadtoval(23); print "a badflag: ", $a->badflag, "\n"; a badflag: 0 =for bad The output always has its bad flag cleared. If the input piddle does not have its bad flag set, then values are copied with no replacement. =cut *setbadtoval = \&PDL::setbadtoval; =head2 copybad =for sig Signature: (a(); mask(); [o]b()) =for ref Copies values from one piddle to another, setting them bad if they are bad in the supplied mask. Can be done inplace. =for example $a = byte( [0,1,3] ); $mask = byte( [0,0,0] ); set($mask,1,$mask->badvalue); $a->inplace->copybad( $mask ); p $a; [0 BAD 3] It is equivalent to: $c = $a + $mask * 0 =for bad This handles input piddles that are bad. If either C<$a> or C<$mask> have bad values, those values will be marked as bad in the output piddle and the output piddle will have its bad value flag set to true. =cut *copybad = \&PDL::copybad; ; =head1 CHANGES The I<experimental> C<BADVAL_PER_PDL> configuration option, which - when set - allows per-piddle bad values, was added after the 2.4.2 release of PDL. The C<$PDL::Bad::PerPdl> variable can be inspected to see if this feature is available. =head1 CONFIGURATION The way the PDL handles the various bad value settings depends on your compile-time configuration settings, as held in C<perldl.conf>. =over =item C<$PDL::Config{WITH_BADVAL}> Set this configuration option to a true value if you want bad value support. The default setting is for this to be true. =item C<$PDL::Config{BADVAL_USENAN}> Set this configuration option to a true value if you want floating-pont numbers to use NaN to represent the bad value. If set to false, you can use any number to represent a bad value, which is generally more flexible. In the default configuration, this is set to a false value. =item C<$PDL::Config{BADVAL_PER_PDL}> Set this configuration option to a true value if you want each of your piddles to keep track of their own bad values. This means that for one piddle you can set the bad value to zero, while in another piddle you can set the bad value to NaN (or any other useful number). This is usually set to false. =back =head1 AUTHOR Doug Burke (djburke@cpan.org), 2000, 2001, 2003, 2006. The per-piddle bad value support is by Heiko Klein (2006). CPAN documentation fixes by David Mertens (2010, 2013). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Complex.pm������������������������������������������������������������������0000644�0601750�0601001�00000073504�13110402055�014256� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Complex; @EXPORT_OK = qw( Ctan Catan re im i cplx real PDL::PP r2C PDL::PP i2C PDL::PP Cr2p PDL::PP Cp2r PDL::PP Cadd PDL::PP Csub PDL::PP Cmul PDL::PP Cprodover PDL::PP Cscale PDL::PP Cdiv PDL::PP Ccmp PDL::PP Cconj PDL::PP Cabs PDL::PP Cabs2 PDL::PP Carg PDL::PP Csin PDL::PP Ccos PDL::PP Cexp PDL::PP Clog PDL::PP Cpow PDL::PP Csqrt PDL::PP Casin PDL::PP Cacos PDL::PP Csinh PDL::PP Ccosh PDL::PP Ctanh PDL::PP Casinh PDL::PP Cacosh PDL::PP Catanh PDL::PP Cproj PDL::PP Croots PDL::PP rCpolynomial ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; BEGIN { @ISA = ( 'PDL::Exporter','DynaLoader','PDL' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Complex ; } our $VERSION = '2.009'; use PDL::Slices; use PDL::Types; use PDL::Bad; use vars qw($sep $sep2); =encoding iso-8859-1 =head1 NAME PDL::Complex - handle complex numbers =head1 SYNOPSIS use PDL; use PDL::Complex; =head1 DESCRIPTION This module features a growing number of functions manipulating complex numbers. These are usually represented as a pair C<[ real imag ]> or C<[ angle phase ]>. If not explicitly mentioned, the functions can work inplace (not yet implemented!!!) and require rectangular form. While there is a procedural interface available (C<< $a/$b*$c <=> Cmul (Cdiv $a, $b), $c) >>), you can also opt to cast your pdl's into the C<PDL::Complex> datatype, which works just like your normal piddles, but with all the normal perl operators overloaded. The latter means that C<sin($a) + $b/$c> will be evaluated using the normal rules of complex numbers, while other pdl functions (like C<max>) just treat the piddle as a real-valued piddle with a lowest dimension of size 2, so C<max> will return the maximum of all real and imaginary parts, not the "highest" (for some definition) =head1 TIPS, TRICKS & CAVEATS =over 4 =item * C<i> is a constant exported by this module, which represents C<-1**0.5>, i.e. the imaginary unit. it can be used to quickly and conveniently write complex constants like this: C<4+3*i>. =item * Use C<r2C(real-values)> to convert from real to complex, as in C<$r = Cpow $cplx, r2C 2>. The overloaded operators automatically do that for you, all the other functions, do not. So C<Croots 1, 5> will return all the fifths roots of 1+1*i (due to threading). =item * use C<cplx(real-valued-piddle)> to cast from normal piddles into the complex datatype. Use C<real(complex-valued-piddle)> to cast back. This requires a copy, though. =item * This module has received some testing by Vanuxem Grégory (g.vanuxem at wanadoo dot fr). Please report any other errors you come across! =back =head1 EXAMPLE WALK-THROUGH The complex constant five is equal to C<pdl(1,0)>: pdl> p $x = r2C 5 5 +0i Now calculate the three cubic roots of of five: pdl> p $r = Croots $x, 3 [1.70998 +0i -0.854988 +1.48088i -0.854988 -1.48088i] Check that these really are the roots: pdl> p $r ** 3 [5 +0i 5 -1.22465e-15i 5 -7.65714e-15i] Duh! Could be better. Now try by multiplying C<$r> three times with itself: pdl> p $r*$r*$r [5 +0i 5 -4.72647e-15i 5 -7.53694e-15i] Well... maybe C<Cpow> (which is used by the C<**> operator) isn't as bad as I thought. Now multiply by C<i> and negate, which is just a very expensive way of swapping real and imaginary parts. pdl> p -($r*i) [0 -1.70998i 1.48088 +0.854988i -1.48088 +0.854988i] Now plot the magnitude of (part of) the complex sine. First generate the coefficients: pdl> $sin = i * zeroes(50)->xlinvals(2,4) + zeroes(50)->xlinvals(0,7) Now plot the imaginary part, the real part and the magnitude of the sine into the same diagram: pdl> use PDL::Graphics::Gnuplot pdl> gplot( with => 'lines', PDL::cat(im ( sin $sin ), re ( sin $sin ), abs( sin $sin ) )) An ASCII version of this plot looks like this: 30 ++-----+------+------+------+------+------+------+------+------+-----++ + + + + + + + + + + + | $$| | $ | 25 ++ $$ ++ | *** | | ** *** | | $$* *| 20 ++ $** ++ | $$$* #| | $$$ * # | | $$ * # | 15 ++ $$$ * # ++ | $$$ ** # | | $$$$ * # | | $$$$ * # | 10 ++ $$$$$ * # ++ | $$$$$ * # | | $$$$$$$ * # | 5 ++ $$$############ * # ++ |*****$$$### ### * # | * #***** # * # | | ### *** ### ** # | 0 ## *** # * # ++ | * # * # | | *** # ** # | | * # * # | -5 ++ ** # * # ++ | *** ## ** # | | * #* # | | **** ***## # | -10 ++ **** # # ++ | # # | | ## ## | + + + + + + + ### + ### + + + -15 ++-----+------+------+------+------+------+-----###-----+------+-----++ 0 5 10 15 20 25 30 35 40 45 50 =cut my $i; BEGIN { $i = bless pdl 0,1 } sub i () { $i->copy }; =head1 FUNCTIONS =cut =head2 cplx real-valued-pdl Cast a real-valued piddle to the complex datatype. The first dimension of the piddle must be of size 2. After this the usual (complex) arithmetic operators are applied to this pdl, rather than the normal elementwise pdl operators. Dataflow to the complex parent works. Use C<sever> on the result if you don't want this. =head2 complex real-valued-pdl Cast a real-valued piddle to the complex datatype I<without> dataflow and I<inplace>. Achieved by merely reblessing a piddle. The first dimension of the piddle must be of size 2. =head2 real cplx-valued-pdl Cast a complex valued pdl back to the "normal" pdl datatype. Afterwards the normal elementwise pdl operators are used in operations. Dataflow to the real parent works. Use C<sever> on the result if you don't want this. =cut use Carp; sub cplx($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP if just piddle croak "first dimsize must be 2" unless $_[0]->dims > 0 && $_[0]->dim(0) == 2; bless $_[0]->slice(''); } sub complex($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP if just piddle croak "first dimsize must be 2" unless $_[0]->dims > 0 && $_[0]->dim(0) == 2; bless $_[0]; } *PDL::cplx = \&cplx; *PDL::complex = \&complex; sub real($) { return $_[0] unless UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP unless complex bless $_[0]->slice(''), 'PDL'; } =head2 r2C =for sig Signature: (r(); [o]c(m=2)) =for ref convert real to complex, assuming an imaginary part of zero =for bad r2C does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *PDL::r2C = \&PDL::Complex::r2C; sub PDL::Complex::r2C($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); my $r = __PACKAGE__->initialize; &PDL::Complex::_r2C_int($_[0], $r); $r } BEGIN {*r2C = \&PDL::Complex::r2C; } =head2 i2C =for sig Signature: (r(); [o]c(m=2)) =for ref convert imaginary to complex, assuming a real part of zero =for bad i2C does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *PDL::i2C = \&PDL::Complex::i2C; sub PDL::Complex::i2C($) { my $r = __PACKAGE__->initialize; &PDL::Complex::_i2C_int($_[0], $r); $r } BEGIN {*i2C = \&PDL::Complex::i2C; } =head2 Cr2p =for sig Signature: (r(m=2); float+ [o]p(m=2)) =for ref convert complex numbers in rectangular form to polar (mod,arg) form. Works inplace =for bad Cr2p does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cr2p = \&PDL::Complex::Cr2p; } =head2 Cp2r =for sig Signature: (r(m=2); [o]p(m=2)) =for ref convert complex numbers in polar (mod,arg) form to rectangular form. Works inplace =for bad Cp2r does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cp2r = \&PDL::Complex::Cp2r; } BEGIN {*Cadd = \&PDL::Complex::Cadd; } BEGIN {*Csub = \&PDL::Complex::Csub; } =head2 Cmul =for sig Signature: (a(m=2); b(m=2); [o]c(m=2)) =for ref complex multiplication =for bad Cmul does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cmul = \&PDL::Complex::Cmul; } =head2 Cprodover =for sig Signature: (a(m=2,n); [o]c(m=2)) =for ref Project via product to N-1 dimension =for bad Cprodover does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cprodover = \&PDL::Complex::Cprodover; } =head2 Cscale =for sig Signature: (a(m=2); b(); [o]c(m=2)) =for ref mixed complex/real multiplication =for bad Cscale does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cscale = \&PDL::Complex::Cscale; } =head2 Cdiv =for sig Signature: (a(m=2); b(m=2); [o]c(m=2)) =for ref complex division =for bad Cdiv does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cdiv = \&PDL::Complex::Cdiv; } =head2 Ccmp =for sig Signature: (a(m=2); b(m=2); [o]c()) =for ref Complex comparison oeprator (spaceship). It orders by real first, then by imaginary. Hm, but it is mathematical nonsense! Complex numbers cannot be ordered. =for bad Ccmp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Ccmp = \&PDL::Complex::Ccmp; } =head2 Cconj =for sig Signature: (a(m=2); [o]c(m=2)) =for ref complex conjugation. Works inplace =for bad Cconj does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cconj = \&PDL::Complex::Cconj; } =head2 Cabs =for sig Signature: (a(m=2); [o]c()) =for ref complex C<abs()> (also known as I<modulus>) =for bad Cabs does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::Complex::Cabs($) { my $pdl= shift; my $abs = PDL->null; &PDL::Complex::_Cabs_int($pdl, $abs); $abs; } BEGIN {*Cabs = \&PDL::Complex::Cabs; } =head2 Cabs2 =for sig Signature: (a(m=2); [o]c()) =for ref complex squared C<abs()> (also known I<squared modulus>) =for bad Cabs2 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::Complex::Cabs2($) { my $pdl= shift; my $abs2 = PDL->null; &PDL::Complex::_Cabs2_int($pdl, $abs2); $abs2; } BEGIN {*Cabs2 = \&PDL::Complex::Cabs2; } =head2 Carg =for sig Signature: (a(m=2); [o]c()) =for ref complex argument function ("angle") =for bad Carg does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::Complex::Carg($) { my $pdl= shift; my $arg = PDL->null; &PDL::Complex::_Carg_int($pdl, $arg); $arg; } BEGIN {*Carg = \&PDL::Complex::Carg; } =head2 Csin =for sig Signature: (a(m=2); [o]c(m=2)) =for ref sin (a) = 1/(2*i) * (exp (a*i) - exp (-a*i)). Works inplace =for bad Csin does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Csin = \&PDL::Complex::Csin; } =head2 Ccos =for sig Signature: (a(m=2); [o]c(m=2)) =for ref cos (a) = 1/2 * (exp (a*i) + exp (-a*i)). Works inplace =for bad Ccos does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Ccos = \&PDL::Complex::Ccos; } =head2 Ctan a [not inplace] tan (a) = -i * (exp (a*i) - exp (-a*i)) / (exp (a*i) + exp (-a*i)) =cut sub Ctan($) { Csin($_[0]) / Ccos($_[0]) } =head2 Cexp =for sig Signature: (a(m=2); [o]c(m=2)) =for ref exp (a) = exp (real (a)) * (cos (imag (a)) + i * sin (imag (a))). Works inplace =for bad Cexp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cexp = \&PDL::Complex::Cexp; } =head2 Clog =for sig Signature: (a(m=2); [o]c(m=2)) =for ref log (a) = log (cabs (a)) + i * carg (a). Works inplace =for bad Clog does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Clog = \&PDL::Complex::Clog; } =head2 Cpow =for sig Signature: (a(m=2); b(m=2); [o]c(m=2)) =for ref complex C<pow()> (C<**>-operator) =for bad Cpow does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cpow = \&PDL::Complex::Cpow; } =head2 Csqrt =for sig Signature: (a(m=2); [o]c(m=2)) =for ref Works inplace =for bad Csqrt does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Csqrt = \&PDL::Complex::Csqrt; } =head2 Casin =for sig Signature: (a(m=2); [o]c(m=2)) =for ref Works inplace =for bad Casin does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Casin = \&PDL::Complex::Casin; } =head2 Cacos =for sig Signature: (a(m=2); [o]c(m=2)) =for ref Works inplace =for bad Cacos does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cacos = \&PDL::Complex::Cacos; } =head2 Catan cplx [not inplace] Return the complex C<atan()>. =cut sub Catan($) { my $z = shift; Cmul Clog(Cdiv (PDL::Complex::i+$z, PDL::Complex::i-$z)), pdl(0, 0.5); } =head2 Csinh =for sig Signature: (a(m=2); [o]c(m=2)) =for ref sinh (a) = (exp (a) - exp (-a)) / 2. Works inplace =for bad Csinh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Csinh = \&PDL::Complex::Csinh; } =head2 Ccosh =for sig Signature: (a(m=2); [o]c(m=2)) =for ref cosh (a) = (exp (a) + exp (-a)) / 2. Works inplace =for bad Ccosh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Ccosh = \&PDL::Complex::Ccosh; } =head2 Ctanh =for sig Signature: (a(m=2); [o]c(m=2)) =for ref Works inplace =for bad Ctanh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Ctanh = \&PDL::Complex::Ctanh; } =head2 Casinh =for sig Signature: (a(m=2); [o]c(m=2)) =for ref Works inplace =for bad Casinh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Casinh = \&PDL::Complex::Casinh; } =head2 Cacosh =for sig Signature: (a(m=2); [o]c(m=2)) =for ref Works inplace =for bad Cacosh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cacosh = \&PDL::Complex::Cacosh; } =head2 Catanh =for sig Signature: (a(m=2); [o]c(m=2)) =for ref Works inplace =for bad Catanh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Catanh = \&PDL::Complex::Catanh; } =head2 Cproj =for sig Signature: (a(m=2); [o]c(m=2)) =for ref compute the projection of a complex number to the riemann sphere. Works inplace =for bad Cproj does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*Cproj = \&PDL::Complex::Cproj; } =head2 Croots =for sig Signature: (a(m=2); [o]c(m=2,n); int n => n) =for ref Compute the C<n> roots of C<a>. C<n> must be a positive integer. The result will always be a complex type! =for bad Croots does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::Complex::Croots($$) { my ($pdl, $n) = @_; my $r = PDL->null; &PDL::Complex::_Croots_int($pdl, $r, $n); bless $r; } BEGIN {*Croots = \&PDL::Complex::Croots; } =head2 re cplx, im cplx Return the real or imaginary part of the complex number(s) given. These are slicing operators, so data flow works. The real and imaginary parts are returned as piddles (ref eq PDL). =cut sub re($) { bless $_[0]->slice("(0)"), 'PDL'; } sub im($) { bless $_[0]->slice("(1)"), 'PDL'; } *PDL::Complex::re = \&re; *PDL::Complex::im = \&im; =head2 rCpolynomial =for sig Signature: (coeffs(n); x(c=2,m); [o]out(c=2,m)) =for ref evaluate the polynomial with (real) coefficients C<coeffs> at the (complex) position(s) C<x>. C<coeffs[0]> is the constant term. =for bad rCpolynomial does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut BEGIN {*rCpolynomial = \&PDL::Complex::rCpolynomial; } ; # overload must be here, so that all the functions can be seen # undocumented compatibility functions sub Catan2($$) { Catan Cdiv $_[1], $_[0] } sub atan2($$) { Catan Cdiv $_[1], $_[0] } sub _gen_biop { local $_ = shift; my $sub; if (/(\S+)\+(\w+)/) { $sub = eval 'sub { '.$2.' $_[0], ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1] }'; } elsif (/(\S+)\-(\w+)/) { $sub = eval 'sub { my $b = ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1]; $_[2] ? '.$2.' $b, $_[0] : '.$2.' $_[0], $b }'; } else { die; } if($1 eq "atan2" || $1 eq "<=>") { return ($1, $sub) } ($1, $sub, "$1=", $sub); } sub _gen_unop { my ($op, $func) = ($_[0] =~ /(.+)@(\w+)/); *$op = \&$func if $op =~ /\w+/; # create an alias ($op, eval 'sub { '.$func.' $_[0] }'); } sub _gen_cpop { ($_[0], eval 'sub { my $b = ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1]; ($_[2] ? $b <=> $_[0] : $_[0] <=> $b) '.$_[0].' 0 }'); } sub initialize { # Bless a null PDL into the supplied 1st arg package # If 1st arg is a ref, get the package from it bless PDL->null, ref($_[0]) ? ref($_[0]) : $_[0]; } use overload (map _gen_biop($_), qw(++Cadd --Csub *+Cmul /-Cdiv **-Cpow atan2-Catan2 <=>-Ccmp)), (map _gen_unop($_), qw(sin@Csin cos@Ccos exp@Cexp abs@Cabs log@Clog sqrt@Csqrt abs@Cabs)), (map _gen_cpop($_), qw(< <= == != >= >)), '++' => sub { $_[0] += 1 }, '--' => sub { $_[0] -= 1 }, '""' => \&PDL::Complex::string ; # overwrite PDL's overloading to honour subclass methods in + - * / { package PDL; my $warningFlag; # This strange usage of BEGINs is to ensure the # warning messages get disabled and enabled in the # proper order. Without the BEGIN's the 'use overload' # would be called first. BEGIN {$warningFlag = $^W; # Temporarily disable warnings caused by $^W = 0; # redefining PDL's subs } sub cp(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'+'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::plus (@_)} } sub cm(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'*'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::mult (@_)} } sub cmi(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'-'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::minus (@_)} } sub cd(;@) { my $foo; if (ref $_[1] && (ref $_[1] ne 'PDL') && defined ($foo = overload::Method($_[1],'/'))) { &$foo($_[1], $_[0], !$_[2])} else { PDL::divide (@_)} } # Used in overriding standard PDL +, -, *, / ops in the complex subclass. use overload ( '+' => \&cp, '*' => \&cm, '-' => \&cmi, '/' => \&cd, ); BEGIN{ $^W = $warningFlag;} # Put Back Warnings }; { our $floatformat = "%4.4g"; # Default print format for long numbers our $doubleformat = "%6.6g"; $PDL::Complex::_STRINGIZING = 0; sub PDL::Complex::string { my($self,$format1,$format2)=@_; my @dims = $self->dims; return PDL::string($self) if ($dims[0] != 2); if($PDL::Complex::_STRINGIZING) { return "ALREADY_STRINGIZING_NO_LOOPS"; } local $PDL::Complex::_STRINGIZING = 1; my $ndims = $self->getndims; if($self->nelem > $PDL::toolongtoprint) { return "TOO LONG TO PRINT"; } if ($ndims==0){ PDL::Core::string($self,$format1); } return "Null" if $self->isnull; return "Empty" if $self->isempty; # Empty piddle local $sep = $PDL::use_commas ? ", " : " "; local $sep2 = $PDL::use_commas ? ", " : ""; if ($ndims < 3) { return str1D($self,$format1,$format2); } else{ return strND($self,$format1,$format2,0); } } sub sum { my($x) = @_; my $tmp = $x->mv(0,1)->clump(0,2)->mv(1,0)->sumover; return $tmp->squeeze; } sub sumover{ my $m = shift; PDL::Ufunc::sumover($m->xchg(0,1)); } sub strND { my($self,$format1,$format2,$level)=@_; my @dims = $self->dims; if ($#dims==2) { return str2D($self,$format1,$format2,$level); } else { my $secbas = join '',map {":,"} @dims[0..$#dims-1]; my $ret="\n"." "x$level ."["; my $j; for ($j=0; $j<$dims[$#dims]; $j++) { my $sec = $secbas . "($j)"; $ret .= strND($self->slice($sec),$format1,$format2, $level+1); chop $ret; $ret .= $sep2; } chop $ret if $PDL::use_commas; $ret .= "\n" ." "x$level ."]\n"; return $ret; } } # String 1D array in nice format # sub str1D { my($self,$format1,$format2)=@_; barf "Not 1D" if $self->getndims() > 2; my $x = PDL::Core::listref_c($self); my ($ret,$dformat,$t, $i); my $dtype = $self->get_datatype(); $dformat = $PDL::Complex::floatformat if $dtype == $PDL_F; $dformat = $PDL::Complex::doubleformat if $dtype == $PDL_D; $ret = "[" if $self->getndims() > 1; my $badflag = $self->badflag(); for($i=0; $i<=$#$x; $i++){ $t = $$x[$i]; if ( $badflag and $t eq "BAD" ) { # do nothing } elsif ($format1) { $t = sprintf $format1,$t; } else{ # Default if ($dformat && length($t)>7) { # Try smaller $t = sprintf $dformat,$t; } } $ret .= $i % 2 ? $i<$#$x ? $t."i$sep" : $t."i" : substr($$x[$i+1],0,1) eq "-" ? "$t " : $t." +"; } $ret.="]" if $self->getndims() > 1; return $ret; } sub str2D { my($self,$format1,$format2,$level)=@_; my @dims = $self->dims(); barf "Not 2D" if scalar(@dims)!=3; my $x = PDL::Core::listref_c($self); my ($i, $f, $t, $len1, $len2, $ret); my $dtype = $self->get_datatype(); my $badflag = $self->badflag(); my $findmax = 0; if (!defined $format1 || !defined $format2 || $format1 eq '' || $format2 eq '') { $len1= $len2 = 0; if ( $badflag ) { for ($i=0; $i<=$#$x; $i++) { if ( $$x[$i] eq "BAD" ) { $f = 3; } else { $f = length($$x[$i]); } if ($i % 2) { $len2 = $f if $f > $len2; } else { $len1 = $f if $f > $len1; } } } else { for ($i=0; $i<=$#$x; $i++) { $f = length($$x[$i]); if ($i % 2){ $len2 = $f if $f > $len2; } else{ $len1 = $f if $f > $len1; } } } $format1 = '%'.$len1.'s'; $format2 = '%'.$len2.'s'; if ($len1 > 5){ if ($dtype == $PDL_F) { $format1 = $PDL::Complex::floatformat; $findmax = 1; } elsif ($dtype == $PDL_D) { $format1 = $PDL::Complex::doubleformat; $findmax = 1; } else { $findmax = 0; } } if($len2 > 5){ if ($dtype == $PDL_F) { $format2 = $PDL::Complex::floatformat; $findmax = 1; } elsif ($dtype == $PDL_D) { $format2 = $PDL::Complex::doubleformat; $findmax = 1; } else { $findmax = 0 unless $findmax; } } } if($findmax) { $len1 = $len2=0; if ( $badflag ) { for($i=0; $i<=$#$x; $i++){ $findmax = $i % 2; if ( $$x[$i] eq 'BAD' ){ $f = 3; } else{ $f = $findmax ? length(sprintf $format2,$$x[$i]) : length(sprintf $format1,$$x[$i]); } if ($findmax){ $len2 = $f if $f > $len2; } else{ $len1 = $f if $f > $len1; } } } else { for ($i=0; $i<=$#$x; $i++) { if ($i % 2){ $f = length(sprintf $format2,$$x[$i]); $len2 = $f if $f > $len2; } else{ $f = length(sprintf $format1,$$x[$i]); $len1 = $f if $f > $len1; } } } } # if: $findmax $ret = "\n" . ' 'x$level . "[\n"; { my $level = $level+1; $ret .= ' 'x$level .'['; $len2 += 2; for ($i=0; $i<=$#$x; $i++) { $findmax = $i % 2; if ($findmax){ if ( $badflag and $$x[$i] eq 'BAD' ){ #|| #($findmax && $$x[$i - 1 ] eq 'BAD') || #(!$findmax && $$x[$i +1 ] eq 'BAD')){ $f = "BAD"; } else{ $f = sprintf $format2, $$x[$i]; if (substr($$x[$i],0,1) eq '-'){ $f.='i'; } else{ $f =~ s/(\s*)(.*)/+$2i/; } } $t = $len2-length($f); } else{ if ( $badflag and $$x[$i] eq 'BAD' ){ $f = "BAD"; } else{ $f = sprintf $format1, $$x[$i]; $t = $len1-length($f); } } $f = ' 'x$t.$f if $t>0; $ret .= $f; if (($i+1)%($dims[1]*2)) { $ret.=$sep if $findmax; } else{ # End of output line $ret.=']'; if ($i==$#$x) { # very last number $ret.="\n"; } else{ $ret.= $sep2."\n" . ' 'x$level .'['; } } } } $ret .= ' 'x$level."]\n"; return $ret; } } =head1 AUTHOR Copyright (C) 2000 Marc Lehmann <pcg@goof.com>. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. =head1 SEE ALSO perl(1), L<PDL>. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Compression.pm��������������������������������������������������������������0000644�0601750�0601001�00000013561�13110402054�015144� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Compression; @EXPORT_OK = qw( PDL::PP rice_compress PDL::PP rice_expand ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Compression ; =head1 NAME PDL::Compression - compression utilities =head1 DESCRIPTION These routines generally accept some data as a PDL and compress it into a smaller PDL. Algorithms typically work on a single dimension and thread over other dimensions, producing a threaded table of compressed values if more than one dimension is fed in. The Rice algorithm, in particular, is designed to be identical to the RICE_1 algorithm used in internal FITS-file compression (see PDL::IO::FITS). =head1 SYNOPSIS use PDL::Compression ($b,$asize) = $a->rice_compress(); $c = $b->rice_expand($asize); =cut =head1 FUNCTIONS =cut =head1 METHODS =cut =head2 rice_compress =for sig Signature: (in(n); [o]out(m); int[o]len(); lbuf(n); int blocksize) =for ref Squishes an input PDL along the 0 dimension by Rice compression. In scalar context, you get back only the compressed PDL; in list context, you also get back ancillary information that is required to uncompress the data with rice_uncompress. Multidimensional data are threaded over - each row is compressed separately, and the returned PDL is squished to the maximum compressed size of any row. If any of the streams could not be compressed (the algorithm produced longer output), the corresponding length is set to -1 and the row is treated as if it had length 0. Rice compression only works on integer data types -- if you have floating point data you must first quantize them. The underlying algorithm is identical to the Rice compressor used in CFITSIO (and is used by PDL::IO::FITS to load and save compressed FITS images). The optional blocksize indicates how many samples are to be compressed as a unit; it defaults to 32. How it works: Rice compression is a subset of Golomb compression, and works on data sets where variation between adjacent samples is typically small compared to the dynamic range of each sample. In this implementation (originally written by Richard White and contributed to CFITSIO in 1999), the data are divided into blocks of samples (by default 32 samples per block). Each block has a running difference applied, and the difference is bit-folded to make it positive definite. High order bits of the difference stream are discarded, and replaced with a unary representation; low order bits are preserved. Unary representation is very efficient for small numbers, but large jumps could give rise to ludicrously large bins in a plain Golomb code; such large jumps ("high entropy" samples) are simply recorded directly in the output stream. Working on astronomical or solar image data, typical compression ratios of 2-3 are achieved. =for usage $out = $pdl->rice_compress($blocksize); ($out, $len, $blocksize, $dim0) = $pdl->rice_compress; $new = $out->rice_expand; =for bad rice_compress ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::rice_compress { my $in = shift; my $blocksize = shift || 32; ## Reject floating-point inputs if( $in->type != byte && $in->type != short && $in->type != ushort && $in->type != long ) { die("rice_compress: input needs to have type byte, short, ushort, or long, not ".($in->type)."\n"); } # output buffer starts the same size; truncate at the end. my ($out) = zeroes($in); # line buffer is here to make sure we don't get fouled up by transpositions my ($lbuf) = zeroes($in->type, $in->dim(0)); # lengths go here my ($len) = zeroes(long, $in->slice("(0)")->dims); &PDL::_rice_compress_int( $in, $out, $len, $lbuf, $blocksize ); $l = $len->max; $out = $out->slice("0:".($l-1))->sever; if(wantarray) { return ($out, $in->dim(0), $blocksize, $len); } else { return $out; } } *rice_compress = \&PDL::rice_compress; =head2 rice_expand =for sig Signature: (in(n); [o]out(m); lbuf(n); int blocksize) =for ref Unsquishes a PDL that has been squished by rice_expand. =for usage ($out, $len, $blocksize, $dim0) = $pdl->rice_compress; $copy = $out->rice_expand($dim0, $blocksize); =for bad rice_expand ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::rice_expand { my $squished = shift; my $dim0 =shift; my $blocksize = shift || 32; # Allocate output array my $out = zeroes( $squished->slice("(0),*$dim0") ); # Allocate row buffer to avoid weird memory edge case my $lbuf = zeroes($squished->type, $squished->dim(0)); &PDL::_rice_expand_int( $squished, $out, $lbuf, $blocksize ); return $out; } *rice_expand = \&PDL::rice_expand; ; =head1 AUTHORS Copyright (C) 2010 Craig DeForest. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The Rice compression library is derived from the similar library in the CFITSIO 3.24 release, and is licensed under yet more more lenient terms than PDL itself; that notice is present in the file "ricecomp.c". =head1 BUGS =over 3 =item * Currently headers are ignored. =item * Currently there is only one compression algorithm. =back =head1 TODO =over 3 =item * Add object encapsulation =item * Add test suite =back =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/FFT.pm����������������������������������������������������������������������0000644�0601750�0601001�00000027211�13110402055�013260� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::FFT; @EXPORT_OK = qw( PDL::PP _fft PDL::PP _ifft fft ifft fftnd ifftnd fftconvolve realfft realifft kernctr PDL::PP convmath PDL::PP cmul PDL::PP cdiv ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::FFT ; =head1 NAME PDL::FFT - FFTs for PDL =head1 DESCRIPTION !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! As of PDL-2.006_04, the direction of the FFT/IFFT has been reversed to match the usage in the FFTW library and the convention in use generally. !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FFTs for PDL. These work for arrays of any dimension, although ones with small prime factors are likely to be the quickest. The forward FFT is unnormalized while the inverse FFT is normalized so that the IFFT of the FFT returns the original values. For historical reasons, these routines work in-place and do not recognize the in-place flag. That should be fixed. =head1 SYNOPSIS use PDL::FFT qw/:Func/; fft($real, $imag); ifft($real, $imag); realfft($real); realifft($real); fftnd($real,$imag); ifftnd($real,$imag); $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); =head1 DATA TYPES The underlying C library upon which this module is based performs FFTs on both single precision and double precision floating point piddles. Performing FFTs on integer data types is not reliable. Consider the following FFT on piddles of type 'double': $r = pdl(0,1,0,1); $i = zeroes($r); fft($r,$i); print $r,$i; [2 0 -2 0] [0 0 0 0] But if $r and $i are unsigned short integers (ushorts): $r = pdl(ushort,0,1,0,1); $i = zeroes($r); fft($r,$i); print $r,$i; [2 0 65534 0] [0 0 0 0] This used to occur because L<PDL::PP|PDL::PP> converts the ushort piddles to floats or doubles, performs the FFT on them, and then converts them back to ushort, causing the overflow where the amplitude of the frequency should be -2. Therefore, if you pass in a piddle of integer datatype (byte, short, ushort, long) to any of the routines in PDL::FFT, your data will be promoted to a double-precision piddle. If you pass in a float, the single-precision FFT will be performed. =head1 FREQUENCIES For even-sized input arrays, the frequencies are packed like normal for FFTs (where N is the size of the array and D is the physical step size between elements): 0, 1/ND, 2/ND, ..., (N/2-1)/ND, 1/2D, -(N/2-1)/ND, ..., -1/ND. which can easily be obtained (taking the Nyquist frequency to be positive) using C<< $kx = $real->xlinvals(-($N/2-1)/$N/$D,1/2/$D)->rotate(-($N/2 -1)); >> For odd-sized input arrays the Nyquist frequency is not directly acessible, and the frequencies are 0, 1/ND, 2/ND, ..., (N/2-0.5)/ND, -(N/2-0.5)/ND, ..., -1/ND. which can easily be obtained using C<< $kx = $real->xlinvals(-($N/2-0.5)/$N/$D,($N/2-0.5)/$N/$D)->rotate(-($N-1)/2); >> =head1 ALTERNATIVE FFT PACKAGES Various other modules - such as L<PDL::FFTW|PDL::FFTW> and L<PDL::Slatec|PDL::Slatec> - contain FFT routines. However, unlike PDL::FFT, these modules are optional, and so may not be installed. =cut =head1 FUNCTIONS =cut *_fft = \&PDL::_fft; *_ifft = \&PDL::_ifft; use Carp; use PDL::Core qw/:Func/; use PDL::Basic qw/:Func/; use PDL::Types; use PDL::ImageND qw/kernctr/; # moved to ImageND since FFTW uses it too END { # tidying up required after using fftn print "Freeing FFT space\n" if $PDL::verbose; fft_free(); } sub todecimal { my ($arg) = @_; $arg = $arg->double if (($arg->get_datatype != $PDL_F) && ($arg->get_datatype != $PDL_D)); $_[0] = $arg; 1;} =head2 fft() =for ref Complex 1-D FFT of the "real" and "imag" arrays [inplace]. =for sig Signature: ([o,nc]real(n); [o,nc]imag(n)) =for usage fft($real,$imag); =cut *fft = \&PDL::fft; sub PDL::fft { # Convert the first argument to decimal and check for trouble. eval { todecimal($_[0]); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($_[1]); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) piddle?' if ($message =~ /undefined value/); barf($message); } _fft($_[0],$_[1]); } =head2 ifft() =for ref Complex inverse 1-D FFT of the "real" and "imag" arrays [inplace]. =for sig Signature: ([o,nc]real(n); [o,nc]imag(n)) =for usage ifft($real,$imag); =cut *ifft = \&PDL::ifft; sub PDL::ifft { # Convert the first argument to decimal and check for trouble. eval { todecimal($_[0]); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($_[1]); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) piddle?' if ($message =~ /undefined value/); barf($message); } _ifft($_[0],$_[1]); } =head2 realfft() =for ref One-dimensional FFT of real function [inplace]. The real part of the transform ends up in the first half of the array and the imaginary part of the transform ends up in the second half of the array. =for usage realfft($real); =cut *realfft = \&PDL::realfft; sub PDL::realfft { barf("Usage: realfft(real(*)") if $#_ != 0; my ($a) = @_; todecimal($a); # FIX: could eliminate $b my ($b) = 0*$a; fft($a,$b); my ($n) = int((($a->dims)[0]-1)/2); my($t); ($t=$a->slice("-$n:-1")) .= $b->slice("1:$n"); undef; } =head2 realifft() =for ref Inverse of one-dimensional realfft routine [inplace]. =for usage realifft($real); =cut *realifft = \&PDL::realifft; sub PDL::realifft { use PDL::Ufunc 'max'; barf("Usage: realifft(xfm(*)") if $#_ != 0; my ($a) = @_; todecimal($a); my ($n) = int((($a->dims)[0]-1)/2); my($t); # FIX: could eliminate $b my ($b) = 0*$a; ($t=$b->slice("1:$n")) .= $a->slice("-$n:-1"); ($t=$a->slice("-$n:-1")) .= $a->slice("$n:1"); ($t=$b->slice("-$n:-1")) .= -$b->slice("$n:1"); ifft($a,$b); # Sanity check -- shouldn't happen carp "Bad inverse transform in realifft" if max(abs($b)) > 1e-6*max(abs($a)); undef; } =head2 fftnd() =for ref N-dimensional FFT over all pdl dims of input (inplace) =for example fftnd($real,$imag); =cut *fftnd = \&PDL::fftnd; sub PDL::fftnd { barf "Must have real and imaginary parts for fftnd" if $#_ != 1; my ($r,$i) = @_; my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for fft" if ($n != $i->getndims); $n--; todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; foreach (0..$n) { fft($r,$i); $r = $r->mv(0,$n); $i = $i->mv(0,$n); } $_[0] = $r; $_[1] = $i; undef; } =head2 ifftnd() =for ref N-dimensional inverse FFT over all pdl dims of input (inplace) =for example ifftnd($real,$imag); =cut *ifftnd = \&PDL::ifftnd; sub PDL::ifftnd { barf "Must have real and imaginary parts for ifftnd" if $#_ != 1; my ($r,$i) = @_; my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for ifft" if ($n != $i->getndims); todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; $n--; foreach (0..$n) { ifft($r,$i); $r = $r->mv(0,$n); $i = $i->mv(0,$n); } $_[0] = $r; $_[1] = $i; undef; } =head2 fftconvolve() =for ref N-dimensional convolution with periodic boundaries (FFT method) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); fftconvolve works inplace, and returns an error array in kernel as an accuracy check -- all the values in it should be negligible. See also L<PDL::ImageND::convolveND|PDL::ImageND/convolveND>, which performs speed-optimized convolution with a variety of boundary conditions. The sizes of the image and the kernel must be the same. L<kernctr|PDL::ImageND/kernctr> centres a small kernel to emulate the behaviour of the direct convolution routines. The speed cross-over between using straight convolution (L<PDL::Image2D::conv2d()|PDL::Image2D/conv2d>) and these fft routines is for kernel sizes roughly 7x7. =cut *fftconvolve = \&PDL::fftconvolve; sub PDL::fftconvolve { barf "Must have image & kernel for fftconvolve" if $#_ != 1; my ($a, $k) = @_; my ($ar,$ai,$kr,$ki,$cr,$ci); $ar = $a->copy; $ai = $ar->zeros; fftnd($ar, $ai); $kr = $k->copy; $ki = $kr->zeroes; fftnd($kr,$ki); $cr = $ar->zeroes; $ci = $ai->zeroes; cmul($ar,$ai,$kr,$ki,$cr,$ci); ifftnd($cr,$ci); $_[0] = $cr; $_[1] = $ci; ($cr,$ci); } sub PDL::fftconvolve_inplace { barf "Must have image & kernel for fftconvolve" if $#_ != 1; my ($hr, $hi) = @_; my ($n) = $hr->getndims; todecimal($hr); # Convert to double unless already float or double todecimal($hi); # Convert to double unless already float or double # need the copy in case $r and $i point to same memory $hi = $hi->copy; $hr = $hr->copy; fftnd($hr,$hi); convmath($hr->clump(-1),$hi->clump(-1)); my ($str1, $str2, $tmp, $i); chop($str1 = '-1:1,' x $n); chop($str2 = '1:-1,' x $n); # FIX: do these inplace -- cuts the arithmetic by a factor 2 as well. ($tmp = $hr->slice($str2)) += $hr->slice($str1)->copy; ($tmp = $hi->slice($str2)) -= $hi->slice($str1)->copy; for ($i = 0; $i<$n; $i++) { chop ($str1 = ('(0),' x $i).'-1:1,'.('(0),'x($n-$i-1))); chop ($str2 = ('(0),' x $i).'1:-1,'.('(0),'x($n-$i-1))); ($tmp = $hr->slice($str2)) += $hr->slice($str1)->copy; ($tmp = $hi->slice($str2)) -= $hi->slice($str1)->copy; } $hr->clump(-1)->set(0,$hr->clump(-1)->at(0)*2); $hi->clump(-1)->set(0,0.); ifftnd($hr,$hi); $_[0] = $hr; $_[1] = $hi; ($hr,$hi); } =head2 convmath =for sig Signature: ([o,nc]a(m); [o,nc]b(m)) =for ref Internal routine doing maths for convolution =for bad convmath does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *convmath = \&PDL::convmath; =head2 cmul =for sig Signature: (ar(); ai(); br(); bi(); [o]cr(); [o]ci()) =for ref Complex multiplication =for bad cmul does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cmul = \&PDL::cmul; =head2 cdiv =for sig Signature: (ar(); ai(); br(); bi(); [o]cr(); [o]ci()) =for ref Complex division =for bad cdiv does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cdiv = \&PDL::cdiv; 1; # OK =head1 BUGS Where the source is marked `FIX', could re-implement using phase-shift factors on the transforms and some real-space bookkeeping, to save some temporary space and redundant transforms. =head1 AUTHOR This file copyright (C) 1997, 1998 R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ; # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Fit/������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402052�013017� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Fit/Gaussian.pm�������������������������������������������������������������0000644�0601750�0601001�00000007415�13110402052�015136� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Fit::Gaussian; @EXPORT_OK = qw( PDL::PP fitgauss1d PDL::PP fitgauss1dr ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Fit::Gaussian ; =head1 NAME PDL::Fit::Gaussian - routines for fitting gaussians =head1 DESCRIPTION This module contains some custom gaussian fitting routines. These were developed in collaboration with Alison Offer, they do a reasonably robust job and are quite useful. Gaussian fitting is something I do a lot of, so I figured it was worth putting in my special code. Note it is not clear to me that this code is fully debugged. The reason I say that is because I tried using the internal linear eqn solving C routines called elsewhere and they were giving erroneous results. So steal from this code with caution! However it does give good fits to reasonable looking gaussians and tests show correct parameters. KGB 29/Oct/2002 =head1 SYNOPSIS use PDL; use PDL::Fit::Gaussian; ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); ($pk, $fwhm, $back, $err, $fit) = fitgauss1dr($r, $data); =head1 FUNCTIONS =head2 fitgauss1d =for ref Fit 1D Gassian to data piddle =for example ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); =for usage ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); =for signature xval(n); data(n); [o]xcentre();[o]peak_ht(); [o]fwhm(); [o]background();int [o]err(); [o]datafit(n); [t]sig(n); [t]xtmp(n); [t]ytmp(n); [t]yytmp(n); [t]rtmp(n); Fits a 1D Gaussian robustly free parameters are the centre, peak height, FWHM. The background is NOT fit, because I find this is generally unreliable, rather a median is determined in the 'outer' 10% of pixels (i.e. those at the start/end of the data piddle). The initial estimate of the FWHM is the length of the piddle/3, so it might fail if the piddle is too long. (This is non-robust anyway). Most data does just fine and this is a good default gaussian fitter. SEE ALSO: fitgauss1dr() for fitting radial gaussians =head2 fitgauss1dr =for ref Fit 1D Gassian to radial data piddle =for example ($pk, $fwhm2, $back, $err, $fit) = fitgauss1dr($r, $data); =for usage ($pk, $fwhm2, $back, $err, $fit) = fitgauss1dr($r, $data); =for signature xval(n); data(n); [o]peak_ht(); [o]fwhm(); [o]background();int [o]err(); [o]datafit(n); [t]sig(n); [t]xtmp(n); [t]ytmp(n); [t]yytmp(n); [t]rtmp(n); Fits a 1D radial Gaussian robustly free parameters are the peak height, FWHM. Centre is assumed to be X=0 (i.e. start of piddle). The background is NOT fit, because I find this is generally unreliable, rather a median is determined in the 'outer' 10% of pixels (i.e. those at the end of the data piddle). The initial estimate of the FWHM is the length of the piddle/3, so it might fail if the piddle is too long. (This is non-robust anyway). Most data does just fine and this is a good default gaussian fitter. SEE ALSO: fitgauss1d() to fit centre as well. =cut *fitgauss1d = \&PDL::fitgauss1d; *fitgauss1dr = \&PDL::fitgauss1dr; 1; # OK =head1 BUGS May not converge for weird data, still pretty good! =head1 AUTHOR This file copyright (C) 1999, Karl Glazebrook (kgb@aaoepp.aao.gov.au), Gaussian fitting code by Alison Offer (aro@aaocbn.aao.gov.au). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ; # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GIS/������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402065�012723� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GIS/Proj.pm�����������������������������������������������������������������0000644�0601750�0601001�00000016110�13110402065�014172� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GIS::Proj; @EXPORT_OK = qw( fwd_transform inv_transform get_proj_info PDL::PP _fwd_trans fwd_trans_inplace PDL::PP _fwd_trans_inplace PDL::PP _inv_trans inv_trans_inplace PDL::PP _inv_trans_inplace load_projection_descriptions load_projection_information ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GIS::Proj ; =head1 NAME PDL::GIS::Proj - PDL interface to the Proj4 projection library. =head1 DESCRIPTION PDL interface to the Proj4 projection library. For more information on the proj library, see: http://www.remotesensing.org/proj/ =head1 AUTHOR Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 DATE 18 March 2003 =head1 CHANGES =head2 1.32 (29 March 2006) Judd Taylor - Getting ready to merge this into the PDL CVS. =head2 1.31 (???) Judd Taylor - Can't remember what was in that version =head2 1.30 (16 September 2003) Judd Taylor - The get_proj_info() function actually works now. =head2 1.20 (24 April 2003) Judd Taylor - Added get_proj_info(). =head2 1.10 (23 April 2003) Judd Taylor - Changed from using the proj_init() type API in projects.h to the - proj_init_plus() API in proj_api.h. The old one was not that stable... =head2 1.00 (18 March 2003) Judd Taylor - Initial version =head1 COPYRIGHT NOTICE Copyright 2003 Judd Taylor, USF Institute for Marine Remote Sensing (judd@marine.usf.edu). GPL Now! This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. =head1 SUBROUTINES =cut =head2 fwd_transform($lon(pdl), $lat(pdl), $params) Proj4 forward transformation $params is a string of the projection transformation parameters. Returns two pdls for x and y values respectively. The units are dependent on Proj4 behavior. They will be PDL->null if an error has occurred. BadDoc: Ignores bad elements of $lat and $lon, and sets the corresponding elements of $x and $y to BAD =cut sub fwd_transform { my ($lon, $lat, $params) = @_; my $x = null; my $y = null; #print "Projection transformation parameters: \'$params\'\n"; _fwd_trans( $lon, $lat, $x, $y, $params ); return ($x, $y); } # End of fwd_transform()... =head2 inv_transform($x(pdl), $y(pdl), $params) Proj4 inverse transformation $params is a string of the projection transformation parameters. Returns two pdls for lat and lon values respectively. The units are dependent on Proj4 behavior. They will be PDL->null if an error has occurred. BadDoc: Ignores bad elements of $lat and $lon, and sets the corresponding elements of $x and $y to BAD =cut sub inv_transform { my ($x, $y, $params) = @_; my $lon = null; my $lat = null; #print "Projection transformation parameters: \'$params\'\n"; _inv_trans( $x, $y, $lon, $lat, $params ); return ($lon, $lat); } # End of fwd_transform()... =head2 get_proj_info($params_string) Returns a string with information about what parameters proj will actually use, this includes defaults, and +init=file stuff. It's the same as running 'proj -v'. It uses the proj command line, so it might not work with all shells. I've tested it with bash. =cut sub get_proj_info { my $params = shift; my @a = split(/\n/, `echo | proj -v $params`); pop(@a); return join("\n", @a); } # End of get_proj_info()... *_fwd_trans = \&PDL::_fwd_trans; # # Wrapper sub for _fwd_trans_inplace that sets a default for the quiet variable. # sub fwd_trans_inplace { my $lon = shift; my $lat = shift; my $params = shift; my $quiet = shift || 0; _fwd_trans_inplace( $lon, $lat, $params, $quiet ); } # End of fwd_trans_inplace()... *_fwd_trans_inplace = \&PDL::_fwd_trans_inplace; *_inv_trans = \&PDL::_inv_trans; # # Wrapper sub for _fwd_trans_inplace that sets a default for the quiet variable. # sub inv_trans_inplace { my $lon = shift; my $lat = shift; my $params = shift; my $quiet = shift || 0; _inv_trans_inplace( $lon, $lat, $params, $quiet ); } # End of fwd_trans_inplace()... *_inv_trans_inplace = \&PDL::_inv_trans_inplace; sub load_projection_information { my $descriptions = PDL::GIS::Proj::load_projection_descriptions(); my $info = {}; foreach my $projection ( keys %$descriptions ) { my $description = $descriptions->{$projection}; my $hash = {}; $hash->{CODE} = $projection; my @lines = split( /\n/, $description ); chomp @lines; # Full name of this projection: $hash->{NAME} = $lines[0]; # The second line is usually a list of projection types this one is: my $temp = $lines[1]; $temp =~ s/no inv\.*,*//; $temp =~ s/or//; my @temp_types = split(/[,&\s]/, $temp ); my @types = grep( /.+/, @temp_types ); $hash->{CATEGORIES} = \@types; # If there's more than 2 lines, then it usually is a listing of parameters: # General parameters for all projections: $hash->{PARAMS}->{GENERAL} = [ qw( x_0 y_0 lon_0 units init no_defs geoc over ) ]; # Earth Figure Parameters: $hash->{PARAMS}->{EARTH} = [ qw( ellps b f rf e es R R_A R_V R_a R_g R_h R_lat_g ) ]; # Projection Specific Parameters: my @proj_params = (); if( $#lines >= 2 ) { foreach my $i ( 2 .. $#lines ) { my $text = $lines[$i]; my @temp2 = split( /\s+/, $text ); my @params = grep( /.+/, @temp2 ); foreach my $param (@params) { $param =~ s/=//; $param =~ s/[,\[\]]//sg; next if $param =~ /^and$/; next if $param =~ /^or$/; next if $param =~ /^Special$/; next if $param =~ /^for$/; next if $param =~ /^Madagascar$/; next if $param =~ /^fixed$/; next if $param =~ /^Earth$/; next if $param =~ /^For$/; next if $param =~ /^CH1903$/; push(@proj_params, $param); } } } $hash->{PARAMS}->{PROJ} = \@proj_params; # Can this projection do inverse? $hash->{INVERSE} = ( $description =~ /no inv/ ) ? 0 : 1; $info->{$projection} = $hash; } # A couple of overrides: # $info->{ob_tran}->{PARAMS}->{PROJ} = [ 'o_proj', 'o_lat_p', 'o_lon_p', 'o_alpha', 'o_lon_c', 'o_lat_c', 'o_lon_1', 'o_lat_1', 'o_lon_2', 'o_lat_2' ]; $info->{nzmg}->{CATEGORIES} = [ 'fixed Earth' ]; return $info; } # End of load_projection_information()... ; # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Graphics/�������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402056�014041� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Graphics/IIS.pm�������������������������������������������������������������0000644�0601750�0601001�00000027330�13110402056�015030� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Graphics::IIS; @EXPORT_OK = qw( iis iiscur iiscirc $stdimage $iisframe saoimage ximtool PDL::PP _iis PDL::PP _iiscirc ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Graphics::IIS ; =head1 NAME PDL::Graphics::IIS - Display PDL images on IIS devices (saoimage/ximtool) =head1 SYNOPSIS use PDL::Graphics::IIS; saoimage ( -geometry => '800x800' ); iis rvals(100,100); =head1 DESCRIPTION This module provides an interface to any image display 'device' which support the 'IIS protocol' - viz the SAOimage and Ximtool X-windows programs, the old SunView imtool program and presumably even the original IIS CRT itself if they aren't all in museums! These programs should be familiar to astronomer's - they are used by the common IRAF system. The programs and their HTML documentation can be obtained from the following URLs: SAOimage: http://tdc-www.harvard.edu/software/saoimage.html Ximtool: http://iraf.noao.edu/iraf/web/projects/x11iraf/x11iraf.html Non-astronomer's may find they quite nifty for displaying 2D data. The Perl variable C<$stdimage> is exported from the module and controls the frame buffer configuration currently in use. The default value is C<imt1024> which specifies a C<1024x1024> frame buffer. Other values supported by the module are: imt512, imt800, imt1024, imt1600, imt2048, and imt4096. If you have a F<$HOME/.imtoolrc> you can use it to specify other frame buffer names and configurations in exactly the same way you can in IRAF. Here is a sample file: -------------------snip------------------------- # Format: configno nframes width height 1 2 512 512 # imt1|imt512 2 2 800 800 # imt2|imt800 3 2 1024 1024 # imt3|imt1024 4 1 1600 1600 # imt4|imt1600 5 1 2048 2048 # imt5|imt2048 6 1 4096 4096 # imt6|imt4096 7 1 8192 8192 # imt7|imt8192 8 1 1024 4096 # imt8|imt1x4 9 2 1144 880 # imt9|imtfs full screen (1152x900 minus frame) 10 2 1144 764 # imt10|imtfs35 full screen at 35mm film aspect ratio -------------------snip------------------------- (Note: some versions of SAOimage may not even work if this file is not present. If you get funny error messages about 'imtoolrc' try copying the above to F<$HOME/.imtoolrc> or F</usr/local/lib/imtoolrc>) The Perl variable C<$iisframe> is also exported from the module and controls which display frame number to use in programs such as Ximtool which supports multiple frames. This allows you to do useful things such as blink between images. The module communicates with the IIS device down FIFO pipes (special UNIX files) - unlike IRAF this module does a pretty decent job of intelligently guessing which file names to use for the pipes and will prompt for their creating if absent. Also if SAOimage or Ximtool are started from within Perl using the module this will guarantee correct file names! =head1 FUNCTIONS =cut use PDL::Core ''; use PDL::Basic ''; use Carp; $iisframe = 1; # Starting defaults $stdimage = "imt1024"; $last_stdimage = ""; $HOME = $ENV{'HOME'}; # Used a lot so shorten ################ Public routines ################# # Display =head2 iis =for ref Displays an image on a IIS device (e.g. SAOimage/Ximtool) =for usage iis $image, [ { MIN => $min, MAX => $max, TITLE => 'pretty picture', FRAME => 2 } ] iis $image, [$min,$max] =for sig (image(m,n),[\%options]) or (image(m,n),[min(),max()]) Displays image on a IIS device. If C<min()> or C<max()> are omitted they are autoscaled. A good demonstration of PDL threading can be had by giving C<iis()> a data *cube* - C<iis()> will be repeatedly called for each plane of the cube resulting in a poor man's movie! If supplied, C<TITLE> is used to label the frame, if no title is supplied, either the C<OBJECT> value stored in the image header or a default string is used (the title is restricted to a maximum length of 32 characters). To specify which frame to draw to, either use the package variable C<$iisframe>, or the C<FRAME> option. =cut sub iis { my $usage = 'Usage: iis ( $image, [\%hash | $min, $max] )'; barf $usage if $#_<0 || $#_>2; my $image = shift; my ( $min, $max ); my $title = 'perlDL rules !'; my $header = $image->gethdr(); if ( defined $header and defined $$header{OBJECT} ) { $title = $$header{OBJECT}; $title =~ s/^'(.*)'$/$1/; } my $frame = $iisframe; if ( $#_ == 1 ) { $min = $_[0]; $max = $_[1]; } elsif ( $#_ == 0 ) { barf $usage unless ref($_[0]) eq "HASH"; my $opt = new PDL::Options( { MIN => undef, MAX => undef, TITLE => $title, FRAME => $frame } ); $opt->options( shift ); my $options = $opt->current; $min = $$options{MIN}; $max = $$options{MAX}; $title = $$options{TITLE}; $iisframe = $$options{FRAME}; } my($nx,$ny) = dims($image); fbconfig($stdimage) if $stdimage ne $last_stdimage; $min = $image->min unless defined $min; $max = $image->max unless defined $max; print "Displaying $nx x $ny image in frame $iisframe from $min to $max ...\n" if $PDL::verbose; PDL::_iis($image,$min,$max,$title); $iisframe = $frame; # restore value 1; } =head2 iiscur =for ref Return cursor position from an IIS device (e.g. SAOimage/Ximtool) =for usage ($x,$y) = iiscur($ch) This function puts up an interactive cursor on the IIS device and returns the C<($x,$y)> position and the character typed (C<$ch>) by the user. =cut sub iiscur { barf 'Usage: ($x,$y) = iiscur($ch)' if $#_>=1; my ($x,$y,$ch) = _iiscur_int(); $_[0] = $ch; # Pass this back in args return ($x,$y); } =head2 iiscirc =for ref Draws a circle on a IIS device (e.g. SAOimage/Ximtool) =for sig (x(),y(),radius(),colour()) =for usage iiscirc $x, $y, [$radius, $colour] Draws circles on the IIS device with specied points and colours. Because this module uses L<PDL::PP|PDL::PP> threading you can supply lists of points via 1D arrays, etc. An amusing PDL idiom is: pdl> iiscirc iiscur Note the colours are the same as IRAF, viz: 201 = cursor color (white) 202 = black 203 = white 204 = red 205 = green 206 = blue 207 = yellow 208 = cyan 209 = magenta 210 = coral 211 = maroon 212 = orange 213 = khaki 214 = orchid 215 = turquoise 216 = violet 217 = wheat =cut sub iiscirc { barf 'Usage: iiscirc( $x, $y, [$radius, $colour] )' if $#_<1 || $#_>3; my($x, $y, $radius, $colour)=@_; fbconfig($stdimage) if $stdimage ne $last_stdimage; $radius = 10 unless defined $radius; $colour = 204 unless defined $colour; PDL::_iiscirc($x, $y, $radius, $colour); 1; } =head2 saoimage =for ref Starts the SAOimage external program =for usage saoimage[(command line options)] Starts up the SAOimage external program. Default FIFO devices are chosen so as to be compatible with other IIS module functions. If no suitable FIFOs are found it will offer to create them. e.g.: =for example pdl> saoimage pdl> saoimage( -geometry => '800x800' ) =cut sub saoimage { # Start SAOimage fbconfig($stdimage) if $stdimage ne $last_stdimage; if( !($pid = fork)) { # error or child exec("saoimage", -idev => $fifo, -odev => $fifi, @_) if defined $pid; die "Can't start saoimage: $!\n"; } return $pid; } =head2 ximtool =for ref Starts the Ximtool external program =for usage ximtool[(command line options)] Starts up the Ximtool external program. Default FIFO devices are chosen so as to be compatible with other IIS module functions. If no suitable FIFOs are found it will offer to create them. e.g. =for example pdl> ximtool pdl> ximtool (-maxColors => 64) =cut sub ximtool { # Start Ximtool fbconfig($stdimage) if $stdimage ne $last_stdimage; if( !($pid = fork)) { # error or child exec("ximtool", -xrm => "ximtool*input_fifo: $fifi", -xrm => "ximtool*output_fifo: $fifo", @_) if defined $pid; die "Can't start ximtool: $!\n"; } return $pid; } ################ Private routines ################# # Change the frame buffer configuration sub fbconfig { my $name = shift; parseimtoolrc() unless $parsed++; findfifo() unless $foundfifo++; barf 'No frame buffer configuration "'.$name.'" found'."\n" unless defined $imtoolrc{$name}; ($fbconfig, $fb_x, $fb_y ) = @{ $imtoolrc{$name} }; print "Using $stdimage - fbconfig=$fbconfig (${fb_x}x$fb_y)\n" if $PDL::verbose;; $last_stdimage = $stdimage; 1;} # Try and find user/system imtoolrc definitions sub parseimtoolrc { # assoc array holds imtool configuations - init with some standard # ones in case imtoolrc goes missing %imtoolrc = ( 'imt512' => [1,512,512], 'imt800' => [2,800,800], 'imt1024' => [3,1024,1024], 'imt1600' => [4,1600,1600], 'imt2048' => [5,2048,2048], 'imt4096' => [6,4096,4096], ); # Look for imtoolrc file $imtoolrc = "/usr/local/lib/imtoolrc"; $imtoolrc = "$HOME/.imtoolrc" if -e "$HOME/.imtoolrc"; if (!-e $imtoolrc) { warn "WARNING: unable to find an imtoolrc file in $HOME/.imtoolrc\n". "or /usr/local/lib/imtoolrc. Will try \$stdimage = imt1024.\n"; return 1; } # Load frame buffer configuartions from imtoolrc file and # store in assoc array open(IMTOOLRC, $imtoolrc) || die "File $imtoolrc not found"; while(<IMTOOLRC>) { if ( /^\s*(\d+)\s+\d+\s+(\d+)\s+(\d+)\s+\#\s*(\S+)\s/ ) { foreach $name (split(/\|/,$4)) { $imtoolrc{$name} = [$1,$2,$3]; } } }close(IMTOOLRC); 1;} # Try a few obvious places for the FIFO pipe and create if necessary sub findfifo { $fifi = ""; $fifo = ""; if (-e "/dev/imt1i" && -e "/dev/imt1o") { $fifi = "/dev/imt1i"; $fifo = "/dev/imt1o"; } if (-e "$HOME/dev/imt1i" && -e "$HOME/dev/imt1o") { $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o"; } if (-e "$HOME/iraf/dev/imt1i" && -e "$HOME/iraf/dev/imt1o") { $fifi = "$HOME/iraf/dev/imt1i"; $fifo = "$HOME/iraf/dev/imt1o"; } if (defined $ENV{'IMTDEV'} && $ENV{'IMTDEV'} =~ /^fifo:(.*):(.*)$/) { $fifi = $1; $fifo = $2; } if ($fifi eq "" && $fifo eq "") { # Still not found use this default warn "WARNING: cannot locate FIFO pipes in /dev/, $HOME/dev, ". "$HOME/iraf/dev or environment variable \$IMTDEV\n"; $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o"; } print "Using FIFO devices in: $fifi\n". " out: $fifo\n" if $PDL::verbose; for $pipe ($fifi, $fifo) { if (!-p $pipe) { print "FIFO $pipe does not exist - try and create now? "; my $ans = <STDIN>; system "/usr/etc/mknod $pipe p" if $ans =~ /^y/i; if ($ans =~ /^y/i) { unlink $pipe if -e $pipe; my $path = $ENV{PATH}; $ENV{PATH} .= ":/etc:/usr/etc"; # Note system return value is backwards - hence 'and' if ( system('mknod', $pipe, 'p') and system('mkfifo',$pipe) ) { die "Failed to create named pipe $pipe\n"; } $ENV{PATH} = $path; } } } 1;} *_iis = \&PDL::Graphics::IIS::_iis; *_iiscirc = \&PDL::Graphics::IIS::_iiscirc; ; =head1 BUGS None known =head1 AUTHOR Copyright (C) Karl Glazebrook 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Graphics/OpenGLQ.pm���������������������������������������������������������0000644�0601750�0601001�00000003250�13110402052�015640� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Graphics::OpenGLQ; @EXPORT_OK = qw( PDL::PP line_3x_3c PDL::PP gl_points PDL::PP gl_lines PDL::PP gl_line_strip PDL::PP gl_texts PDL::PP gl_triangles_mat PDL::PP gl_triangles_n_mat PDL::PP gl_triangles_wn_mat PDL::PP gl_triangles PDL::PP gl_triangles_n PDL::PP gl_triangles_wn PDL::PP gl_arrows ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Graphics::OpenGLQ ; =head1 NAME PDL::Graphics::OpenGLQ - quick routines to plot lots of stuff from piddles. =head1 SYNOPSIS only for internal use - see source =head1 DESCRIPTION only for internal use - see source =head1 AUTHOR Copyright (C) 1997,1998 Tuomas J. Lukka. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut *line_3x_3c = \&PDL::line_3x_3c; *gl_points = \&PDL::gl_points; *gl_lines = \&PDL::gl_lines; *gl_line_strip = \&PDL::gl_line_strip; *gl_texts = \&PDL::gl_texts; *gl_triangles_mat = \&PDL::gl_triangles_mat; *gl_triangles_n_mat = \&PDL::gl_triangles_n_mat; *gl_triangles_wn_mat = \&PDL::gl_triangles_wn_mat; *gl_triangles = \&PDL::gl_triangles; *gl_triangles_n = \&PDL::gl_triangles_n; *gl_triangles_wn = \&PDL::gl_triangles_wn; *gl_arrows = \&PDL::gl_arrows; ; # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Graphics/TriD/��������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402053�014700� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Graphics/TriD/Rout.pm�������������������������������������������������������0000644�0601750�0601001�00000012634�13110402053�016175� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Graphics::TriD::Rout; @EXPORT_OK = qw( PDL::PP combcoords PDL::PP repulse PDL::PP attract PDL::PP vrmlcoordsvert PDL::PP contour_segments_internal ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Graphics::TriD::Rout ; =head1 NAME PDL::Graphics::TriD::Rout - Helper routines for Three-dimensional graphics =head1 DESCRIPTION This module is for miscellaneous PP-defined utility routines for the PDL::Graphics::TriD module. Currently, there are =head1 FUNCTIONS =cut =head2 combcoords =for sig Signature: (x(); y(); z(); float [o]coords(tri=3);) =for ref Combine three coordinates into a single piddle. Combine x, y and z to a single piddle the first dimension of which is 3. This routine does dataflow automatically. =for bad combcoords does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *combcoords = \&PDL::combcoords; =head2 repulse =for sig Signature: (coords(nc,np); [o]vecs(nc,np); int [t]links(np);; double boxsize; int dmult; double a; double b; double c; double d; ) =for ref Repulsive potential for molecule-like constructs. C<repulse> uses a hash table of cubes to quickly calculate a repulsive force that vanishes at infinity for many objects. For use by the module L<PDL::Graphics::TriD::MathGraph|PDL::Graphics::TriD::MathGraph>. For definition of the potential, see the actual function. =for bad repulse does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *repulse = \&PDL::repulse; =head2 attract =for sig Signature: (coords(nc,np); int from(nl); int to(nl); strength(nl); [o]vecs(nc,np);; double m; double ms; ) =for ref Attractive potential for molecule-like constructs. C<attract> is used to calculate an attractive force for many objects, of which some attract each other (in a way like molecular bonds). For use by the module L<PDL::Graphics::TriD::MathGraph|PDL::Graphics::TriD::MathGraph>. For definition of the potential, see the actual function. =for bad attract does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *attract = \&PDL::attract; =head2 vrmlcoordsvert =for sig Signature: (vertices(n=3); char* space; char* fd) =for ref info not available =for bad vrmlcoordsvert does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *vrmlcoordsvert = \&PDL::vrmlcoordsvert; =head2 contour_segments =for ref This is the interface for the pp routine contour_segments_internal - it takes 3 piddles as input C<$c> is a contour value (or a list of contour values) C<$data> is an [m,n] array of values at each point C<$points> is a list of [3,m,n] points, it should be a grid monotonically increasing with m and n. contour_segments returns a reference to a Perl array of line segments associated with each value of C<$c>. It does not (yet) handle missing data values. =over 4 =item Algorthym The data array represents samples of some field observed on the surface described by points. For each contour value we look for intersections on the line segments joining points of the data. When an intersection is found we look to the adjoining line segments for the other end(s) of the line segment(s). So suppose we find an intersection on an x-segment. We first look down to the left y-segment, then to the right y-segment and finally across to the next x-segment. Once we find one in a box (two on a point) we can quit because there can only be one. After we are done with a given x-segment, we look to the leftover possibilities for the adjoining y-segment. Thus the contours are built as a collection of line segments rather than a set of closed polygons. =back =cut use strict; sub PDL::Graphics::TriD::Contours::contour_segments { my($this,$c,$data,$points) = @_; # pre compute space for output of pp routine my $segdim = ($data->getdim(0)-1)*($data->getdim(1)-1)*4; # print "segdim = $segdim\n"; my $segs = zeroes(3,$segdim,$c->nelem); my $cnt = zeroes($c->nelem); contour_segments_internal($c,$data,$points,$segs,$cnt); # print "contour segments done ",$points->info,"\n"; $this->{Points} = pdl->null; my $pcnt=0; my $ncnt; for(my $i=0; $i<$c->nelem; $i++){ $ncnt = $cnt->slice("($i)"); next if($ncnt==-1); $pcnt = $pcnt+$ncnt; $this->{ContourSegCnt}[$i] = $pcnt; $pcnt=$pcnt+1; $this->{Points} = $this->{Points}->append($segs->slice(":,0:$ncnt,($i)")->xchg(0,1)); } $this->{Points} = $this->{Points}->xchg(0,1); } *contour_segments_internal = \&PDL::contour_segments_internal; ; =head1 AUTHOR Copyright (C) 2000 James P. Edwards Copyright (C) 1997 Tuomas J. Lukka. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSL/������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402070�012722� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSL/DIFF.pm�����������������������������������������������������������������0000644�0601750�0601001�00000011050�13110402065�013771� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::DIFF; @EXPORT_OK = qw( gsldiff PDL::PP diff_central PDL::PP diff_backward PDL::PP diff_forward ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::DIFF ; =head1 NAME PDL::GSL::DIFF - PDL interface to numerical differentiation routines in GSL =head1 DESCRIPTION This is an interface to the numerical differentiation package present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::DIFF; my $x0 = 3.3; my @res = gsldiff(\&myfunction,$x0); # same as above: @res = gsldiff(\&myfunction,$x0,{Method => 'central'}); # use only values greater than $x0 to get the derivative @res = gsldiff(\&myfunction,$x0,{Method => 'forward'}); # use only values smaller than $x0 to get the derivative @res = gsldiff(\&myfunction,$x0,{Method => 'backward'}); sub myfunction{ my ($x) = @_; return $x**2; } =head1 FUNCTIONS =cut sub gsldiff{ my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Method => 'central'}; } die 'Usage: gsldiff(function_ref, x, {Options} )' if $#_<1 || $#_>2; my ($f,$x) = @_; my ($res,$abserr); if($$opt{Method}=~/cent/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_central($x,$f); } elsif($$opt{Method}=~/back/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_backward($x,$f); } elsif($$opt{Method}=~/forw/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_forward($x,$f); } else{ barf("Unknown differentiation method $method in gsldiff\n"); } return ($res,$abserr); } =head2 diff_central =for sig Signature: (double x(); double [o] res(); double [o] abserr(); SV* function) =for ref info not available =for bad diff_central does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *diff_central = \&PDL::diff_central; =head2 diff_backward =for sig Signature: (double x(); double [o] res(); double [o] abserr(); SV* function) =for ref info not available =for bad diff_backward does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *diff_backward = \&PDL::diff_backward; =head2 diff_forward =for sig Signature: (double x(); double [o] res(); double [o] abserr(); SV* function) =for ref info not available =for bad diff_forward does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *diff_forward = \&PDL::diff_forward; ; =head2 gsldiff =for ref This functions serves as an interface to the three differentiation functions present in GSL: gsl_diff_central, gsl_diff_backward and gsl_diff_forward. To compute the derivative, the central method uses values greater and smaller than the point at which the derivative is to be evaluated, while backward and forward use only values smaller and greater respectively. gsldiff() returns both the derivative and an absolute error estimate. The default method is 'central', others can be specified by passing an option. Please check the GSL documentation for more information. =for usage Usage: ($d,$abserr) = gsldiff($function_ref,$x,{Method => $method}); =for example Example: #derivative using default method ('central') ($d,$abserr) = gsldiff(\&myf,3.3); #same as above with method set explicitly ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'central'}); #using backward & forward methods ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'backward'}); ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'forward'}); sub myf{ my ($x) = @_; return exp($x); } =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L<http://pdl.perl.org>). =head1 SEE ALSO L<PDL> The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2003 Andres Jordan <andresj@physics.rutgers.edu> All rights reserved. There is no warranty. You are allowed to redistribute this software documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL differentiation routines were written by David Morrison. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSL/INTEG.pm����������������������������������������������������������������0000644�0601750�0601001�00000063570�13110402060�014140� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::INTEG; @EXPORT_OK = qw( gslinteg_qng gslinteg_qag gslinteg_qags gslinteg_qagp gslinteg_qagi gslinteg_qagiu gslinteg_qagil gslinteg_qawc gslinteg_qaws gslinteg_qawo gslinteg_qawf PDL::PP qng_meat PDL::PP qag_meat PDL::PP qags_meat PDL::PP qagp_meat PDL::PP qagi_meat PDL::PP qagiu_meat PDL::PP qagil_meat PDL::PP qawc_meat PDL::PP qaws_meat PDL::PP qawo_meat PDL::PP qawf_meat ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::INTEG ; =head1 NAME PDL::GSL::INTEG - PDL interface to numerical integration routines in GSL =head1 DESCRIPTION This is an interface to the numerical integration package present in the GNU Scientific Library, which is an implementation of QUADPACK. Functions are named B<gslinteg_{algorithm}> where {algorithm} is the QUADPACK naming convention. The available functions are: =over 3 =item gslinteg_qng: Non-adaptive Gauss-Kronrod integration =item gslinteg_qag: Adaptive integration =item gslinteg_qags: Adaptive integration with singularities =item gslinteg_qagp: Adaptive integration with known singular points =item gslinteg_qagi: Adaptive integration on infinite interval of the form (-\infty,\infty) =item gslinteg_qagiu: Adaptive integration on infinite interval of the form (a,\infty) =item gslinteg_qagil: Adaptive integration on infinite interval of the form (-\infty,b) =item gslinteg_qawc: Adaptive integration for Cauchy principal values =item gslinteg_qaws: Adaptive integration for singular functions =item gslinteg_qawo: Adaptive integration for oscillatory functions =item gslinteg_qawf: Adaptive integration for Fourier integrals =back Each algorithm computes an approximation to the integral, I, of the function f(x)w(x), where w(x) is a weight function (for general integrands w(x)=1). The user provides absolute and relative error bounds (epsabs,epsrel) which specify the following accuracy requirement: |RESULT - I| <= max(epsabs, epsrel |I|) The routines will fail to converge if the error bounds are too stringent, but always return the best approximation obtained up to that stage All functions return the result, and estimate of the absolute error and an error flag (which is zero if there were no problems). You are responsible for checking for any errors, no warnings are issued unless the option {Warn => 'y'} is specified in which case the reason of failure will be printed. You can nest integrals up to 20 levels. If you find yourself in the unlikely situation that you need more, you can change the value of 'max_nested_integrals' in the first line of the file 'FUNC.c' and recompile. =for ref Please check the GSL documentation for more information. =head1 SYNOPSIS use PDL; use PDL::GSL::INTEG; my $a = 1.2; my $b = 3.7; my $epsrel = 0; my $epsabs = 1e-6; # Non adaptive integration my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&myf,$a,$b,$epsrel,$epsabs); # Warnings on my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&myf,$a,$b,$epsrel,$epsabs,{Warn=>'y'}); # Adaptive integration with warnings on my $limit = 1000; my $key = 5; my ($res,$abserr,$ierr) = gslinteg_qag(\&myf,$a,$b,$epsrel, $epsabs,$limit,$key,{Warn=>'y'}); sub myf{ my ($x) = @_; return exp(-$x**2); } =head1 FUNCTIONS =cut sub gslinteg_qng{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$epsabs,$epsrel) = @_; barf 'Usage: gslinteg_qng($function_ref,$a,$b,$epsabs,$epsrel,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$neval,$ierr) = qng_meat($a,$b,$epsabs,$epsrel,$warn,$f); return ($res,$abserr,$ierr,$neval); } =head2 qng_meat =for sig Signature: (double a(); double b(); double epsabs(); double epsrel(); double [o] result(); double [o] abserr(); int [o] neval(); int [o] ierr(); int gslwarn(); SV* function) =for ref info not available =for bad qng_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qng_meat = \&PDL::qng_meat; sub gslinteg_qag{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$epsabs,$epsrel,$limit,$key) = @_; barf 'Usage: gslinteg_qag($function_ref,$a,$b,$epsabs,$epsrel,$limit,$key,[opt]) ' unless ($#_ == 6); my ($res,$abserr,$ierr) = qag_meat($a,$b,$epsabs,$epsrel,$limit,$key,$limit,$warn,$f); return ($res,$abserr,$ierr); } =head2 qag_meat =for sig Signature: (double a(); double b(); double epsabs();double epsrel(); int limit(); int key(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qag_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qag_meat = \&PDL::qag_meat; sub gslinteg_qags{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qags($function_ref,$a,$b,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 5); my ($res,$abserr,$ierr) = qags_meat($a,$b,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } =head2 qags_meat =for sig Signature: (double a(); double b(); double epsabs();double epsrel(); int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qags_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qags_meat = \&PDL::qags_meat; sub gslinteg_qagp{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$points,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagp($function_ref,$points,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagp_meat($points,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } =head2 qagp_meat =for sig Signature: (double pts(l); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagp_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qagp_meat = \&PDL::qagp_meat; sub gslinteg_qagi{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagi($function_ref,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 3); my ($res,$abserr,$ierr) = qagi_meat($epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } =head2 qagi_meat =for sig Signature: (double epsabs();double epsrel(); int limit(); double [o] result(); double [o] abserr(); int n(); int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagi_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qagi_meat = \&PDL::qagi_meat; sub gslinteg_qagiu{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagiu($function_ref,$a,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagiu_meat($a,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } =head2 qagiu_meat =for sig Signature: (double a(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagiu_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qagiu_meat = \&PDL::qagiu_meat; sub gslinteg_qagil{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$b,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagil($function_ref,$b,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagil_meat($b,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } =head2 qagil_meat =for sig Signature: (double b(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagil_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qagil_meat = \&PDL::qagil_meat; sub gslinteg_qawc{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$c,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qawc($function_ref,$a,$b,$c,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 6); my ($res,$abserr,$ierr) = qawc_meat($a,$b,$c,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } =head2 qawc_meat =for sig Signature: (double a(); double b(); double c(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qawc_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qawc_meat = \&PDL::qawc_meat; sub gslinteg_qaws{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$alpha,$beta,$mu,$nu,$a,$b,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qaws($function_ref,$alpha,$beta,$mu,$nu,$a,$b,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 9); my ($res,$abserr,$ierr) = qaws_meat($a,$b,$epsabs,$epsrel,$limit,$limit,$alpha,$beta,$mu,$nu,$warn,$f); return ($res,$abserr,$ierr); } =head2 qaws_meat =for sig Signature: (double a(); double b();double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n(); double alpha(); double beta(); int mu(); int nu();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qaws_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qaws_meat = \&PDL::qaws_meat; sub gslinteg_qawo{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$omega,$sincosopt,$a,$b,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qawo($function_ref,$omega,$sin_or_cos,$a,$b,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 7); my $OPTION_SIN_COS; if($sincosopt=~/cos/i){ $OPTION_SIN_COS = 0;} elsif($sincosopt=~/sin/i){ $OPTION_SIN_COS = 1;} else { barf("Error in argument 3 of function gslinteg_qawo: specify 'cos' or 'sin'\n");} my $L = $b - $a; my $nlevels = $limit; my ($res,$abserr,$ierr) = qawo_meat($a,$b,$epsabs,$epsrel,$limit,$limit,$OPTION_SIN_COS,$omega,$L,$nlevels,$warn,$f); return ($res,$abserr,$ierr); } =head2 qawo_meat =for sig Signature: (double a(); double b();double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n(); int sincosopt(); double omega(); double L(); int nlevels();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qawo_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qawo_meat = \&PDL::qawo_meat; sub gslinteg_qawf{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$omega,$sincosopt,$a,$epsabs,$limit) = @_; barf 'Usage: gslinteg_qawf($function_ref,$omega,$sin_or_cos,$a,$epsabs,$limit,[opt]) ' unless ($#_ == 5); my $OPTION_SIN_COS; if($sincosopt=~/cos/i){ $OPTION_SIN_COS = 0;} elsif($sincosopt=~/sin/i){ $OPTION_SIN_COS = 1;} else { barf("Error in argument 3 of function gslinteg_qawf: specify 'cos' or 'sin'\n");} my $nlevels = $limit; my ($res,$abserr,$ierr) = qawf_meat($a,$epsabs,$limit,$limit,$OPTION_SIN_COS,$omega,$nlevels,$warn,$f); return ($res,$abserr,$ierr); } =head2 qawf_meat =for sig Signature: (double a(); double epsabs();int limit(); double [o] result(); double [o] abserr();int n(); int sincosopt(); double omega(); int nlevels();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qawf_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *qawf_meat = \&PDL::qawf_meat; ; =head2 gslinteg_qng Non-adaptive Gauss-Kronrod integration This function applies the Gauss-Kronrod 10-point, 21-point, 43-point and 87-point integration rules in succession until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. It is meant for fast integration of smooth functions. It returns an array with the result, an estimate of the absolute error, an error flag and the number of function evaluations performed. =for usage Usage: ($res,$abserr,$ierr,$neval) = gslinteg_qng($function_ref,$a,$b, $epsrel,$epsabs,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&f,0,1,0,1e-9); # with warnings on my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&f,0,1,0,1e-9,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x**2.6)*log(1.0/$x); } =head2 gslinteg_qag Adaptive integration This function applies an integration rule adaptively until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. On each iteration the adaptive integration strategy bisects the interval with the largest error estimate; the maximum number of allowed subdivisions is given by the parameter $limit. The integration rule is determined by the value of $key, which has to be one of (1,2,3,4,5,6) and correspond to the 15, 21, 31, 41, 51 and 61 point Gauss-Kronrod rules respectively. It returns an array with the result, an estimate of the absolute error and an error flag. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qag($function_ref,$a,$b,$epsrel, $epsabs,$limit,$key,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qag(\&f,0,1,0,1e-10,1000,1); # with warnings on my ($res,$abserr,$ierr) = gslinteg_qag(\&f,0,1,0,1e-10,1000,1,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x**2.6)*log(1.0/$x); } =head2 gslinteg_qags Adaptive integration with singularities This function applies the Gauss-Kronrod 21-point integration rule adaptively until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. The algorithm is such that it accelerates the convergence of the integral in the presence of discontinuities and integrable singularities. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qags($function_ref,$a,$b,$epsrel, $epsabs,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qags(\&f,0,1,0,1e-10,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qags(\&f,0,1,0,1e-10,1000,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x)*log(1.0/$x); } =head2 gslinteg_qagp Adaptive integration with known singular points This function applies the adaptive integration algorithm used by gslinteg_qags taking into account the location of singular points until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. Singular points are supplied in the piddle $points, whose endpoints determine the integration range. So, for example, if the function has singular points at x_1 and x_2 and the integral is desired from a to b (a < x_1 < x_2 < b), $points = pdl(a,x_1,x_2,b). The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagp($function_ref,$points,$epsabs, $epsrel,$limit,[{Warn => $warn}]) =for example Example: my $points = pdl(0,1,sqrt(2),3); my ($res,$abserr,$ierr) = gslinteg_qagp(\&f,$points,0,1e-3,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagp(\&f,$points,0,1e-3,1000,{Warn => 'y'}); sub f{ my ($x) = @_; my $x2 = $x**2; my $x3 = $x**3; return $x3 * log(abs(($x2-1.0)*($x2-2.0))); } =head2 gslinteg_qagi Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (-\infty,+\infty) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagi($function_ref,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qagi(\&myfn,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagi(\&myfn,1e-7,0,1000,{Warn => 'y'}); sub myfn{ my ($x) = @_; return exp(-$x - $x*$x) ; } =head2 gslinteg_qagiu Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (a,+\infty) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagiu($function_ref,$a,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my $alfa = 1; my ($res,$abserr,$ierr) = gslinteg_qagiu(\&f,99.9,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagiu(\&f,99.9,1e-7,0,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if (($x==0) && ($alfa == 1)) {return 1;} if (($x==0) && ($alfa > 1)) {return 0;} return ($x**($alfa-1))/((1+10*$x)**2); } =head2 gslinteg_qagil Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (-\infty,b) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagl($function_ref,$b,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qagil(\&myfn,1.0,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagil(\&myfn,1.0,1e-7,0,1000,{Warn => 'y'}); sub myfn{ my ($x) = @_; return exp($x); } =head2 gslinteg_qawc Adaptive integration for Cauchy principal values This function computes the Cauchy principal value of the integral of f over (a,b), with a singularity at c, I = \int_a^b dx f(x)/(x - c). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawc($function_ref,$a,$b,$c,$epsabs,$epsrel,$limit) =for example Example: my ($res,$abserr,$ierr) = gslinteg_qawc(\&f,-1,5,0,0,1e-3,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qawc(\&f,-1,5,0,0,1e-3,1000,{Warn => 'y'}); sub f{ my ($x) = @_; return 1.0 / (5.0 * $x * $x * $x + 6.0) ; } =head2 gslinteg_qaws Adaptive integration for singular functions The algorithm in gslinteg_qaws is designed for integrands with algebraic-logarithmic singularities at the end-points of an integration region. Specifically, this function computes the integral given by I = \int_a^b dx f(x) (x-a)^alpha (b-x)^beta log^mu (x-a) log^nu (b-x). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawc($function_ref,$alpha,$beta,$mu,$nu,$a,$b, $epsabs,$epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qaws(\&f,0,0,1,0,0,1,0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qaws(\&f,0,0,1,0,0,1,0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if($x==0){return 0;} else{ my $u = log($x); my $v = 1 + $u*$u; return 1.0/($v*$v); } } =head2 gslinteg_qawo Adaptive integration for oscillatory functions This function uses an adaptive algorithm to compute the integral of f over (a,b) with the weight function sin(omega*x) or cos(omega*x) -- which of sine or cosine is used is determined by the parameter $opt ('cos' or 'sin'). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawo($function_ref,$omega,$sin_or_cos, $a,$b,$epsabs,$epsrel,$limit,[opt]) =for example Example: my $PI = 3.14159265358979323846264338328; my ($res,$abserr,$ierr) = PDL::GSL::INTEG::gslinteg_qawo(\&f,10*$PI,'sin',0,1,0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = PDL::GSL::INTEG::gslinteg_qawo(\&f,10*$PI,'sin',0,1,0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if($x==0){return 0;} else{ return log($x);} } =head2 gslinteg_qawf Adaptive integration for Fourier integrals This function attempts to compute a Fourier integral of the function f over the semi-infinite interval [a,+\infty). Specifically, it attempts tp compute I = \int_a^{+\infty} dx f(x)w(x), where w(x) is sin(omega*x) or cos(omega*x) -- which of sine or cosine is used is determined by the parameter $opt ('cos' or 'sin'). The integral is estimated within the desired absolute error limit $epsabs. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: gslinteg_qawf($function_ref,$omega,$sin_or_cos,$a,$epsabs,$limit,[opt]) =for example Example: my ($res,$abserr,$ierr) = gslinteg_qawf(\&f,$PI/2.0,'cos',0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qawf(\&f,$PI/2.0,'cos',0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if ($x == 0){return 0;} return 1.0/sqrt($x) } =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L<http://pdl.perl.org>). =head1 SEE ALSO L<PDL> The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2003,2005 Andres Jordan <ajordan@eso.org> All rights reserved. There is no warranty. You are allowed to redistribute this software documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL integration routines were written by Brian Gough. QUADPACK was written by Piessens, Doncker-Kapenga, Uberhuber and Kahaner. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSL/INTERP.pm���������������������������������������������������������������0000644�0601750�0601001�00000015716�13110402061�014273� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::INTERP; @EXPORT_OK = qw( ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::INTERP ; =head1 NAME PDL::GSL::INTERP - PDL interface to Interpolation routines in GSL =head1 DESCRIPTION This is an interface to the interpolation package present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::INTERP; my $x = sequence(10); my $y = exp($x); my $spl = PDL::GSL::INTERP->init('cspline',$x,$y); my $res = $spl->eval(4.35); $res = $spl->deriv(4.35); $res = $spl->deriv2(4.35); $res = $spl->integ(2.1,7.4); =head1 FUNCTIONS =head2 init() =for ref The init method initializes a new instance of INTERP. It needs as input an interpolation type and two piddles holding the x and y values to be interpolated. The GSL routines require that x be monotonically increasing and a quicksort is performed by default to ensure that. You can skip the quicksort by passing the option {Sort => 0}. The available interpolation types are : =over 2 =item linear =item polynomial =item cspline (natural cubic spline) =item cspline_periodic (periodic cubic spline) =item akima (natural akima spline) =item akima_periodic (periodic akima spline) =back Please check the GSL documentation for more information. =for usage Usage: $blessed_ref = PDL::GSL::INTERP->init($interp_method,$x,$y,$opt); =for example Example: $x = sequence(10); $y = exp($x); $spl = PDL::GSL::INTERP->init('cspline',$x,$y) $spl = PDL::GSL::INTERP->init('cspline',$x,$y,{Sort => 1}) #same as above # no sorting done on x, user is certain that x is monotonically increasing $spl = PDL::GSL::INTERP->init('cspline',$x,$y,{Sort => 0}); =head2 eval() =for ref The function eval returns the interpolating function at a given point. By default it will barf if you try to extrapolate, to comply silently if the point to be evaluated is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->eval($points,$opt); =for example Example: my $res = $spl->eval($x) $res = $spl->eval($x,{Extrapolate => 0}) #same as above # silently comply if $x is out of range $res = $spl->eval($x,{Extrapolate => 1}) =head2 deriv() =for ref The deriv function returns the derivative of the interpolating function at a given point. By default it will barf if you try to extrapolate, to comply silently if the point to be evaluated is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->deriv($points,$opt); =for example Example: my $res = $spl->deriv($x) $res = $spl->deriv($x,{Extrapolate => 0}) #same as above # silently comply if $x is out of range $res = $spl->deriv($x,{Extrapolate => 1}) =head2 deriv2() =for ref The deriv2 function returns the second derivative of the interpolating function at a given point. By default it will barf if you try to extrapolate, to comply silently if the point to be evaluated is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->deriv2($points,$opt); =for example Example: my $res = $spl->deriv2($x) $res = $spl->deriv2($x,{Extrapolate => 0}) #same as above # silently comply if $x is out of range $res = $spl->deriv2($x,{Extrapolate => 1}) =head2 integ() =for ref The integ function returns the integral of the interpolating function between two points. By default it will barf if you try to extrapolate, to comply silently if one of the integration limits is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->integ($a,$b,$opt); =for example Example: my $res = $spl->integ($a,$b) $res = $spl->integ($a,$b,{Extrapolate => 0}) #same as above # silently comply if $a or $b are out of range $res = $spl->eval($a,$b,{Extrapolate => 1}) =head1 BUGS Feedback is welcome. =head1 SEE ALSO L<PDL> The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2003 Andres Jordan <andresj@physics.rutgers.edu> All rights reserved. There is no warranty. You are allowed to redistribute this software/documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL interpolation module was written by Gerard Jungman. =cut sub init{ my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Sort => 1}; } my ($class,$type,$x,$y) = @_; if( (ref($x) ne 'PDL') || (ref($y) ne 'PDL') ){ barf("Have to pass piddles as arguments to init method\n"); } if($$opt{Sort} != 0){ my $idx = PDL::Ufunc::qsorti($x); $x = $x->index($idx); $y = $y->index($idx); } my $ene = nelem($x); my $obj1 = new_spline($type,$ene); my $obj2 = new_accel(); init_meat($x,$y,$$obj1); my @ret_a = ($obj1,$obj2); return bless(\@ret_a, $class); } *init_meat = \&PDL::GSL::INTERP::init_meat; sub eval{ my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_meat($x,$$s_obj,$$a_obj); } else{ return eval_meat_ext($x,$$s_obj,$$a_obj); } } *eval_meat = \&PDL::GSL::INTERP::eval_meat; *eval_meat_ext = \&PDL::GSL::INTERP::eval_meat_ext; sub deriv{ my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_deriv_meat($x,$$s_obj,$$a_obj); } else{ return eval_deriv_meat_ext($x,$$s_obj,$$a_obj); } } *eval_deriv_meat = \&PDL::GSL::INTERP::eval_deriv_meat; *eval_deriv_meat_ext = \&PDL::GSL::INTERP::eval_deriv_meat_ext; sub deriv2{ my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_deriv2_meat($x,$$s_obj,$$a_obj); } else{ return eval_deriv2_meat_ext($x,$$s_obj,$$a_obj); } } *eval_deriv2_meat = \&PDL::GSL::INTERP::eval_deriv2_meat; *eval_deriv2_meat_ext = \&PDL::GSL::INTERP::eval_deriv2_meat_ext; sub integ{ my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$a,$b) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_integ_meat($a,$b,$$s_obj,$$a_obj); } else{ return eval_integ_meat_ext($a,$b,$$s_obj,$$a_obj); } } *eval_integ_meat = \&PDL::GSL::INTERP::eval_integ_meat; *eval_integ_meat_ext = \&PDL::GSL::INTERP::eval_integ_meat_ext; ; # Exit with OK status 1; ��������������������������������������������������PDL-2.018/GENERATED/PDL/GSL/MROOT.pm����������������������������������������������������������������0000644�0601750�0601001�00000007643�13110402070�014172� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::MROOT; @EXPORT_OK = qw( gslmroot_fsolver PDL::PP fsolver_meat ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::MROOT ; =head1 NAME PDL::GSL::MROOT - PDL interface to multidimensional root-finding routines in GSL =head1 DESCRIPTION This is an interface to the multidimensional root-finding package present in the GNU Scientific Library. At the moment there is a single function B<gslmroot_fsolver> which provides an interface to the algorithms in the GSL library that do not use derivatives. =head1 SYNOPSIS use PDL; use PDL::GSL::MROOT; my $init = pdl (-10.00, -5.0); my $epsabs = 1e-7; $res = gslmroot_fsolver($init, \&rosenbrock, {Method => 0, EpsAbs => $epsabs}); sub rosenbrock{ my ($x) = @_; my $a = 1; my $b = 10; my $y = zeroes($x); my $y0 = $y->slice(0); $y0 .= $a * (1 - $x->slice(0)); my $y1 = $y->slice(1); $y1 .= $b * ($x->slice(1) - $x->slice(0)**2); return $y; } =head1 FUNCTIONS =cut sub gslmroot_fsolver{ my ($x, $f_vect) = @_; my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Method => 0, EpsAbs => 1e-3}; } if( (ref($x) ne 'PDL')){ barf("Have to pass piddle as first argument to fsolver\n"); } my $res = $x->copy; fsolver_meat($res, $$opt{'EpsAbs'}, $$opt{'Method'}, $f_vect); return $res; } =head2 fsolver_meat =for sig Signature: (double xfree(n); double epsabs(); int method(); SV* function1) =for ref info not available =for bad fsolver_meat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *fsolver_meat = \&PDL::GSLMROOT::fsolver_meat; ; =head2 gslmroot_fsolver Multidimensional root finder without using derivatives This function provides an interface to the multidimensional root finding algorithms in the GSL library. It takes a minimum of two argumennts: a piddle $init with an initial guess for the roots of the system and a reference to a function. The latter function must return a piddle whose i-th element is the i-th equation evaluated at the vector x (a piddle which is the sole input to this function). See the example in the Synopsis above for an illustration. The function returns a piddle with the roots for the system of equations. Two optional arguments can be specified as shown below. One is B<Method>, which can take the values 0,1,2,3. They correspond to the 'hybrids', 'hybrid', 'dnewton' and 'broyden' algorithms respectively (see GSL documentation for details). The other optional argument is B<Epsabs>, which sets the absolute accuracy to which the roots of the system of equations are required. The default value for Method is 0 ('hybrids' algorithm) and the default for Epsabs is 1e-3. =for usage Usage: $res = gslmroot_fsolver($init, $function_ref, [{Method => $method, Epsabs => $epsabs}]); =for ref =head1 SEE ALSO L<PDL> The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2006 Andres Jordan <ajordan@eso.org> and Simon Casassus <simon@das.uchile.cl> All rights reserved. There is no warranty. You are allowed to redistribute this software/documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; ���������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSL/RNG.pm������������������������������������������������������������������0000644�0601750�0601001�00000126326�13110402067�013726� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::RNG; @EXPORT_OK = qw( ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core qw/ zeroes long barf /; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::RNG ; =head1 NAME PDL::GSL::RNG - PDL interface to RNG and randist routines in GSL =head1 DESCRIPTION This is an interface to the rng and randist packages present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::RNG; $rng = PDL::GSL::RNG->new('taus'); $rng->set_seed(time()); $a=zeroes(5,5,5) $rng->get_uniform($a); # inplace $b=$rng->get_uniform(3,4,5); # creates new pdl =head1 FUNCTIONS =head2 new =for ref The new method initializes a new instance of the RNG. The available RNGs are: coveyou cmrg fishman18 fishman20 fishman2x gfsr4 knuthran knuthran2 knuthran2002 lecuyer21 minstd mrg mt19937 mt19937_1999 mt19937_1998 r250 ran0 ran1 ran2 ran3 rand rand48 random128_bsd random128_glibc2 random128_libc5 random256_bsd random256_glibc2 random256_libc5 random32_bsd random32_glibc2 random32_libc5 random64_bsd random64_glibc2 random64_libc5 random8_bsd random8_glibc2 random8_libc5 random_bsd random_glibc2 random_libc5 randu ranf ranlux ranlux389 ranlxd1 ranlxd2 ranlxs0 ranlxs1 ranlxs2 ranmar slatec taus taus2 taus113 transputer tt800 uni uni32 vax waterman14 zuf default The last one (default) uses the environment variable GSL_RNG_TYPE. Note that only a few of these rngs are recommended for general use. Please check the GSL documentation for more information. =for usage Usage: $blessed_ref = PDL::GSL::RNG->new($RNG_name); Example: =for example $rng = PDL::GSL::RNG->new('taus'); =head2 set_seed =for ref Sets the RNG seed. Usage: =for usage $rng->set_seed($integer); # or $rng = PDL::GSL::RNG->new('taus')->set_seed($integer); Example: =for example $rng->set_seed(666); =head2 min =for ref Return the minimum value generable by this RNG. Usage: =for usage $integer = $rng->min(); Example: =for example $min = $rng->min(); $max = $rng->max(); =head2 max =for ref Return the maximum value generable by the RNG. Usage: =for usage $integer = $rng->max(); Example: =for example $min = $rng->min(); $max = $rng->max(); =head2 name =for ref Returns the name of the RNG. Usage: =for usage $string = $rng->name(); Example: =for example $name = $rng->name(); =head2 get =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get() returns integer values between a minimum and a maximum specific to every RNG. Usage: =for usage $piddle = $rng->get($list_of_integers) $rng->get($piddle); Example: =for example $a = zeroes 5,6; $o = $rng->get(10,10); $rng->get($a); =head2 get_int =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get_int() returns integer values between 0 and $max. Usage: =for usage $piddle = $rng->get($max, $list_of_integers) $rng->get($max, $piddle); Example: =for example $a = zeroes 5,6; $max=100; $o = $rng->get(10,10); $rng->get($a); =head2 get_uniform =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get_uniform() returns values 0<=x<1, Usage: =for usage $piddle = $rng->get_uniform($list_of_integers) $rng->get_uniform($piddle); Example: =for example $a = zeroes 5,6; $max=100; $o = $rng->get_uniform(10,10); $rng->get_uniform($a); =head2 get_uniform_pos =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get_uniform_pos() returns values 0<x<1, Usage: =for usage $piddle = $rng->get_uniform_pos($list_of_integers) $rng->get_uniform_pos($piddle); Example: =for example $a = zeroes 5,6; $o = $rng->get_uniform_pos(10,10); $rng->get_uniform_pos($a); =head2 ran_shuffle =for ref Shuffles values in piddle Usage: =for usage $rng->ran_shuffle($piddle); =head2 ran_shuffle_vec =for ref Shuffles values in piddle Usage: =for usage $rng->ran_shuffle_vec(@vec); =head2 ran_choose =for ref Chooses values from C<$inpiddle> to C<$outpiddle>. Usage: =for usage $rng->ran_choose($inpiddle,$outpiddle); =head2 ran_choose_vec =for ref Chooses C<$n> values from C<@vec>. Usage: =for usage @chosen = $rng->ran_choose_vec($n,@vec); =head2 ran_gaussian =for ref Fills output piddle with random values from Gaussian distribution with mean zero and standard deviation C<$sigma>. Usage: =for usage $piddle = $rng->ran_gaussian($sigma,[list of integers = output piddle dims]); $rng->ran_gaussian($sigma, $output_piddle); Example: =for example $o = $rng->ran_gaussian($sigma,10,10); $rng->ran_gaussian($sigma,$a); =head2 ran_gaussian_var =for ref This method is similar to L<ran_gaussian|/ran_gaussian> except that it takes the parameters of the distribution as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gaussian_var($sigma_piddle); $rng->ran_gaussian_var($sigma_piddle, $output_piddle); Example: =for example $sigma_pdl = rvals zeroes 11,11; $o = $rng->ran_gaussian_var($sigma_pdl); =head2 ran_additive_gaussian =for ref Add Gaussian noise of given sigma to a piddle. Usage: =for usage $rng->ran_additive_gaussian($sigma,$piddle); Example: =for example $rng->ran_additive_gaussian(1,$image); =head2 ran_bivariate_gaussian =for ref Generates C<$n> bivariate gaussian random deviates. Usage: =for usage $piddle = $rng->ran_bivariate_gaussian($sigma_x,$sigma_y,$rho,$n); Example: =for example $o = $rng->ran_bivariate_gaussian(1,2,0.5,1000); =head2 ran_poisson =for ref Fills output piddle by with random integer values from the Poisson distribution with mean C<$mu>. Usage: =for usage $piddle = $rng->ran_poisson($mu,[list of integers = output piddle dims]); $rng->ran_poisson($mu,$output_piddle); =head2 ran_poisson_var =for ref Similar to L<ran_poisson|/ran_poisson> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_poisson_var($mu_piddle); =head2 ran_additive_poisson =for ref Add Poisson noise of given C<$mu> to a C<$piddle>. Usage: =for usage $rng->ran_additive_poisson($mu,$piddle); Example: =for example $rng->ran_additive_poisson(1,$image); =head2 ran_feed_poisson =for ref This method simulates shot noise, taking the values of piddle as values for C<$mu> to be fed in the poissonian RNG. Usage: =for usage $rng->ran_feed_poisson($piddle); Example: =for example $rng->ran_feed_poisson($image); =head2 ran_bernoulli =for ref Fills output piddle with random values 0 or 1, the result of a Bernoulli trial with probability C<$p>. Usage: =for usage $piddle = $rng->ran_bernoulli($p,[list of integers = output piddle dims]); $rng->ran_bernoulli($p,$output_piddle); =head2 ran_bernoulli_var =for ref Similar to L<ran_bernoulli|/ran_bernoulli> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_bernoulli_var($p_piddle); =head2 ran_beta =for ref Fills output piddle with random variates from the beta distribution with parameters C<$a> and C<$b>. Usage: =for usage $piddle = $rng->ran_beta($a,$b,[list of integers = output piddle dims]); $rng->ran_beta($a,$b,$output_piddle); =head2 ran_beta_var =for ref Similar to L<ran_beta|/ran_beta> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_beta_var($a_piddle, $b_piddle); =head2 ran_binomial =for ref Fills output piddle with random integer values from the binomial distribution, the number of successes in C<$n> independent trials with probability C<$p>. Usage: =for usage $piddle = $rng->ran_binomial($p,$n,[list of integers = output piddle dims]); $rng->ran_binomial($p,$n,$output_piddle); =head2 ran_binomial_var =for ref Similar to L<ran_binomial|/ran_binomial> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_binomial_var($p_piddle, $n_piddle); =head2 ran_cauchy =for ref Fills output piddle with random variates from the Cauchy distribution with scale parameter C<$a>. Usage: =for usage $piddle = $rng->ran_cauchy($a,[list of integers = output piddle dims]); $rng->ran_cauchy($a,$output_piddle); =head2 ran_cauchy_var =for ref Similar to L<ran_cauchy|/ran_cauchy> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_cauchy_var($a_piddle); =head2 ran_chisq =for ref Fills output piddle with random variates from the chi-squared distribution with C<$nu> degrees of freedom. Usage: =for usage $piddle = $rng->ran_chisq($nu,[list of integers = output piddle dims]); $rng->ran_chisq($nu,$output_piddle); =head2 ran_chisq_var =for ref Similar to L<ran_chisq|/ran_chisq> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_chisq_var($nu_piddle); =head2 ran_exponential =for ref Fills output piddle with random variates from the exponential distribution with mean C<$mu>. Usage: =for usage $piddle = $rng->ran_exponential($mu,[list of integers = output piddle dims]); $rng->ran_exponential($mu,$output_piddle); =head2 ran_exponential_var =for ref Similar to L<ran_exponential|/ran_exponential> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_exponential_var($mu_piddle); =head2 ran_exppow =for ref Fills output piddle with random variates from the exponential power distribution with scale parameter C<$a> and exponent C<$b>. Usage: =for usage $piddle = $rng->ran_exppow($mu,$a,[list of integers = output piddle dims]); $rng->ran_exppow($mu,$a,$output_piddle); =head2 ran_exppow_var =for ref Similar to L<ran_exppow|/ran_exppow> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_exppow_var($mu_piddle, $a_piddle); =head2 ran_fdist =for ref Fills output piddle with random variates from the F-distribution with degrees of freedom C<$nu1> and C<$nu2>. Usage: =for usage $piddle = $rng->ran_fdist($nu1, $nu2,[list of integers = output piddle dims]); $rng->ran_fdist($nu1, $nu2,$output_piddle); =head2 ran_fdist_var =for ref Similar to L<ran_fdist|/ran_fdist> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_fdist_var($nu1_piddle, $nu2_piddle); =head2 ran_flat =for ref Fills output piddle with random variates from the flat (uniform) distribution from C<$a> to C<$b>. Usage: =for usage $piddle = $rng->ran_flat($a,$b,[list of integers = output piddle dims]); $rng->ran_flat($a,$b,$output_piddle); =head2 ran_flat_var =for ref Similar to L<ran_flat|/ran_flat> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_flat_var($a_piddle, $b_piddle); =head2 ran_gamma =for ref Fills output piddle with random variates from the gamma distribution. Usage: =for usage $piddle = $rng->ran_gamma($a,$b,[list of integers = output piddle dims]); $rng->ran_gamma($a,$b,$output_piddle); =head2 ran_gamma_var =for ref Similar to L<ran_gamma|/ran_gamma> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gamma_var($a_piddle, $b_piddle); =head2 ran_geometric =for ref Fills output piddle with random integer values from the geometric distribution, the number of independent trials with probability C<$p> until the first success. Usage: =for usage $piddle = $rng->ran_geometric($p,[list of integers = output piddle dims]); $rng->ran_geometric($p,$output_piddle); =head2 ran_geometric_var =for ref Similar to L<ran_geometric|/ran_geometric> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_geometric_var($p_piddle); =head2 ran_gumbel1 =for ref Fills output piddle with random variates from the Type-1 Gumbel distribution. Usage: =for usage $piddle = $rng->ran_gumbel1($a,$b,[list of integers = output piddle dims]); $rng->ran_gumbel1($a,$b,$output_piddle); =head2 ran_gumbel1_var =for ref Similar to L<ran_gumbel1|/ran_gumbel1> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gumbel1_var($a_piddle, $b_piddle); =head2 ran_gumbel2 =for ref Fills output piddle with random variates from the Type-2 Gumbel distribution. Usage: =for usage $piddle = $rng->ran_gumbel2($a,$b,[list of integers = output piddle dims]); $rng->ran_gumbel2($a,$b,$output_piddle); =head2 ran_gumbel2_var =for ref Similar to L<ran_gumbel2|/ran_gumbel2> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gumbel2_var($a_piddle, $b_piddle); =head2 ran_hypergeometric =for ref Fills output piddle with random integer values from the hypergeometric distribution. If a population contains C<$n1> elements of type 1 and C<$n2> elements of type 2 then the hypergeometric distribution gives the probability of obtaining C<$x> elements of type 1 in C<$t> samples from the population without replacement. Usage: =for usage $piddle = $rng->ran_hypergeometric($n1, $n2, $t,[list of integers = output piddle dims]); $rng->ran_hypergeometric($n1, $n2, $t,$output_piddle); =head2 ran_hypergeometric_var =for ref Similar to L<ran_hypergeometric|/ran_hypergeometric> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_hypergeometric_var($n1_piddle, $n2_piddle, $t_piddle); =head2 ran_laplace =for ref Fills output piddle with random variates from the Laplace distribution with width C<$a>. Usage: =for usage $piddle = $rng->ran_laplace($a,[list of integers = output piddle dims]); $rng->ran_laplace($a,$output_piddle); =head2 ran_laplace_var =for ref Similar to L<ran_laplace|/ran_laplace> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_laplace_var($a_piddle); =head2 ran_levy =for ref Fills output piddle with random variates from the Levy symmetric stable distribution with scale C<$c> and exponent C<$alpha>. Usage: =for usage $piddle = $rng->ran_levy($mu,$a,[list of integers = output piddle dims]); $rng->ran_levy($mu,$a,$output_piddle); =head2 ran_levy_var =for ref Similar to L<ran_levy|/ran_levy> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_levy_var($mu_piddle, $a_piddle); =head2 ran_logarithmic =for ref Fills output piddle with random integer values from the logarithmic distribution. Usage: =for usage $piddle = $rng->ran_logarithmic($p,[list of integers = output piddle dims]); $rng->ran_logarithmic($p,$output_piddle); =head2 ran_logarithmic_var =for ref Similar to L<ran_logarithmic|/ran_logarithmic> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_logarithmic_var($p_piddle); =head2 ran_logistic =for ref Fills output piddle with random random variates from the logistic distribution. Usage: =for usage $piddle = $rng->ran_logistic($m,[list of integers = output piddle dims]u) $rng->ran_logistic($m,$output_piddle) =head2 ran_logistic_var =for ref Similar to L<ran_logistic|/ran_logistic> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_logistic_var($m_piddle); =head2 ran_lognormal =for ref Fills output piddle with random variates from the lognormal distribution with parameters C<$mu> (location) and C<$sigma> (scale). Usage: =for usage $piddle = $rng->ran_lognormal($mu,$sigma,[list of integers = output piddle dims]); $rng->ran_lognormal($mu,$sigma,$output_piddle); =head2 ran_lognormal_var =for ref Similar to L<ran_lognormal|/ran_lognormal> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_lognormal_var($mu_piddle, $sigma_piddle); =head2 ran_negative_binomial =for ref Fills output piddle with random integer values from the negative binomial distribution, the number of failures occurring before C<$n> successes in independent trials with probability C<$p> of success. Note that C<$n> is not required to be an integer. Usage: =for usage $piddle = $rng->ran_negative_binomial($p,$n,[list of integers = output piddle dims]); $rng->ran_negative_binomial($p,$n,$output_piddle); =head2 ran_negative_binomial_var =for ref Similar to L<ran_negative_binomial|/ran_negative_binomial> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_negative_binomial_var($p_piddle, $n_piddle); =head2 ran_pareto =for ref Fills output piddle with random variates from the Pareto distribution of order C<$a> and scale C<$b>. Usage: =for usage $piddle = $rng->ran_pareto($a,$b,[list of integers = output piddle dims]); $rng->ran_pareto($a,$b,$output_piddle); =head2 ran_pareto_var =for ref Similar to L<ran_pareto|/ran_pareto> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_pareto_var($a_piddle, $b_piddle); =head2 ran_pascal =for ref Fills output piddle with random integer values from the Pascal distribution. The Pascal distribution is simply a negative binomial distribution (see L<ran_negative_binomial|/ran_negative_binomial>) with an integer value of C<$n>. Usage: =for usage $piddle = $rng->ran_pascal($p,$n,[list of integers = output piddle dims]); $rng->ran_pascal($p,$n,$output_piddle); =head2 ran_pascal_var =for ref Similar to L<ran_pascal|/ran_pascal> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_pascal_var($p_piddle, $n_piddle); =head2 ran_rayleigh =for ref Fills output piddle with random variates from the Rayleigh distribution with scale parameter C<$sigma>. Usage: =for usage $piddle = $rng->ran_rayleigh($sigma,[list of integers = output piddle dims]); $rng->ran_rayleigh($sigma,$output_piddle); =head2 ran_rayleigh_var =for ref Similar to L<ran_rayleigh|/ran_rayleigh> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_rayleigh_var($sigma_piddle); =head2 ran_rayleigh_tail =for ref Fills output piddle with random variates from the tail of the Rayleigh distribution with scale parameter C<$sigma> and a lower limit of C<$a>. Usage: =for usage $piddle = $rng->ran_rayleigh_tail($a,$sigma,[list of integers = output piddle dims]); $rng->ran_rayleigh_tail($a,$sigma,$output_piddle); =head2 ran_rayleigh_tail_var =for ref Similar to L<ran_rayleigh_tail|/ran_rayleigh_tail> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_rayleigh_tail_var($a_piddle, $sigma_piddle); =head2 ran_tdist =for ref Fills output piddle with random variates from the t-distribution (AKA Student's t-distribution) with C<$nu> degrees of freedom. Usage: =for usage $piddle = $rng->ran_tdist($nu,[list of integers = output piddle dims]); $rng->ran_tdist($nu,$output_piddle); =head2 ran_tdist_var =for ref Similar to L<ran_tdist|/ran_tdist> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_tdist_var($nu_piddle); =head2 ran_ugaussian_tail =for ref Fills output piddle with random variates from the upper tail of a Gaussian distribution with C<standard deviation = 1> (AKA unit Gaussian distribution). Usage: =for usage $piddle = $rng->ran_ugaussian_tail($tail,[list of integers = output piddle dims]); $rng->ran_ugaussian_tail($tail,$output_piddle); =head2 ran_ugaussian_tail_var =for ref Similar to L<ran_ugaussian_tail|/ran_ugaussian_tail> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_ugaussian_tail_var($tail_piddle); =head2 ran_weibull =for ref Fills output piddle with random variates from the Weibull distribution. Usage: =for usage $piddle = $rng->ran_weibull($mu,$a,[list of integers = output piddle dims]); $rng->ran_weibull($mu,$a,$output_piddle); =head2 ran_weibull_var =for ref Similar to L<ran_weibull|/ran_weibull> except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_weibull_var($mu_piddle, $a_piddle); =head2 ran_dir =for ref Returns C<$n> random vectors in C<$ndim> dimensions. Usage: =for usage $piddle = $rng->ran_dir($ndim,$n); Example: =for example $o = $rng->ran_dir($ndim,$n); =head2 ran_discrete_preproc =for ref This method returns a handle that must be used when calling L<ran_discrete|/ran_discrete>. You specify the probability of the integer number that are returned by L<ran_discrete|/ran_discrete>. Usage: =for usage $discrete_dist_handle = $rng->ran_discrete_preproc($double_piddle_prob); Example: =for example $prob = pdl [0.1,0.3,0.6]; $ddh = $rng->ran_discrete_preproc($prob); $o = $rng->ran_discrete($discrete_dist_handle,100); =head2 ran_discrete =for ref Is used to get the desired samples once a proper handle has been enstablished (see ran_discrete_preproc()). Usage: =for usage $piddle = $rng->ran_discrete($discrete_dist_handle,$num); Example: =for example $prob = pdl [0.1,0.3,0.6]; $ddh = $rng->ran_discrete_preproc($prob); $o = $rng->ran_discrete($discrete_dist_handle,100); =head2 ran_ver =for ref Returns a piddle with C<$n> values generated by the Verhulst map from C<$x0> and parameter C<$r>. Usage: =for usage $rng->ran_ver($x0, $r, $n); =head2 ran_caos =for ref Returns values from Verhuls map with C<$r=4.0> and randomly chosen C<$x0>. The values are scaled by C<$m>. Usage: =for usage $rng->ran_caos($m,$n); =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L<http://pdl.perl.org/>). =head1 SEE ALSO L<PDL> The GSL documentation is online at L<http://www.gnu.org/software/gsl/manual/html_node/> =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> Docs mangled by C. Soeller. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL RNG and randist modules were written by James Theiler. =cut use strict; # PDL::GSL::RNG::nullcreate just creates a null PDL. Used # for the GSL functions that create PDLs sub nullcreate{ my ($type,$arg) = @_; PDL->nullcreate($arg); } sub get_uniform { my ($obj,@var) = @_;if (ref($var[0]) eq 'PDL') { gsl_get_uniform_meat($var[0],$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_uniform_meat($p,$$obj); return $p; } } sub get_uniform_pos { my ($obj,@var) = @_;if (ref($var[0]) eq 'PDL') { gsl_get_uniform_pos_meat($var[0],$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_uniform_pos_meat($p,$$obj); return $p; } } sub get { my ($obj,@var) = @_;if (ref($var[0]) eq 'PDL') { gsl_get_meat($var[0],$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_meat($p,$$obj); return $p; } } sub get_int { my ($obj,$n,@var) = @_;if (!($n>0)) {barf("first parameter must be an int >0")};if (ref($var[0]) eq 'PDL') { gsl_get_int_meat($var[0],$n,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_int_meat($p,$n,$$obj); return $p; } } *gsl_get_uniform_meat = \&PDL::GSL::RNG::gsl_get_uniform_meat; *gsl_get_uniform_pos_meat = \&PDL::GSL::RNG::gsl_get_uniform_pos_meat; *gsl_get_meat = \&PDL::GSL::RNG::gsl_get_meat; *gsl_get_int_meat = \&PDL::GSL::RNG::gsl_get_int_meat; *ran_gaussian_meat = \&PDL::GSL::RNG::ran_gaussian_meat; sub ran_gaussian { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gaussian_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gaussian_meat($p,$a,$$obj); return $p; } } *ran_gaussian_var_meat = \&PDL::GSL::RNG::ran_gaussian_var_meat; sub ran_gaussian_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_gaussian_var_meat(@var,$$obj); } *ran_ugaussian_tail_meat = \&PDL::GSL::RNG::ran_ugaussian_tail_meat; sub ran_ugaussian_tail { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_ugaussian_tail_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_ugaussian_tail_meat($p,$a,$$obj); return $p; } } *ran_ugaussian_tail_var_meat = \&PDL::GSL::RNG::ran_ugaussian_tail_var_meat; sub ran_ugaussian_tail_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_ugaussian_tail_var_meat(@var,$$obj); } *ran_exponential_meat = \&PDL::GSL::RNG::ran_exponential_meat; sub ran_exponential { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_exponential_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_exponential_meat($p,$a,$$obj); return $p; } } *ran_exponential_var_meat = \&PDL::GSL::RNG::ran_exponential_var_meat; sub ran_exponential_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_exponential_var_meat(@var,$$obj); } *ran_laplace_meat = \&PDL::GSL::RNG::ran_laplace_meat; sub ran_laplace { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_laplace_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_laplace_meat($p,$a,$$obj); return $p; } } *ran_laplace_var_meat = \&PDL::GSL::RNG::ran_laplace_var_meat; sub ran_laplace_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_laplace_var_meat(@var,$$obj); } *ran_exppow_meat = \&PDL::GSL::RNG::ran_exppow_meat; sub ran_exppow { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_exppow_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_exppow_meat($p,$a,$b,$$obj); return $p; } } *ran_exppow_var_meat = \&PDL::GSL::RNG::ran_exppow_var_meat; sub ran_exppow_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_exppow_var_meat(@var,$$obj); } *ran_cauchy_meat = \&PDL::GSL::RNG::ran_cauchy_meat; sub ran_cauchy { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_cauchy_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_cauchy_meat($p,$a,$$obj); return $p; } } *ran_cauchy_var_meat = \&PDL::GSL::RNG::ran_cauchy_var_meat; sub ran_cauchy_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_cauchy_var_meat(@var,$$obj); } *ran_rayleigh_meat = \&PDL::GSL::RNG::ran_rayleigh_meat; sub ran_rayleigh { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_rayleigh_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_rayleigh_meat($p,$a,$$obj); return $p; } } *ran_rayleigh_var_meat = \&PDL::GSL::RNG::ran_rayleigh_var_meat; sub ran_rayleigh_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_rayleigh_var_meat(@var,$$obj); } *ran_rayleigh_tail_meat = \&PDL::GSL::RNG::ran_rayleigh_tail_meat; sub ran_rayleigh_tail { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_rayleigh_tail_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_rayleigh_tail_meat($p,$a,$b,$$obj); return $p; } } *ran_rayleigh_tail_var_meat = \&PDL::GSL::RNG::ran_rayleigh_tail_var_meat; sub ran_rayleigh_tail_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_rayleigh_tail_var_meat(@var,$$obj); } *ran_levy_meat = \&PDL::GSL::RNG::ran_levy_meat; sub ran_levy { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_levy_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_levy_meat($p,$a,$b,$$obj); return $p; } } *ran_levy_var_meat = \&PDL::GSL::RNG::ran_levy_var_meat; sub ran_levy_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_levy_var_meat(@var,$$obj); } *ran_gamma_meat = \&PDL::GSL::RNG::ran_gamma_meat; sub ran_gamma { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gamma_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gamma_meat($p,$a,$b,$$obj); return $p; } } *ran_gamma_var_meat = \&PDL::GSL::RNG::ran_gamma_var_meat; sub ran_gamma_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_gamma_var_meat(@var,$$obj); } *ran_flat_meat = \&PDL::GSL::RNG::ran_flat_meat; sub ran_flat { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_flat_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_flat_meat($p,$a,$b,$$obj); return $p; } } *ran_flat_var_meat = \&PDL::GSL::RNG::ran_flat_var_meat; sub ran_flat_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_flat_var_meat(@var,$$obj); } *ran_lognormal_meat = \&PDL::GSL::RNG::ran_lognormal_meat; sub ran_lognormal { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_lognormal_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_lognormal_meat($p,$a,$b,$$obj); return $p; } } *ran_lognormal_var_meat = \&PDL::GSL::RNG::ran_lognormal_var_meat; sub ran_lognormal_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_lognormal_var_meat(@var,$$obj); } *ran_chisq_meat = \&PDL::GSL::RNG::ran_chisq_meat; sub ran_chisq { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_chisq_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_chisq_meat($p,$a,$$obj); return $p; } } *ran_chisq_var_meat = \&PDL::GSL::RNG::ran_chisq_var_meat; sub ran_chisq_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_chisq_var_meat(@var,$$obj); } *ran_fdist_meat = \&PDL::GSL::RNG::ran_fdist_meat; sub ran_fdist { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_fdist_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_fdist_meat($p,$a,$b,$$obj); return $p; } } *ran_fdist_var_meat = \&PDL::GSL::RNG::ran_fdist_var_meat; sub ran_fdist_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_fdist_var_meat(@var,$$obj); } *ran_tdist_meat = \&PDL::GSL::RNG::ran_tdist_meat; sub ran_tdist { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_tdist_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_tdist_meat($p,$a,$$obj); return $p; } } *ran_tdist_var_meat = \&PDL::GSL::RNG::ran_tdist_var_meat; sub ran_tdist_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_tdist_var_meat(@var,$$obj); } *ran_beta_meat = \&PDL::GSL::RNG::ran_beta_meat; sub ran_beta { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_beta_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_beta_meat($p,$a,$b,$$obj); return $p; } } *ran_beta_var_meat = \&PDL::GSL::RNG::ran_beta_var_meat; sub ran_beta_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_beta_var_meat(@var,$$obj); } *ran_logistic_meat = \&PDL::GSL::RNG::ran_logistic_meat; sub ran_logistic { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_logistic_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_logistic_meat($p,$a,$$obj); return $p; } } *ran_logistic_var_meat = \&PDL::GSL::RNG::ran_logistic_var_meat; sub ran_logistic_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_logistic_var_meat(@var,$$obj); } *ran_pareto_meat = \&PDL::GSL::RNG::ran_pareto_meat; sub ran_pareto { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_pareto_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_pareto_meat($p,$a,$b,$$obj); return $p; } } *ran_pareto_var_meat = \&PDL::GSL::RNG::ran_pareto_var_meat; sub ran_pareto_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_pareto_var_meat(@var,$$obj); } *ran_weibull_meat = \&PDL::GSL::RNG::ran_weibull_meat; sub ran_weibull { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_weibull_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_weibull_meat($p,$a,$b,$$obj); return $p; } } *ran_weibull_var_meat = \&PDL::GSL::RNG::ran_weibull_var_meat; sub ran_weibull_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_weibull_var_meat(@var,$$obj); } *ran_gumbel1_meat = \&PDL::GSL::RNG::ran_gumbel1_meat; sub ran_gumbel1 { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gumbel1_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gumbel1_meat($p,$a,$b,$$obj); return $p; } } *ran_gumbel1_var_meat = \&PDL::GSL::RNG::ran_gumbel1_var_meat; sub ran_gumbel1_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_gumbel1_var_meat(@var,$$obj); } *ran_gumbel2_meat = \&PDL::GSL::RNG::ran_gumbel2_meat; sub ran_gumbel2 { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gumbel2_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gumbel2_meat($p,$a,$b,$$obj); return $p; } } *ran_gumbel2_var_meat = \&PDL::GSL::RNG::ran_gumbel2_var_meat; sub ran_gumbel2_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_gumbel2_var_meat(@var,$$obj); } *ran_poisson_meat = \&PDL::GSL::RNG::ran_poisson_meat; sub ran_poisson { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_poisson_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_poisson_meat($p,$a,$$obj); return $p; } } *ran_poisson_var_meat = \&PDL::GSL::RNG::ran_poisson_var_meat; sub ran_poisson_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_poisson_var_meat(@var,$$obj); } *ran_bernoulli_meat = \&PDL::GSL::RNG::ran_bernoulli_meat; sub ran_bernoulli { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_bernoulli_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_bernoulli_meat($p,$a,$$obj); return $p; } } *ran_bernoulli_var_meat = \&PDL::GSL::RNG::ran_bernoulli_var_meat; sub ran_bernoulli_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_bernoulli_var_meat(@var,$$obj); } *ran_binomial_meat = \&PDL::GSL::RNG::ran_binomial_meat; sub ran_binomial { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_binomial_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_binomial_meat($p,$a,$b,$$obj); return $p; } } *ran_binomial_var_meat = \&PDL::GSL::RNG::ran_binomial_var_meat; sub ran_binomial_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_binomial_var_meat(@var,$$obj); } *ran_negative_binomial_meat = \&PDL::GSL::RNG::ran_negative_binomial_meat; sub ran_negative_binomial { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_negative_binomial_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_negative_binomial_meat($p,$a,$b,$$obj); return $p; } } *ran_negative_binomial_var_meat = \&PDL::GSL::RNG::ran_negative_binomial_var_meat; sub ran_negative_binomial_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_negative_binomial_var_meat(@var,$$obj); } *ran_pascal_meat = \&PDL::GSL::RNG::ran_pascal_meat; sub ran_pascal { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_pascal_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_pascal_meat($p,$a,$b,$$obj); return $p; } } *ran_pascal_var_meat = \&PDL::GSL::RNG::ran_pascal_var_meat; sub ran_pascal_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_pascal_var_meat(@var,$$obj); } *ran_geometric_meat = \&PDL::GSL::RNG::ran_geometric_meat; sub ran_geometric { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_geometric_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_geometric_meat($p,$a,$$obj); return $p; } } *ran_geometric_var_meat = \&PDL::GSL::RNG::ran_geometric_var_meat; sub ran_geometric_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_geometric_var_meat(@var,$$obj); } *ran_hypergeometric_meat = \&PDL::GSL::RNG::ran_hypergeometric_meat; sub ran_hypergeometric { my ($obj,$a,$b,$c,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_hypergeometric_meat($var[0],$a,$b,$c,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_hypergeometric_meat($p,$a,$b,$c,$$obj); return $p; } } *ran_hypergeometric_var_meat = \&PDL::GSL::RNG::ran_hypergeometric_var_meat; sub ran_hypergeometric_var { my ($obj,@var) = @_; if (scalar(@var) != 3) {barf("Bad number of parameters!");} return ran_hypergeometric_var_meat(@var,$$obj); } *ran_logarithmic_meat = \&PDL::GSL::RNG::ran_logarithmic_meat; sub ran_logarithmic { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_logarithmic_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_logarithmic_meat($p,$a,$$obj); return $p; } } *ran_logarithmic_var_meat = \&PDL::GSL::RNG::ran_logarithmic_var_meat; sub ran_logarithmic_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_logarithmic_var_meat(@var,$$obj); } *ran_additive_gaussian_meat = \&PDL::GSL::RNG::ran_additive_gaussian_meat; sub ran_additive_gaussian { my ($obj,$sigma,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_additive_gaussian_meat($var[0],$sigma,$$obj); return $var[0]; } else { barf("In additive gaussian mode you must specify a piddle!"); } } *ran_additive_poisson_meat = \&PDL::GSL::RNG::ran_additive_poisson_meat; sub ran_additive_poisson { my ($obj,$sigma,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_additive_poisson_meat($var[0],$sigma,$$obj); return $var[0]; } else { barf("In additive poisson mode you must specify a piddle!"); } } *ran_feed_poisson_meat = \&PDL::GSL::RNG::ran_feed_poisson_meat; sub ran_feed_poisson { my ($obj,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_feed_poisson_meat($var[0],$$obj); return $var[0]; } else { barf("In poisson mode you must specify a piddle!"); } } *ran_bivariate_gaussian_meat = \&PDL::GSL::RNG::ran_bivariate_gaussian_meat; sub ran_bivariate_gaussian { my ($obj,$sigma_x,$sigma_y,$rho,$n) = @_; if ($n>0) { my $p = zeroes(2,$n); ran_bivariate_gaussian_meat($p,$sigma_x,$sigma_y,$rho,$$obj); return $p; } else { barf("Not enough parameters for gaussian bivariate!"); } } *ran_dir_2d_meat = \&PDL::GSL::RNG::ran_dir_2d_meat; *ran_dir_3d_meat = \&PDL::GSL::RNG::ran_dir_3d_meat; *ran_dir_nd_meat = \&PDL::GSL::RNG::ran_dir_nd_meat; sub ran_dir { my ($obj,$ndim,$n) = @_; if ($n>0) { my $p = zeroes($ndim,$n); if ($ndim==2) { ran_dir_2d_meat($p,$$obj); } elsif ($ndim==3) { ran_dir_3d_meat($p,$$obj); } elsif ($ndim>=4 && $ndim<=100) { ran_dir_nd_meat($p,$ndim,$$obj); } else { barf("Bad number of dimensions!"); } return $p; } else { barf("Not enough parameters for random vectors!"); } } *ran_discrete_meat = \&PDL::GSL::RNG::ran_discrete_meat; sub ran_discrete { my ($obj, $rdt, @var) = @_; if (ref($var[0]) eq 'PDL') { ran_discrete_meat($var[0], $$rdt, $$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_discrete_meat($p, $$rdt, $$obj); return $p; } } sub ran_shuffle_vec { my ($obj,@in) = @_; my (@out,$i,$p); $p = long [0..$#in]; $obj->ran_shuffle($p); for($i=0;$i<scalar(@in);$i++) { $out[$p->at($i)]=$in[$i]; } return @out; } sub ran_choose_vec { my ($obj,$nout,@in) = @_; my (@out,$i,$pin,$pout); $pin = long [0..$#in]; $pout = long [0..($nout-1)]; $obj->ran_choose($pin,$pout); for($i=0;$i<$nout;$i++) { $out[$i]=$in[$pout->at($i)]; } return @out; } *ran_ver_meat = \&PDL::GSL::RNG::ran_ver_meat; *ran_caos_meat = \&PDL::GSL::RNG::ran_caos_meat; sub ran_ver { my ($obj,$x0,$r,$n) = @_; if ($n>0) { my $p = zeroes($n); ran_ver_meat($p,$x0,$r,$n,$$obj); return $p; } else { barf("Not enough parameters for ran_ver!"); } } sub ran_caos { my ($obj,$m,$n) = @_; if ($n>0) { my $p = zeroes($n); ran_caos_meat($p,$m,$n,$$obj); return $p; } else { barf("Not enough parameters for ran_caos!"); } } ; # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/����������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402070�013153� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/AIRY.pm���������������������������������������������������������������0000644�0601750�0601001�00000010603�13110402063�014257� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::AIRY; @EXPORT_OK = qw( PDL::PP gsl_sf_airy_Ai PDL::PP gsl_sf_airy_Bi PDL::PP gsl_sf_airy_Ai_scaled PDL::PP gsl_sf_airy_Bi_scaled PDL::PP gsl_sf_airy_Ai_deriv PDL::PP gsl_sf_airy_Bi_deriv PDL::PP gsl_sf_airy_Ai_deriv_scaled PDL::PP gsl_sf_airy_Bi_deriv_scaled ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::AIRY ; =head1 NAME PDL::GSLSF::AIRY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_airy_Ai =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Airy Function Ai(x). =for bad gsl_sf_airy_Ai does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Ai = \&PDL::gsl_sf_airy_Ai; =head2 gsl_sf_airy_Bi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Airy Function Bi(x). =for bad gsl_sf_airy_Bi does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Bi = \&PDL::gsl_sf_airy_Bi; =head2 gsl_sf_airy_Ai_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Scaled Airy Function Ai(x). Ai(x) for x < 0 and exp(+2/3 x^{3/2}) Ai(x) for x > 0. =for bad gsl_sf_airy_Ai_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Ai_scaled = \&PDL::gsl_sf_airy_Ai_scaled; =head2 gsl_sf_airy_Bi_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Scaled Airy Function Bi(x). Bi(x) for x < 0 and exp(+2/3 x^{3/2}) Bi(x) for x > 0. =for bad gsl_sf_airy_Bi_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Bi_scaled = \&PDL::gsl_sf_airy_Bi_scaled; =head2 gsl_sf_airy_Ai_deriv =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Airy Function Ai`(x). =for bad gsl_sf_airy_Ai_deriv does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Ai_deriv = \&PDL::gsl_sf_airy_Ai_deriv; =head2 gsl_sf_airy_Bi_deriv =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Airy Function Bi`(x). =for bad gsl_sf_airy_Bi_deriv does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Bi_deriv = \&PDL::gsl_sf_airy_Bi_deriv; =head2 gsl_sf_airy_Ai_deriv_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Scaled Airy Function Ai(x). Ai`(x) for x < 0 and exp(+2/3 x^{3/2}) Ai`(x) for x > 0. =for bad gsl_sf_airy_Ai_deriv_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Ai_deriv_scaled = \&PDL::gsl_sf_airy_Ai_deriv_scaled; =head2 gsl_sf_airy_Bi_deriv_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Scaled Airy Function Bi(x). Bi`(x) for x < 0 and exp(+2/3 x^{3/2}) Bi`(x) for x > 0. =for bad gsl_sf_airy_Bi_deriv_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_airy_Bi_deriv_scaled = \&PDL::gsl_sf_airy_Bi_deriv_scaled; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/BESSEL.pm�������������������������������������������������������������0000644�0601750�0601001�00000031234�13110402062�014472� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::BESSEL; @EXPORT_OK = qw( PDL::PP gsl_sf_bessel_Jn PDL::PP gsl_sf_bessel_J_array PDL::PP gsl_sf_bessel_Yn PDL::PP gsl_sf_bessel_Y_array PDL::PP gsl_sf_bessel_In PDL::PP gsl_sf_bessel_I_array PDL::PP gsl_sf_bessel_In_scaled PDL::PP gsl_sf_bessel_I_scaled_array PDL::PP gsl_sf_bessel_Kn PDL::PP gsl_sf_bessel_K_array PDL::PP gsl_sf_bessel_Kn_scaled PDL::PP gsl_sf_bessel_K_scaled_array PDL::PP gsl_sf_bessel_jl PDL::PP gsl_sf_bessel_j_array PDL::PP gsl_sf_bessel_yl PDL::PP gsl_sf_bessel_y_array PDL::PP gsl_sf_bessel_il_scaled PDL::PP gsl_sf_bessel_i_scaled_array PDL::PP gsl_sf_bessel_kl_scaled PDL::PP gsl_sf_bessel_k_scaled_array PDL::PP gsl_sf_bessel_Jnu PDL::PP gsl_sf_bessel_Ynu PDL::PP gsl_sf_bessel_Inu_scaled PDL::PP gsl_sf_bessel_Inu PDL::PP gsl_sf_bessel_Knu_scaled PDL::PP gsl_sf_bessel_Knu PDL::PP gsl_sf_bessel_lnKnu ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::BESSEL ; =head1 NAME PDL::GSLSF::BESSEL - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_bessel_Jn =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Regular Bessel Function J_n(x). =for bad gsl_sf_bessel_Jn does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Jn = \&PDL::gsl_sf_bessel_Jn; =head2 gsl_sf_bessel_J_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Regular Bessel Functions J_{s}(x) to J_{s+n-1}(x). =for bad gsl_sf_bessel_J_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_J_array = \&PDL::gsl_sf_bessel_J_array; =head2 gsl_sf_bessel_Yn =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref IrRegular Bessel Function Y_n(x). =for bad gsl_sf_bessel_Yn does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Yn = \&PDL::gsl_sf_bessel_Yn; =head2 gsl_sf_bessel_Y_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Regular Bessel Functions Y_{s}(x) to Y_{s+n-1}(x). =for bad gsl_sf_bessel_Y_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Y_array = \&PDL::gsl_sf_bessel_Y_array; =head2 gsl_sf_bessel_In =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Regular Modified Bessel Function I_n(x). =for bad gsl_sf_bessel_In does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_In = \&PDL::gsl_sf_bessel_In; =head2 gsl_sf_bessel_I_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Regular Modified Bessel Functions I_{s}(x) to I_{s+n-1}(x). =for bad gsl_sf_bessel_I_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_I_array = \&PDL::gsl_sf_bessel_I_array; =head2 gsl_sf_bessel_In_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled Regular Modified Bessel Function exp(-|x|) I_n(x). =for bad gsl_sf_bessel_In_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_In_scaled = \&PDL::gsl_sf_bessel_In_scaled; =head2 gsl_sf_bessel_I_scaled_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Scaled Regular Modified Bessel Functions exp(-|x|) I_{s}(x) to exp(-|x|) I_{s+n-1}(x). =for bad gsl_sf_bessel_I_scaled_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_I_scaled_array = \&PDL::gsl_sf_bessel_I_scaled_array; =head2 gsl_sf_bessel_Kn =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref IrRegular Modified Bessel Function K_n(x). =for bad gsl_sf_bessel_Kn does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Kn = \&PDL::gsl_sf_bessel_Kn; =head2 gsl_sf_bessel_K_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of IrRegular Modified Bessel Functions K_{s}(x) to K_{s+n-1}(x). =for bad gsl_sf_bessel_K_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_K_array = \&PDL::gsl_sf_bessel_K_array; =head2 gsl_sf_bessel_Kn_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled IrRegular Modified Bessel Function exp(-|x|) K_n(x). =for bad gsl_sf_bessel_Kn_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Kn_scaled = \&PDL::gsl_sf_bessel_Kn_scaled; =head2 gsl_sf_bessel_K_scaled_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Scaled IrRegular Modified Bessel Functions exp(-|x|) K_{s}(x) to exp(-|x|) K_{s+n-1}(x). =for bad gsl_sf_bessel_K_scaled_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_K_scaled_array = \&PDL::gsl_sf_bessel_K_scaled_array; =head2 gsl_sf_bessel_jl =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Regular Sphericl Bessel Function J_n(x). =for bad gsl_sf_bessel_jl does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_jl = \&PDL::gsl_sf_bessel_jl; =head2 gsl_sf_bessel_j_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Spherical Regular Bessel Functions J_{0}(x) to J_{n-1}(x). =for bad gsl_sf_bessel_j_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_j_array = \&PDL::gsl_sf_bessel_j_array; =head2 gsl_sf_bessel_yl =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref IrRegular Spherical Bessel Function y_n(x). =for bad gsl_sf_bessel_yl does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_yl = \&PDL::gsl_sf_bessel_yl; =head2 gsl_sf_bessel_y_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Regular Spherical Bessel Functions y_{0}(x) to y_{n-1}(x). =for bad gsl_sf_bessel_y_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_y_array = \&PDL::gsl_sf_bessel_y_array; =head2 gsl_sf_bessel_il_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled Regular Modified Spherical Bessel Function exp(-|x|) i_n(x). =for bad gsl_sf_bessel_il_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_il_scaled = \&PDL::gsl_sf_bessel_il_scaled; =head2 gsl_sf_bessel_i_scaled_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Scaled Regular Modified Spherical Bessel Functions exp(-|x|) i_{0}(x) to exp(-|x|) i_{n-1}(x). =for bad gsl_sf_bessel_i_scaled_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_i_scaled_array = \&PDL::gsl_sf_bessel_i_scaled_array; =head2 gsl_sf_bessel_kl_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled IrRegular Modified Spherical Bessel Function exp(-|x|) k_n(x). =for bad gsl_sf_bessel_kl_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_kl_scaled = \&PDL::gsl_sf_bessel_kl_scaled; =head2 gsl_sf_bessel_k_scaled_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Scaled IrRegular Modified Spherical Bessel Functions exp(-|x|) k_{s}(x) to exp(-|x|) k_{s+n-1}(x). =for bad gsl_sf_bessel_k_scaled_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_k_scaled_array = \&PDL::gsl_sf_bessel_k_scaled_array; =head2 gsl_sf_bessel_Jnu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Regular Cylindrical Bessel Function J_nu(x). =for bad gsl_sf_bessel_Jnu does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Jnu = \&PDL::gsl_sf_bessel_Jnu; =head2 gsl_sf_bessel_Ynu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref IrRegular Cylindrical Bessel Function J_nu(x). =for bad gsl_sf_bessel_Ynu does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Ynu = \&PDL::gsl_sf_bessel_Ynu; =head2 gsl_sf_bessel_Inu_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Scaled Modified Cylindrical Bessel Function exp(-|x|) I_nu(x). =for bad gsl_sf_bessel_Inu_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Inu_scaled = \&PDL::gsl_sf_bessel_Inu_scaled; =head2 gsl_sf_bessel_Inu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Modified Cylindrical Bessel Function I_nu(x). =for bad gsl_sf_bessel_Inu does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Inu = \&PDL::gsl_sf_bessel_Inu; =head2 gsl_sf_bessel_Knu_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Scaled Modified Cylindrical Bessel Function exp(-|x|) K_nu(x). =for bad gsl_sf_bessel_Knu_scaled does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Knu_scaled = \&PDL::gsl_sf_bessel_Knu_scaled; =head2 gsl_sf_bessel_Knu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Modified Cylindrical Bessel Function K_nu(x). =for bad gsl_sf_bessel_Knu does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_Knu = \&PDL::gsl_sf_bessel_Knu; =head2 gsl_sf_bessel_lnKnu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Logarithm of Modified Cylindrical Bessel Function K_nu(x). =for bad gsl_sf_bessel_lnKnu does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_bessel_lnKnu = \&PDL::gsl_sf_bessel_lnKnu; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/CLAUSEN.pm������������������������������������������������������������0000644�0601750�0601001�00000002653�13110402062�014612� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::CLAUSEN; @EXPORT_OK = qw( PDL::PP gsl_sf_clausen ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::CLAUSEN ; =head1 NAME PDL::GSLSF::CLAUSEN - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_clausen =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Clausen Integral. Cl_2(x) := Integrate[-Log[2 Sin[t/2]], {t,0,x}] =for bad gsl_sf_clausen does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_clausen = \&PDL::gsl_sf_clausen; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/COULOMB.pm������������������������������������������������������������0000644�0601750�0601001�00000006342�13110402052�014616� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::COULOMB; @EXPORT_OK = qw( PDL::PP gsl_sf_hydrogenicR PDL::PP gsl_sf_coulomb_wave_FGp_array PDL::PP gsl_sf_coulomb_wave_sphF_array PDL::PP gsl_sf_coulomb_CL_e ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::COULOMB ; =head1 NAME PDL::GSLSF::COULOMB - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_hydrogenicR =for sig Signature: (double x(); double [o]y(); double [o]e(); int n; int l; double z) =for ref Normalized Hydrogenic bound states. Radial dipendence. =for bad gsl_sf_hydrogenicR does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hydrogenicR = \&PDL::gsl_sf_hydrogenicR; =head2 gsl_sf_coulomb_wave_FGp_array =for sig Signature: (double x(); double [o]fc(n); double [o]fcp(n); double [o]gc(n); double [o]gcp(n); int [o]ovfw(); double [o]fe(n); double [o]ge(n); double lam_min; int kmax=>n; double eta) =for ref Coulomb wave functions F_{lam_F}(eta,x), G_{lam_G}(eta,x) and their derivatives; lam_G := lam_F - k_lam_G. if ovfw is signaled then F_L(eta,x) = fc[k_L] * exp(fe) and similar. =for bad gsl_sf_coulomb_wave_FGp_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_coulomb_wave_FGp_array = \&PDL::gsl_sf_coulomb_wave_FGp_array; =head2 gsl_sf_coulomb_wave_sphF_array =for sig Signature: (double x(); double [o]fc(n); int [o]ovfw(); double [o]fe(n); double lam_min; int kmax=>n; double eta) =for ref Coulomb wave function divided by the argument, F(xi, eta)/xi. This is the function which reduces to spherical Bessel functions in the limit eta->0. =for bad gsl_sf_coulomb_wave_sphF_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_coulomb_wave_sphF_array = \&PDL::gsl_sf_coulomb_wave_sphF_array; =head2 gsl_sf_coulomb_CL_e =for sig Signature: (double L(); double eta(); double [o]y(); double [o]e()) =for ref Coulomb wave function normalization constant. [Abramowitz+Stegun 14.1.8, 14.1.9]. =for bad gsl_sf_coulomb_CL_e does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_coulomb_CL_e = \&PDL::gsl_sf_coulomb_CL_e; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/COUPLING.pm�����������������������������������������������������������0000644�0601750�0601001�00000004463�13110402053�014741� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::COUPLING; @EXPORT_OK = qw( PDL::PP gsl_sf_coupling_3j PDL::PP gsl_sf_coupling_6j PDL::PP gsl_sf_coupling_9j ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::COUPLING ; =head1 NAME PDL::GSLSF::COUPLING - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_coupling_3j =for sig Signature: (ja(); jb(); jc(); ma(); mb(); mc(); double [o]y(); double [o]e()) =for ref 3j Symbols: (ja jb jc) over (ma mb mc). =for bad gsl_sf_coupling_3j does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_coupling_3j = \&PDL::gsl_sf_coupling_3j; =head2 gsl_sf_coupling_6j =for sig Signature: (ja(); jb(); jc(); jd(); je(); jf(); double [o]y(); double [o]e()) =for ref 6j Symbols: (ja jb jc) over (jd je jf). =for bad gsl_sf_coupling_6j does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_coupling_6j = \&PDL::gsl_sf_coupling_6j; =head2 gsl_sf_coupling_9j =for sig Signature: (ja(); jb(); jc(); jd(); je(); jf(); jg(); jh(); ji(); double [o]y(); double [o]e()) =for ref 9j Symbols: (ja jb jc) over (jd je jf) over (jg jh ji). =for bad gsl_sf_coupling_9j does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_coupling_9j = \&PDL::gsl_sf_coupling_9j; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/DAWSON.pm�������������������������������������������������������������0000644�0601750�0601001�00000002632�13110402055�014512� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::DAWSON; @EXPORT_OK = qw( PDL::PP gsl_sf_dawson ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::DAWSON ; =head1 NAME PDL::GSLSF::DAWSON - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_dawson =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Dawsons integral: Exp[-x^2] Integral[ Exp[t^2], {t,0,x}] =for bad gsl_sf_dawson does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_dawson = \&PDL::gsl_sf_dawson; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/DEBYE.pm��������������������������������������������������������������0000644�0601750�0601001�00000005044�13110402063�014346� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::DEBYE; @EXPORT_OK = qw( PDL::PP gsl_sf_debye_1 PDL::PP gsl_sf_debye_2 PDL::PP gsl_sf_debye_3 PDL::PP gsl_sf_debye_4 ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::DEBYE ; =head1 NAME PDL::GSLSF::DEBYE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_debye_1 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_1 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_debye_1 = \&PDL::gsl_sf_debye_1; =head2 gsl_sf_debye_2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_2 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_debye_2 = \&PDL::gsl_sf_debye_2; =head2 gsl_sf_debye_3 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_3 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_debye_3 = \&PDL::gsl_sf_debye_3; =head2 gsl_sf_debye_4 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_4 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_debye_4 = \&PDL::gsl_sf_debye_4; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/DILOG.pm��������������������������������������������������������������0000644�0601750�0601001�00000003701�13110402070�014350� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::DILOG; @EXPORT_OK = qw( PDL::PP gsl_sf_dilog PDL::PP gsl_sf_complex_dilog ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::DILOG ; =head1 NAME PDL::GSLSF::DILOG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_dilog =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref /* Real part of DiLogarithm(x), for real argument. In Lewins notation, this is Li_2(x). Li_2(x) = - Re[ Integrate[ Log[1-s] / s, {s, 0, x}] ] =for bad gsl_sf_dilog does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_dilog = \&PDL::gsl_sf_dilog; =head2 gsl_sf_complex_dilog =for sig Signature: (double r(); double t(); double [o]re(); double [o]im(); double [o]ere(); double [o]eim()) =for ref DiLogarithm(z), for complex argument z = r Exp[i theta]. =for bad gsl_sf_complex_dilog does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_complex_dilog = \&PDL::gsl_sf_complex_dilog; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ���������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/ELEMENTARY.pm���������������������������������������������������������0000644�0601750�0601001�00000003517�13110402065�015170� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ELEMENTARY; @EXPORT_OK = qw( PDL::PP gsl_sf_multiply PDL::PP gsl_sf_multiply_err ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ELEMENTARY ; =head1 NAME PDL::GSLSF::ELEMENTARY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_multiply =for sig Signature: (double x(); double xx(); double [o]y(); double [o]e()) =for ref Multiplication. =for bad gsl_sf_multiply does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_multiply = \&PDL::gsl_sf_multiply; =head2 gsl_sf_multiply_err =for sig Signature: (double x(); double xe(); double xx(); double xxe(); double [o]y(); double [o]e()) =for ref Multiplication with associated errors. =for bad gsl_sf_multiply_err does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_multiply_err = \&PDL::gsl_sf_multiply_err; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/ELLINT.pm�������������������������������������������������������������0000644�0601750�0601001�00000013312�13110402054�014502� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ELLINT; @EXPORT_OK = qw( PDL::PP gsl_sf_ellint_Kcomp PDL::PP gsl_sf_ellint_Ecomp PDL::PP gsl_sf_ellint_F PDL::PP gsl_sf_ellint_E PDL::PP gsl_sf_ellint_P PDL::PP gsl_sf_ellint_D PDL::PP gsl_sf_ellint_RC PDL::PP gsl_sf_ellint_RD PDL::PP gsl_sf_ellint_RF PDL::PP gsl_sf_ellint_RJ ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ELLINT ; =head1 NAME PDL::GSLSF::ELLINT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_ellint_Kcomp =for sig Signature: (double k(); double [o]y(); double [o]e()) =for ref Legendre form of complete elliptic integrals K(k) = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}]. =for bad gsl_sf_ellint_Kcomp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_Kcomp = \&PDL::gsl_sf_ellint_Kcomp; =head2 gsl_sf_ellint_Ecomp =for sig Signature: (double k(); double [o]y(); double [o]e()) =for ref Legendre form of complete elliptic integrals E(k) = Integral[ Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}] =for bad gsl_sf_ellint_Ecomp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_Ecomp = \&PDL::gsl_sf_ellint_Ecomp; =head2 gsl_sf_ellint_F =for sig Signature: (double phi(); double k(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals F(phi,k) = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}] =for bad gsl_sf_ellint_F does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_F = \&PDL::gsl_sf_ellint_F; =head2 gsl_sf_ellint_E =for sig Signature: (double phi(); double k(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals E(phi,k) = Integral[ Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}] =for bad gsl_sf_ellint_E does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_E = \&PDL::gsl_sf_ellint_E; =head2 gsl_sf_ellint_P =for sig Signature: (double phi(); double k(); double n(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals P(phi,k,n) = Integral[(1 + n Sin[t]^2)^(-1)/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}] =for bad gsl_sf_ellint_P does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_P = \&PDL::gsl_sf_ellint_P; =head2 gsl_sf_ellint_D =for sig Signature: (double phi(); double k(); double n(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals D(phi,k,n) =for bad gsl_sf_ellint_D does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_D = \&PDL::gsl_sf_ellint_D; =head2 gsl_sf_ellint_RC =for sig Signature: (double x(); double yy(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RC(x,y) = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1)], {t,0,Inf} =for bad gsl_sf_ellint_RC does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_RC = \&PDL::gsl_sf_ellint_RC; =head2 gsl_sf_ellint_RD =for sig Signature: (double x(); double yy(); double z(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RD(x,y,z) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-3/2), {t,0,Inf}] =for bad gsl_sf_ellint_RD does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_RD = \&PDL::gsl_sf_ellint_RD; =head2 gsl_sf_ellint_RF =for sig Signature: (double x(); double yy(); double z(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RF(x,y,z) = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2), {t,0,Inf}] =for bad gsl_sf_ellint_RF does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_RF = \&PDL::gsl_sf_ellint_RF; =head2 gsl_sf_ellint_RJ =for sig Signature: (double x(); double yy(); double z(); double p(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RJ(x,y,z,p) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2) (t+p)^(-1), {t,0,Inf}] =for bad gsl_sf_ellint_RJ does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_ellint_RJ = \&PDL::gsl_sf_ellint_RJ; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it>, 2002 Christian Soeller. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/ELLJAC.pm�������������������������������������������������������������0000644�0601750�0601001�00000002713�13110402052�014446� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ELLJAC; @EXPORT_OK = qw( PDL::PP gsl_sf_elljac ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ELLJAC ; =head1 NAME PDL::GSLSF::ELLJAC - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_elljac =for sig Signature: (double u(); double m(); double [o]sn(); double [o]cn(); double [o]dn()) =for ref Jacobian elliptic functions sn, dn, cn by descending Landen transformations =for bad gsl_sf_elljac does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_elljac = \&PDL::gsl_sf_elljac; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �����������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/ERF.pm����������������������������������������������������������������0000644�0601750�0601001�00000005564�13110402070�014137� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ERF; @EXPORT_OK = qw( PDL::PP gsl_sf_erfc PDL::PP gsl_sf_log_erfc PDL::PP gsl_sf_erf PDL::PP gsl_sf_erf_Z PDL::PP gsl_sf_erf_Q ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ERF ; =head1 NAME PDL::GSLSF::ERF - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_erfc =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complementary Error Function erfc(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,x,Infinity}] =for bad gsl_sf_erfc does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_erfc = \&PDL::gsl_sf_erfc; =head2 gsl_sf_log_erfc =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Log Complementary Error Function =for bad gsl_sf_log_erfc does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_log_erfc = \&PDL::gsl_sf_log_erfc; =head2 gsl_sf_erf =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Error Function erf(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,0,x}] =for bad gsl_sf_erf does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_erf = \&PDL::gsl_sf_erf; =head2 gsl_sf_erf_Z =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Z(x) : Abramowitz+Stegun 26.2.1 =for bad gsl_sf_erf_Z does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_erf_Z = \&PDL::gsl_sf_erf_Z; =head2 gsl_sf_erf_Q =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Q(x) : Abramowitz+Stegun 26.2.1 =for bad gsl_sf_erf_Q does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_erf_Q = \&PDL::gsl_sf_erf_Q; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/EXP.pm����������������������������������������������������������������0000644�0601750�0601001�00000004305�13110402070�014147� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::EXP; @EXPORT_OK = qw( PDL::PP gsl_sf_exp PDL::PP gsl_sf_exprel_n PDL::PP gsl_sf_exp_err ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::EXP ; =head1 NAME PDL::GSLSF::EXP - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_exp =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Exponential =for bad gsl_sf_exp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_exp = \&PDL::gsl_sf_exp; =head2 gsl_sf_exprel_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref N-relative Exponential. exprel_N(x) = N!/x^N (exp(x) - Sum[x^k/k!, {k,0,N-1}]) = 1 + x/(N+1) + x^2/((N+1)(N+2)) + ... = 1F1(1,1+N,x) =for bad gsl_sf_exprel_n does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_exprel_n = \&PDL::gsl_sf_exprel_n; =head2 gsl_sf_exp_err =for sig Signature: (double x(); double dx(); double [o]y(); double [o]e()) =for ref Exponential of a quantity with given error. =for bad gsl_sf_exp_err does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_exp_err = \&PDL::gsl_sf_exp_err; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/EXPINT.pm�������������������������������������������������������������0000644�0601750�0601001�00000010603�13110402054�014522� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::EXPINT; @EXPORT_OK = qw( PDL::PP gsl_sf_expint_E1 PDL::PP gsl_sf_expint_E2 PDL::PP gsl_sf_expint_Ei PDL::PP gsl_sf_Shi PDL::PP gsl_sf_Chi PDL::PP gsl_sf_expint_3 PDL::PP gsl_sf_Si PDL::PP gsl_sf_Ci PDL::PP gsl_sf_atanint ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::EXPINT ; =head1 NAME PDL::GSLSF::EXPINT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_expint_E1 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref E_1(x) := Re[ Integrate[ Exp[-xt]/t, {t,1,Infinity}] ] =for bad gsl_sf_expint_E1 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_expint_E1 = \&PDL::gsl_sf_expint_E1; =head2 gsl_sf_expint_E2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref E_2(x) := Re[ Integrate[ Exp[-xt]/t^2, {t,1,Infity}] ] =for bad gsl_sf_expint_E2 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_expint_E2 = \&PDL::gsl_sf_expint_E2; =head2 gsl_sf_expint_Ei =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Ei(x) := PV Integrate[ Exp[-t]/t, {t,-x,Infinity}] =for bad gsl_sf_expint_Ei does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_expint_Ei = \&PDL::gsl_sf_expint_Ei; =head2 gsl_sf_Shi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Shi(x) := Integrate[ Sinh[t]/t, {t,0,x}] =for bad gsl_sf_Shi does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_Shi = \&PDL::gsl_sf_Shi; =head2 gsl_sf_Chi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Chi(x) := Re[ M_EULER + log(x) + Integrate[(Cosh[t]-1)/t, {t,0,x}] ] =for bad gsl_sf_Chi does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_Chi = \&PDL::gsl_sf_Chi; =head2 gsl_sf_expint_3 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Ei_3(x) := Integral[ Exp[-t^3], {t,0,x}] =for bad gsl_sf_expint_3 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_expint_3 = \&PDL::gsl_sf_expint_3; =head2 gsl_sf_Si =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Si(x) := Integrate[ Sin[t]/t, {t,0,x}] =for bad gsl_sf_Si does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_Si = \&PDL::gsl_sf_Si; =head2 gsl_sf_Ci =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Ci(x) := -Integrate[ Cos[t]/t, {t,x,Infinity}] =for bad gsl_sf_Ci does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_Ci = \&PDL::gsl_sf_Ci; =head2 gsl_sf_atanint =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref AtanInt(x) := Integral[ Arctan[t]/t, {t,0,x}] =for bad gsl_sf_atanint does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_atanint = \&PDL::gsl_sf_atanint; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/FERMI_DIRAC.pm��������������������������������������������������������0000644�0601750�0601001�00000006536�13110402062�015270� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::FERMI_DIRAC; @EXPORT_OK = qw( PDL::PP gsl_sf_fermi_dirac_int PDL::PP gsl_sf_fermi_dirac_mhalf PDL::PP gsl_sf_fermi_dirac_half PDL::PP gsl_sf_fermi_dirac_3half PDL::PP gsl_sf_fermi_dirac_inc_0 ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::FERMI_DIRAC ; =head1 NAME PDL::GSLSF::FERMI_DIRAC - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Please note that: Complete Fermi-Dirac Integrals: F_j(x) := 1/Gamma[j+1] Integral[ t^j /(Exp[t-x] + 1), {t,0,Infinity}] Incomplete Fermi-Dirac Integrals: F_j(x,b) := 1/Gamma[j+1] Integral[ t^j /(Exp[t-x] + 1), {t,b,Infinity}] =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_fermi_dirac_int =for sig Signature: (double x(); double [o]y(); double [o]e(); int j) =for ref Complete integral F_j(x) for integer j =for bad gsl_sf_fermi_dirac_int does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_fermi_dirac_int = \&PDL::gsl_sf_fermi_dirac_int; =head2 gsl_sf_fermi_dirac_mhalf =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complete integral F_{-1/2}(x) =for bad gsl_sf_fermi_dirac_mhalf does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_fermi_dirac_mhalf = \&PDL::gsl_sf_fermi_dirac_mhalf; =head2 gsl_sf_fermi_dirac_half =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complete integral F_{1/2}(x) =for bad gsl_sf_fermi_dirac_half does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_fermi_dirac_half = \&PDL::gsl_sf_fermi_dirac_half; =head2 gsl_sf_fermi_dirac_3half =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complete integral F_{3/2}(x) =for bad gsl_sf_fermi_dirac_3half does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_fermi_dirac_3half = \&PDL::gsl_sf_fermi_dirac_3half; =head2 gsl_sf_fermi_dirac_inc_0 =for sig Signature: (double x(); double [o]y(); double [o]e(); double b) =for ref Incomplete integral F_0(x,b) = ln(1 + e^(b-x)) - (b-x) =for bad gsl_sf_fermi_dirac_inc_0 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_fermi_dirac_inc_0 = \&PDL::gsl_sf_fermi_dirac_inc_0; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/GAMMA.pm��������������������������������������������������������������0000644�0601750�0601001�00000021111�13110402057�014334� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::GAMMA; @EXPORT_OK = qw( PDL::PP gsl_sf_lngamma PDL::PP gsl_sf_gamma PDL::PP gsl_sf_gammastar PDL::PP gsl_sf_gammainv PDL::PP gsl_sf_lngamma_complex PDL::PP gsl_sf_taylorcoeff PDL::PP gsl_sf_fact PDL::PP gsl_sf_doublefact PDL::PP gsl_sf_lnfact PDL::PP gsl_sf_lndoublefact PDL::PP gsl_sf_lnchoose PDL::PP gsl_sf_choose PDL::PP gsl_sf_lnpoch PDL::PP gsl_sf_poch PDL::PP gsl_sf_pochrel PDL::PP gsl_sf_gamma_inc_Q PDL::PP gsl_sf_gamma_inc_P PDL::PP gsl_sf_lnbeta PDL::PP gsl_sf_beta ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::GAMMA ; =head1 NAME PDL::GSLSF::GAMMA - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_lngamma =for sig Signature: (double x(); double [o]y(); double [o]s(); double [o]e()) =for ref Log[Gamma(x)], x not a negative integer Uses real Lanczos method. Determines the sign of Gamma[x] as well as Log[|Gamma[x]|] for x < 0. So Gamma[x] = sgn * Exp[result_lg]. =for bad gsl_sf_lngamma does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lngamma = \&PDL::gsl_sf_lngamma; =head2 gsl_sf_gamma =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Gamma(x), x not a negative integer =for bad gsl_sf_gamma does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_gamma = \&PDL::gsl_sf_gamma; =head2 gsl_sf_gammastar =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Regulated Gamma Function, x > 0 Gamma^*(x) = Gamma(x)/(Sqrt[2Pi] x^(x-1/2) exp(-x)) = (1 + 1/(12x) + ...), x->Inf =for bad gsl_sf_gammastar does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_gammastar = \&PDL::gsl_sf_gammastar; =head2 gsl_sf_gammainv =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref 1/Gamma(x) =for bad gsl_sf_gammainv does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_gammainv = \&PDL::gsl_sf_gammainv; =head2 gsl_sf_lngamma_complex =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Log[Gamma(z)] for z complex, z not a negative integer. Calculates: lnr = log|Gamma(z)|, arg = arg(Gamma(z)) in (-Pi, Pi] =for bad gsl_sf_lngamma_complex does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lngamma_complex = \&PDL::gsl_sf_lngamma_complex; =head2 gsl_sf_taylorcoeff =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref x^n / n! =for bad gsl_sf_taylorcoeff does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_taylorcoeff = \&PDL::gsl_sf_taylorcoeff; =head2 gsl_sf_fact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref n! =for bad gsl_sf_fact does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_fact = \&PDL::gsl_sf_fact; =head2 gsl_sf_doublefact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref n!! = n(n-2)(n-4) =for bad gsl_sf_doublefact does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_doublefact = \&PDL::gsl_sf_doublefact; =head2 gsl_sf_lnfact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref ln n! =for bad gsl_sf_lnfact does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lnfact = \&PDL::gsl_sf_lnfact; =head2 gsl_sf_lndoublefact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref ln n!! =for bad gsl_sf_lndoublefact does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lndoublefact = \&PDL::gsl_sf_lndoublefact; =head2 gsl_sf_lnchoose =for sig Signature: (n(); m(); double [o]y(); double [o]e()) =for ref log(n choose m) =for bad gsl_sf_lnchoose does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lnchoose = \&PDL::gsl_sf_lnchoose; =head2 gsl_sf_choose =for sig Signature: (n(); m(); double [o]y(); double [o]e()) =for ref n choose m =for bad gsl_sf_choose does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_choose = \&PDL::gsl_sf_choose; =head2 gsl_sf_lnpoch =for sig Signature: (double x(); double [o]y(); double [o]s(); double [o]e(); double a) =for ref Logarithm of Pochammer (Apell) symbol, with sign information. result = log( |(a)_x| ), sgn = sgn( (a)_x ) where (a)_x := Gamma[a + x]/Gamma[a] =for bad gsl_sf_lnpoch does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lnpoch = \&PDL::gsl_sf_lnpoch; =head2 gsl_sf_poch =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Pochammer (Apell) symbol (a)_x := Gamma[a + x]/Gamma[x] =for bad gsl_sf_poch does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_poch = \&PDL::gsl_sf_poch; =head2 gsl_sf_pochrel =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Relative Pochammer (Apell) symbol ((a,x) - 1)/x where (a,x) = (a)_x := Gamma[a + x]/Gamma[a] =for bad gsl_sf_pochrel does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_pochrel = \&PDL::gsl_sf_pochrel; =head2 gsl_sf_gamma_inc_Q =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Normalized Incomplete Gamma Function Q(a,x) = 1/Gamma(a) Integral[ t^(a-1) e^(-t), {t,x,Infinity} ] =for bad gsl_sf_gamma_inc_Q does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_gamma_inc_Q = \&PDL::gsl_sf_gamma_inc_Q; =head2 gsl_sf_gamma_inc_P =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Complementary Normalized Incomplete Gamma Function P(a,x) = 1/Gamma(a) Integral[ t^(a-1) e^(-t), {t,0,x} ] =for bad gsl_sf_gamma_inc_P does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_gamma_inc_P = \&PDL::gsl_sf_gamma_inc_P; =head2 gsl_sf_lnbeta =for sig Signature: (double a(); double b(); double [o]y(); double [o]e()) =for ref Logarithm of Beta Function Log[B(a,b)] =for bad gsl_sf_lnbeta does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lnbeta = \&PDL::gsl_sf_lnbeta; =head2 gsl_sf_beta =for sig Signature: (double a(); double b();double [o]y(); double [o]e()) =for ref Beta Function B(a,b) =for bad gsl_sf_beta does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_beta = \&PDL::gsl_sf_beta; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/GEGENBAUER.pm���������������������������������������������������������0000644�0601750�0601001�00000003601�13110402052�015115� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::GEGENBAUER; @EXPORT_OK = qw( PDL::PP gsl_sf_gegenpoly_n PDL::PP gsl_sf_gegenpoly_array ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::GEGENBAUER ; =head1 NAME PDL::GSLSF::GEGENBAUER - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_gegenpoly_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n; double lambda) =for ref Evaluate Gegenbauer polynomials. =for bad gsl_sf_gegenpoly_n does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_gegenpoly_n = \&PDL::gsl_sf_gegenpoly_n; =head2 gsl_sf_gegenpoly_array =for sig Signature: (double x(); double [o]y(num); int n=>num; double lambda) =for ref Calculate array of Gegenbauer polynomials from 0 to n-1. =for bad gsl_sf_gegenpoly_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_gegenpoly_array = \&PDL::gsl_sf_gegenpoly_array; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/HYPERG.pm�������������������������������������������������������������0000644�0601750�0601001�00000011504�13110402066�014515� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::HYPERG; @EXPORT_OK = qw( PDL::PP gsl_sf_hyperg_0F1 PDL::PP gsl_sf_hyperg_1F1 PDL::PP gsl_sf_hyperg_U PDL::PP gsl_sf_hyperg_2F1 PDL::PP gsl_sf_hyperg_2F1_conj PDL::PP gsl_sf_hyperg_2F1_renorm PDL::PP gsl_sf_hyperg_2F1_conj_renorm PDL::PP gsl_sf_hyperg_2F0 ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::HYPERG ; =head1 NAME PDL::GSLSF::HYPERG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_hyperg_0F1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double c) =for ref /* Hypergeometric function related to Bessel functions 0F1[c,x] = Gamma[c] x^(1/2(1-c)) I_{c-1}(2 Sqrt[x]) Gamma[c] (-x)^(1/2(1-c)) J_{c-1}(2 Sqrt[-x]) =for bad gsl_sf_hyperg_0F1 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_0F1 = \&PDL::gsl_sf_hyperg_0F1; =head2 gsl_sf_hyperg_1F1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b) =for ref Confluent hypergeometric function for integer parameters. 1F1[a,b,x] = M(a,b,x) =for bad gsl_sf_hyperg_1F1 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_1F1 = \&PDL::gsl_sf_hyperg_1F1; =head2 gsl_sf_hyperg_U =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b) =for ref Confluent hypergeometric function for integer parameters. U(a,b,x) =for bad gsl_sf_hyperg_U does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_U = \&PDL::gsl_sf_hyperg_U; =head2 gsl_sf_hyperg_2F1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Confluent hypergeometric function for integer parameters. 2F1[a,b,c,x] =for bad gsl_sf_hyperg_2F1 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_2F1 = \&PDL::gsl_sf_hyperg_2F1; =head2 gsl_sf_hyperg_2F1_conj =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Gauss hypergeometric function 2F1[aR + I aI, aR - I aI, c, x] =for bad gsl_sf_hyperg_2F1_conj does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_2F1_conj = \&PDL::gsl_sf_hyperg_2F1_conj; =head2 gsl_sf_hyperg_2F1_renorm =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Renormalized Gauss hypergeometric function 2F1[a,b,c,x] / Gamma[c] =for bad gsl_sf_hyperg_2F1_renorm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_2F1_renorm = \&PDL::gsl_sf_hyperg_2F1_renorm; =head2 gsl_sf_hyperg_2F1_conj_renorm =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Renormalized Gauss hypergeometric function 2F1[aR + I aI, aR - I aI, c, x] / Gamma[c] =for bad gsl_sf_hyperg_2F1_conj_renorm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_2F1_conj_renorm = \&PDL::gsl_sf_hyperg_2F1_conj_renorm; =head2 gsl_sf_hyperg_2F0 =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b) =for ref Mysterious hypergeometric function. The series representation is a divergent hypergeometric series. However, for x < 0 we have 2F0(a,b,x) = (-1/x)^a U(a,1+a-b,-1/x) =for bad gsl_sf_hyperg_2F0 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hyperg_2F0 = \&PDL::gsl_sf_hyperg_2F0; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/LAGUERRE.pm�����������������������������������������������������������0000644�0601750�0601001�00000002670�13110402066�014731� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::LAGUERRE; @EXPORT_OK = qw( PDL::PP gsl_sf_laguerre_n ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::LAGUERRE ; =head1 NAME PDL::GSLSF::LAGUERRE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_laguerre_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n; double a) =for ref Evaluate generalized Laguerre polynomials. =for bad gsl_sf_laguerre_n does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_laguerre_n = \&PDL::gsl_sf_laguerre_n; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/LEGENDRE.pm�����������������������������������������������������������0000644�0601750�0601001�00000017452�13110402061�014707� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::LEGENDRE; @EXPORT_OK = qw( PDL::PP gsl_sf_legendre_Pl PDL::PP gsl_sf_legendre_Pl_array PDL::PP gsl_sf_legendre_Ql PDL::PP gsl_sf_legendre_Plm PDL::PP gsl_sf_legendre_Plm_array PDL::PP gsl_sf_legendre_sphPlm_array PDL::PP gsl_sf_legendre_sphPlm PDL::PP gsl_sf_conicalP_half PDL::PP gsl_sf_conicalP_mhalf PDL::PP gsl_sf_conicalP_0 PDL::PP gsl_sf_conicalP_1 PDL::PP gsl_sf_conicalP_sph_reg PDL::PP gsl_sf_conicalP_cyl_reg_e PDL::PP gsl_sf_legendre_H3d PDL::PP gsl_sf_legendre_H3d_array ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::LEGENDRE ; =head1 NAME PDL::GSLSF::LEGENDRE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_legendre_Pl =for sig Signature: (double x(); double [o]y(); double [o]e(); int l) =for ref P_l(x) =for bad gsl_sf_legendre_Pl does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_Pl = \&PDL::gsl_sf_legendre_Pl; =head2 gsl_sf_legendre_Pl_array =for sig Signature: (double x(); double [o]y(num); int l=>num) =for ref P_l(x) from 0 to n-1. =for bad gsl_sf_legendre_Pl_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_Pl_array = \&PDL::gsl_sf_legendre_Pl_array; =head2 gsl_sf_legendre_Ql =for sig Signature: (double x(); double [o]y(); double [o]e(); int l) =for ref Q_l(x) =for bad gsl_sf_legendre_Ql does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_Ql = \&PDL::gsl_sf_legendre_Ql; =head2 gsl_sf_legendre_Plm =for sig Signature: (double x(); double [o]y(); double [o]e(); int l; int m) =for ref P_lm(x) =for bad gsl_sf_legendre_Plm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_Plm = \&PDL::gsl_sf_legendre_Plm; =head2 gsl_sf_legendre_Plm_array =for sig Signature: (double x(); double [o]y(num); int l=>num; int m) P_lm(x) for l from 0 to n-2+m. gsl_sf_legendre_Plm_array has been deprecated in GSL version 2.0. It is included here for backwards compatability and may be removed in a future release. New code should use L<gsl_sf_legendre_array> instead. =for bad gsl_sf_legendre_Plm_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_Plm_array = \&PDL::gsl_sf_legendre_Plm_array; =head2 gsl_sf_legendre_sphPlm_array =for sig Signature: (double x(); double [o]y(num); int n=>num; int m) P_lm(x), normalized properly for use in spherical harmonics for l from 0 to n-2+m. gsl_sf_legendre_sphPlm_array has been deprecated in GSL version 2.0. It is included here for backwards compatability and may be removed in a future release. New code should use L<gsl_sf_legendre_array> instead. =for bad gsl_sf_legendre_sphPlm_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_sphPlm_array = \&PDL::gsl_sf_legendre_sphPlm_array; =head2 gsl_sf_legendre_sphPlm =for sig Signature: (double x(); double [o]y(); double [o]e(); int l; int m) =for ref P_lm(x), normalized properly for use in spherical harmonics =for bad gsl_sf_legendre_sphPlm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_sphPlm = \&PDL::gsl_sf_legendre_sphPlm; =head2 gsl_sf_conicalP_half =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Irregular Spherical Conical Function P^{1/2}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_half does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_conicalP_half = \&PDL::gsl_sf_conicalP_half; =head2 gsl_sf_conicalP_mhalf =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Regular Spherical Conical Function P^{-1/2}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_mhalf does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_conicalP_mhalf = \&PDL::gsl_sf_conicalP_mhalf; =head2 gsl_sf_conicalP_0 =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Conical Function P^{0}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_0 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_conicalP_0 = \&PDL::gsl_sf_conicalP_0; =head2 gsl_sf_conicalP_1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Conical Function P^{1}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_1 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_conicalP_1 = \&PDL::gsl_sf_conicalP_1; =head2 gsl_sf_conicalP_sph_reg =for sig Signature: (double x(); double [o]y(); double [o]e(); int l; double lambda) =for ref Regular Spherical Conical Function P^{-1/2-l}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_sph_reg does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_conicalP_sph_reg = \&PDL::gsl_sf_conicalP_sph_reg; =head2 gsl_sf_conicalP_cyl_reg_e =for sig Signature: (double x(); double [o]y(); double [o]e(); int m; double lambda) =for ref Regular Cylindrical Conical Function P^{-m}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_cyl_reg_e does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_conicalP_cyl_reg_e = \&PDL::gsl_sf_conicalP_cyl_reg_e; =head2 gsl_sf_legendre_H3d =for sig Signature: (double [o]y(); double [o]e(); int l; double lambda; double eta) =for ref lth radial eigenfunction of the Laplacian on the 3-dimensional hyperbolic space. =for bad gsl_sf_legendre_H3d does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_H3d = \&PDL::gsl_sf_legendre_H3d; =head2 gsl_sf_legendre_H3d_array =for sig Signature: (double [o]y(num); int l=>num; double lambda; double eta) =for ref Array of H3d(ell), for l from 0 to n-1. =for bad gsl_sf_legendre_H3d_array does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_legendre_H3d_array = \&PDL::gsl_sf_legendre_H3d_array; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/LOG.pm����������������������������������������������������������������0000644�0601750�0601001�00000003536�13110402070�014141� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::LOG; @EXPORT_OK = qw( PDL::PP gsl_sf_log PDL::PP gsl_sf_complex_log ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::LOG ; =head1 NAME PDL::GSLSF::LOG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_log =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Provide a logarithm function with GSL semantics. =for bad gsl_sf_log does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_log = \&PDL::gsl_sf_log; =head2 gsl_sf_complex_log =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Complex Logarithm exp(lnr + I theta) = zr + I zi Returns argument in [-pi,pi]. =for bad gsl_sf_complex_log does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_complex_log = \&PDL::gsl_sf_complex_log; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/POLY.pm���������������������������������������������������������������0000644�0601750�0601001�00000003077�13110402062�014304� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::POLY; @EXPORT_OK = qw( PDL::PP gsl_poly_eval ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::POLY ; =head1 NAME PDL::GSLSF::POLY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. NOTE: this should actually be PDL::POLY for consistency but I don't want to get into edits changing the directory structure at this time. These fixes should allow things to build. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_poly_eval =for sig Signature: (double x(); double c(m); double [o]y()) =for ref c[0] + c[1] x + c[2] x^2 + ... + c[m-1] x^(m-1) =for bad gsl_poly_eval does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_poly_eval = \&PDL::gsl_poly_eval; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/POW_INT.pm������������������������������������������������������������0000644�0601750�0601001�00000002577�13110402054�014705� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::POW_INT; @EXPORT_OK = qw( PDL::PP gsl_sf_pow_int ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::POW_INT ; =head1 NAME PDL::GSLSF::POW_INT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_pow_int =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Calculate x^n. =for bad gsl_sf_pow_int does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_pow_int = \&PDL::gsl_sf_pow_int; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/PSI.pm����������������������������������������������������������������0000644�0601750�0601001�00000004240�13110402061�014144� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::PSI; @EXPORT_OK = qw( PDL::PP gsl_sf_psi PDL::PP gsl_sf_psi_1piy PDL::PP gsl_sf_psi_n ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::PSI ; =head1 NAME PDL::GSLSF::PSI - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Poly-Gamma Functions psi(m,x) := (d/dx)^m psi(0,x) = (d/dx)^{m+1} log(gamma(x)) =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_psi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Di-Gamma Function psi(x). =for bad gsl_sf_psi does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_psi = \&PDL::gsl_sf_psi; =head2 gsl_sf_psi_1piy =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Di-Gamma Function Re[psi(1 + I y)] =for bad gsl_sf_psi_1piy does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_psi_1piy = \&PDL::gsl_sf_psi_1piy; =head2 gsl_sf_psi_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Poly-Gamma Function psi^(n)(x) =for bad gsl_sf_psi_n does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_psi_n = \&PDL::gsl_sf_psi_n; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/SYNCHROTRON.pm��������������������������������������������������������0000644�0601750�0601001�00000003633�13110402055�015351� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::SYNCHROTRON; @EXPORT_OK = qw( PDL::PP gsl_sf_synchrotron_1 PDL::PP gsl_sf_synchrotron_2 ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::SYNCHROTRON ; =head1 NAME PDL::GSLSF::SYNCHROTRON - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_synchrotron_1 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref First synchrotron function: synchrotron_1(x) = x Integral[ K_{5/3}(t), {t, x, Infinity}] =for bad gsl_sf_synchrotron_1 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_synchrotron_1 = \&PDL::gsl_sf_synchrotron_1; =head2 gsl_sf_synchrotron_2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Second synchroton function: synchrotron_2(x) = x * K_{2/3}(x) =for bad gsl_sf_synchrotron_2 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_synchrotron_2 = \&PDL::gsl_sf_synchrotron_2; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/TRANSPORT.pm����������������������������������������������������������0000644�0601750�0601001�00000005037�13110402060�015111� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::TRANSPORT; @EXPORT_OK = qw( PDL::PP gsl_sf_transport_2 PDL::PP gsl_sf_transport_3 PDL::PP gsl_sf_transport_4 PDL::PP gsl_sf_transport_5 ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::TRANSPORT ; =head1 NAME PDL::GSLSF::TRANSPORT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Transport function: J(n,x) := Integral[ t^n e^t /(e^t - 1)^2, {t,0,x}] =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_transport_2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(2,x) =for bad gsl_sf_transport_2 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_transport_2 = \&PDL::gsl_sf_transport_2; =head2 gsl_sf_transport_3 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(3,x) =for bad gsl_sf_transport_3 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_transport_3 = \&PDL::gsl_sf_transport_3; =head2 gsl_sf_transport_4 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(4,x) =for bad gsl_sf_transport_4 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_transport_4 = \&PDL::gsl_sf_transport_4; =head2 gsl_sf_transport_5 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(5,x) =for bad gsl_sf_transport_5 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_transport_5 = \&PDL::gsl_sf_transport_5; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/TRIG.pm���������������������������������������������������������������0000644�0601750�0601001�00000015057�13110402064�014271� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::TRIG; @EXPORT_OK = qw( PDL::PP gsl_sf_sin PDL::PP gsl_sf_cos PDL::PP gsl_sf_hypot PDL::PP gsl_sf_complex_sin PDL::PP gsl_sf_complex_cos PDL::PP gsl_sf_complex_logsin PDL::PP gsl_sf_lnsinh PDL::PP gsl_sf_lncosh PDL::PP gsl_sf_polar_to_rect PDL::PP gsl_sf_rect_to_polar PDL::PP gsl_sf_angle_restrict_symm PDL::PP gsl_sf_angle_restrict_pos PDL::PP gsl_sf_sin_err PDL::PP gsl_sf_cos_err ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::TRIG ; =head1 NAME PDL::GSLSF::TRIG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_sin =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Sin(x) with GSL semantics. =for bad gsl_sf_sin does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_sin = \&PDL::gsl_sf_sin; =head2 gsl_sf_cos =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Cos(x) with GSL semantics. =for bad gsl_sf_cos does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_cos = \&PDL::gsl_sf_cos; =head2 gsl_sf_hypot =for sig Signature: (double x(); double xx(); double [o]y(); double [o]e()) =for ref Hypot(x,xx) with GSL semantics. =for bad gsl_sf_hypot does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hypot = \&PDL::gsl_sf_hypot; =head2 gsl_sf_complex_sin =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Sin(z) for complex z =for bad gsl_sf_complex_sin does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_complex_sin = \&PDL::gsl_sf_complex_sin; =head2 gsl_sf_complex_cos =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Cos(z) for complex z =for bad gsl_sf_complex_cos does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_complex_cos = \&PDL::gsl_sf_complex_cos; =head2 gsl_sf_complex_logsin =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Log(Sin(z)) for complex z =for bad gsl_sf_complex_logsin does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_complex_logsin = \&PDL::gsl_sf_complex_logsin; =head2 gsl_sf_lnsinh =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Log(Sinh(x)) with GSL semantics. =for bad gsl_sf_lnsinh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lnsinh = \&PDL::gsl_sf_lnsinh; =head2 gsl_sf_lncosh =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Log(Cos(x)) with GSL semantics. =for bad gsl_sf_lncosh does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_lncosh = \&PDL::gsl_sf_lncosh; =head2 gsl_sf_polar_to_rect =for sig Signature: (double r(); double t(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Convert polar to rectlinear coordinates. =for bad gsl_sf_polar_to_rect does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_polar_to_rect = \&PDL::gsl_sf_polar_to_rect; =head2 gsl_sf_rect_to_polar =for sig Signature: (double x(); double y(); double [o]r(); double [o]t(); double [o]re(); double [o]te()) =for ref Convert rectlinear to polar coordinates. return argument in range [-pi, pi]. =for bad gsl_sf_rect_to_polar does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_rect_to_polar = \&PDL::gsl_sf_rect_to_polar; =head2 gsl_sf_angle_restrict_symm =for sig Signature: (double [o]y()) =for ref Force an angle to lie in the range (-pi,pi]. =for bad gsl_sf_angle_restrict_symm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_angle_restrict_symm = \&PDL::gsl_sf_angle_restrict_symm; =head2 gsl_sf_angle_restrict_pos =for sig Signature: (double [o]y()) =for ref Force an angle to lie in the range [0,2 pi). =for bad gsl_sf_angle_restrict_pos does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_angle_restrict_pos = \&PDL::gsl_sf_angle_restrict_pos; =head2 gsl_sf_sin_err =for sig Signature: (double x(); double dx(); double [o]y(); double [o]e()) =for ref Sin(x) for quantity with an associated error. =for bad gsl_sf_sin_err does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_sin_err = \&PDL::gsl_sf_sin_err; =head2 gsl_sf_cos_err =for sig Signature: (double x(); double dx(); double [o]y(); double [o]e()) =for ref Cos(x) for quantity with an associated error. =for bad gsl_sf_cos_err does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_cos_err = \&PDL::gsl_sf_cos_err; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/GSLSF/ZETA.pm���������������������������������������������������������������0000644�0601750�0601001�00000004232�13110402057�014262� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ZETA; @EXPORT_OK = qw( PDL::PP gsl_sf_zeta PDL::PP gsl_sf_hzeta PDL::PP gsl_sf_eta ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ZETA ; =head1 NAME PDL::GSLSF::ZETA - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut =head1 FUNCTIONS =cut =head2 gsl_sf_zeta =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Riemann Zeta Function zeta(x) = Sum[ k^(-s), {k,1,Infinity} ], s != 1.0 =for bad gsl_sf_zeta does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_zeta = \&PDL::gsl_sf_zeta; =head2 gsl_sf_hzeta =for sig Signature: (double s(); double [o]y(); double [o]e(); double q) =for ref Hurwicz Zeta Function zeta(s,q) = Sum[ (k+q)^(-s), {k,0,Infinity} ] =for bad gsl_sf_hzeta does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_hzeta = \&PDL::gsl_sf_hzeta; =head2 gsl_sf_eta =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Eta Function eta(s) = (1-2^(1-s)) zeta(s) =for bad gsl_sf_eta does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gsl_sf_eta = \&PDL::gsl_sf_eta; ; =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin <chri@infis.univ.trieste.it> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Image2D.pm������������������������������������������������������������������0000644�0601750�0601001�00000073207�13110402063�014056� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Image2D; @EXPORT_OK = qw( PDL::PP conv2d PDL::PP med2d PDL::PP med2df PDL::PP box2d PDL::PP patch2d PDL::PP patchbad2d PDL::PP max2d_ind PDL::PP centroid2d cc8compt cc4compt PDL::PP ccNcompt polyfill pnpoly polyfillv rotnewsz PDL::PP rot2d PDL::PP bilin2d PDL::PP rescale2d fitwarp2d applywarp2d PDL::PP warp2d warp2d_kernel PDL::PP warp2d_kernel ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Image2D ; =head1 NAME PDL::Image2D - Miscellaneous 2D image processing functions =head1 DESCRIPTION Miscellaneous 2D image processing functions - for want of anywhere else to put them. =head1 SYNOPSIS use PDL::Image2D; =cut use PDL; # ensure qsort routine available use PDL::Math; use Carp; use strict; =head1 FUNCTIONS =cut =head2 conv2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); int opt) =for ref 2D convolution of an array with a kernel (smoothing) For large kernels, using a FFT routine, such as L<fftconvolve()|PDL::FFT/fftconvolve()> in C<PDL::FFT>, will be quicker. =for usage $new = conv2d $old, $kernel, {OPTIONS} =for example $smoothed = conv2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =for bad Unlike the FFT routines, conv2d is able to process bad values. =cut sub PDL::conv2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: conv2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )' if $#_<1 || $#_>2; my($a,$kern) = @_; my $c = $#_ == 2 ? $_[2] : $a->nullcreate; &PDL::_conv2d_int($a,$kern,$c, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } *conv2d = \&PDL::conv2d; =head2 med2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); int opt) =for ref 2D median-convolution of an array with a kernel (smoothing) Note: only points in the kernel E<gt>0 are included in the median, other points are weighted by the kernel value (medianing lots of zeroes is rather pointless) =for usage $new = med2d $old, $kernel, {OPTIONS} =for example $smoothed = med2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =for bad Bad values are ignored in the calculation. If all elements within the kernel are bad, the output is set bad. =cut sub PDL::med2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: med2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )' if $#_<1 || $#_>2; my($a,$kern) = @_; croak "med2d: kernel must contain some positive elements.\n" if all( $kern <= 0 ); my $c = $#_ == 2 ? $_[2] : $a->nullcreate; &PDL::_med2d_int($a,$kern,$c, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } *med2d = \&PDL::med2d; =head2 med2df =for sig Signature: (a(m,n); [o]b(m,n); int __p_size; int __q_size; int opt) =for ref 2D median-convolution of an array in a pxq window (smoothing) Note: this routine does the median over all points in a rectangular window and is not quite as flexible as C<med2d> in this regard but slightly faster instead =for usage $new = med2df $old, $xwidth, $ywidth, {OPTIONS} =for example $smoothed = med2df $image, 3, 3, {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =for bad med2df does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::med2df { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: med2df( a(m,n), [o]b(m,n), p, q, {Options} )' if $#_<2 || $#_>3; my($a,$p,$q) = @_; croak "med2df: kernel must contain some positive elements.\n" if $p == 0 && $q == 0; my $c = $#_ == 3 ? $_[3] : $a->nullcreate; &PDL::_med2df_int($a,$c,$p,$q, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } *med2df = \&PDL::med2df; =head2 box2d =for sig Signature: (a(n,m); [o] b(n,m); int wx; int wy; int edgezero) =for ref fast 2D boxcar average =for example $smoothim = $im->box2d($wx,$wy,$edgezero=1); The edgezero argument controls if edge is set to zero (edgezero=1) or just keeps the original (unfiltered) values. C<box2d> should be updated to support similar edge options as C<conv2d> and C<med2d> etc. Boxcar averaging is a pretty crude way of filtering. For serious stuff better filters are around (e.g., use L<conv2d|conv2d> with the appropriate kernel). On the other hand it is fast and computational cost grows only approximately linearly with window size. =for bad box2d does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *box2d = \&PDL::box2d; =head2 patch2d =for sig Signature: (a(m,n); int bad(m,n); [o]b(m,n)) =for ref patch bad pixels out of 2D images using a mask =for usage $patched = patch2d $data, $bad; C<$bad> is a 2D mask array where 1=bad pixel 0=good pixel. Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the original data value is copied across. =for bad This routine does not handle bad values - use L<patchbad2d|/patchbad2d> instead =cut *patch2d = \&PDL::patch2d; =head2 patchbad2d =for sig Signature: (a(m,n); [o]b(m,n)) =for ref patch bad pixels out of 2D images containing bad values =for usage $patched = patchbad2d $data; Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the output is set bad. If the input piddle contains I<no> bad values, then a straight copy is performed (see L<patch2d|/patch2d>). =for bad patchbad2d handles bad values. The output piddle I<may> contain bad values, depending on the pattern of bad values in the input piddle. =cut *patchbad2d = \&PDL::patchbad2d; =head2 max2d_ind =for sig Signature: (a(m,n); [o]val(); int [o]x(); int[o]y()) =for ref Return value/position of maximum value in 2D image Contributed by Tim Jeness =for bad Bad values are excluded from the search. If all pixels are bad then the output is set bad. =cut *max2d_ind = \&PDL::max2d_ind; =head2 centroid2d =for sig Signature: (im(m,n); x(); y(); box(); [o]xcen(); [o]ycen()) =for ref Refine a list of object positions in 2D image by centroiding in a box C<$box> is the full-width of the box, i.e. the window is C<+/- $box/2>. =for bad Bad pixels are excluded from the centroid calculation. If all elements are bad (or the pixel sum is 0 - but why would you be centroiding something with negatives in...) then the output values are set bad. =cut *centroid2d = \&PDL::centroid2d; =head2 cc8compt =for ref Connected 8-component labeling of a binary image. Connected 8-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 8-component labeling includes all neighboring pixels. This is just a front-end to ccNcompt. See also L<cc4compt|cc4compt>. =for example $segmented = cc8compt( $image > $threshold ); =head2 cc4compt =for ref Connected 4-component labeling of a binary image. Connected 4-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 4-component labling does not include the diagonal neighbors. This is just a front-end to ccNcompt. See also L<cc8compt|cc8compt>. =for example $segmented = cc4compt( $image > $threshold ); =cut sub PDL::cc8compt{ return ccNcompt(shift,8); } *cc8compt = \&PDL::cc8compt; sub PDL::cc4compt{ return ccNcompt(shift,4); } *cc4compt = \&PDL::cc4compt; =head2 ccNcompt =for sig Signature: (a(m,n); int+ [o]b(m,n); int con) =for ref Connected component labeling of a binary image. Connected component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. See also L<cc4compt|cc4compt> and L<cc8compt|cc8compt>. The connectivity parameter must be 4 or 8. =for example $segmented = ccNcompt( $image > $threshold, 4); $segmented2 = ccNcompt( $image > $threshold, 8); where the second parameter specifies the connectivity (4 or 8) of the labeling. =for bad ccNcompt ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ccNcompt = \&PDL::ccNcompt; =head2 polyfill =for ref fill the area of the given polygon with the given colour. This function works inplace, i.e. modifies C<im>. =for usage polyfill($im,$ps,$colour,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L<pnpoly|pnpoly>. Often, it includes vertices and edge points. Set the C<Method> option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L<pnpoly|pnpoly> algorithm =for example # Make a convex 3x3 square of 1s in an image using the pnpoly algorithm $ps = pdl([3,3],[3,6],[6,6],[6,3]); polyfill($im,$ps,1,{'Method' =>'pnpoly'}); =cut sub PDL::polyfill { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfill($im,$ps,$colour,[\%options])') unless @_==3; my ($im,$ps,$colour) = @_; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); if( $parsed->current->{'Method'} eq 'pnpoly' ) { PDL::pnpolyfill_pp($im,$ps,$colour); } } else { PDL::polyfill_pp($im,$ps,$colour); } return $im; } *polyfill = \&PDL::polyfill; =head2 pnpoly =for ref 'points in a polygon' selection from a 2-D piddle =for usage $mask = $img->pnpoly($ps); # Old style, do not use $mask = pnpoly($x, $y, $px, $py); For a closed polygon determined by the sequence of points in {$px,$py} the output of pnpoly is a mask corresponding to whether or not each coordinate (x,y) in the set of test points, {$x,$y}, is in the interior of the polygon. This is the 'points in a polygon' algorithm from L<http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html> and vectorized for PDL by Karl Glazebrook. =for example # define a 3-sided polygon (a triangle) $ps = pdl([3, 3], [20, 20], [34, 3]); # $tri is 0 everywhere except for points in polygon interior $tri = $img->pnpoly($ps); With the second form, the x and y coordinates must also be specified. B< I<THIS IS MAINTAINED FOR BACKWARD COMPATIBILITY ONLY> >. $px = pdl( 3, 20, 34 ); $py = pdl( 3, 20, 3 ); $x = $img->xvals; # get x pixel coords $y = $img->yvals; # get y pixel coords # $tri is 0 everywhere except for points in polygon interior $tri = pnpoly($x,$y,$px,$py); =cut # From: http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html # # Fixes needed to pnpoly code: # # Use topdl() to ensure piddle args # # Add POD docs for usage # # Calculate first term in & expression to use to fix divide-by-zero when # the test point is in line with a vertical edge of the polygon. # By adding the value of $mask we prevent a divide-by-zero since the & # operator does not "short circuit". sub PDL::pnpoly { barf('Usage: $mask = pnpoly($img, $ps);') unless(@_==2 || @_==4); my ($tx, $ty, $vertx, $verty) = @_; # if only two inputs, use the pure PP version unless( defined $vertx ) { barf("ps must contain pairwise points.\n") unless $ty->getdim(0) == 2; # Input mapping: $img => $tx, $ps => $ty return PDL::pnpoly_pp($tx,$ty); } my $testx = PDL::Core::topdl($tx)->dummy(0); my $testy = PDL::Core::topdl($ty)->dummy(0); my $vertxj = PDL::Core::topdl($vertx)->rotate(1); my $vertyj = PDL::Core::topdl($verty)->rotate(1); my $mask = ( ($verty>$testy) == ($vertyj>$testy) ); my $c = sumover( ! $mask & ( $testx < ($vertxj-$vertx) * ($testy-$verty) / ($vertyj-$verty+$mask) + $vertx) ) % 2; return $c; } *pnpoly = \&PDL::pnpoly; =head2 polyfillv =for ref return the (dataflown) area of an image described by a polygon =for usage polyfillv($im,$ps,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L<pnpoly|pnpoly>. Often, it includes vertices and edge points. Set the C<Method> option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L<pnpoly|pnpoly> algorithm =for example # increment intensity in area bounded by $poly using the pnpoly algorithm $im->polyfillv($poly,{'Method'=>'pnpoly'})++; # legal in perl >= 5.6 # compute average intensity within area bounded by $poly using the default algorithm $av = $im->polyfillv($poly)->avg; =cut sub PDL::polyfillv :lvalue { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfillv($im,$ps,[\%options])') unless @_==2; my ($im,$ps) = @_; barf("ps must contain pairwise points.\n") unless $ps->getdim(0) == 2; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); return $im->where(PDL::pnpoly_pp($im, $ps)) if $parsed->current->{'Method'} eq 'pnpoly'; } my $msk = zeroes(long,$im->dims); PDL::polyfill_pp($msk, $ps, 1); return $im->where($msk); } *polyfillv = \&PDL::polyfillv; =head2 rot2d =for sig Signature: (im(m,n); float angle(); bg(); int aa(); [o] om(p,q)) =for ref rotate an image by given C<angle> =for example # rotate by 10.5 degrees with antialiasing, set missing values to 7 $rot = $im->rot2d(10.5,7,1); This function rotates an image through an C<angle> between -90 and + 90 degrees. Uses/doesn't use antialiasing depending on the C<aa> flag. Pixels outside the rotated image are set to C<bg>. Code modified from pnmrotate (Copyright Jef Poskanzer) with an algorithm based on "A Fast Algorithm for General Raster Rotation" by Alan Paeth, Graphics Interface '86, pp. 77-81. Use the C<rotnewsz> function to find out about the dimension of the newly created image ($newcols,$newrows) = rotnewsz $oldn, $oldm, $angle; L<PDL::Transform|PDL::Transform> offers a more general interface to distortions, including rotation, with various types of sampling; but rot2d is faster. =for bad rot2d ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rot2d = \&PDL::rot2d; =head2 bilin2d =for sig Signature: (I(n,m); O(q,p)) =for ref Bilinearly maps the first piddle in the second. The interpolated values are actually added to the second piddle which is supposed to be larger than the first one. =for bad bilin2d ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bilin2d = \&PDL::bilin2d; =head2 rescale2d =for sig Signature: (I(m,n); O(p,q)) =for ref The first piddle is rescaled to the dimensions of the second (expanding or meaning values as needed) and then added to it in place. Nothing useful is returned. If you want photometric accuracy or automatic FITS header metadata tracking, consider using L<PDL::Transform::map|PDL::Transform/map> instead: it does these things, at some speed penalty compared to rescale2d. =for bad rescale2d ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rescale2d = \&PDL::rescale2d; =head2 fitwarp2d =for ref Find the best-fit 2D polynomial to describe a coordinate transformation. =for usage ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, $nf. { options } ) Given a set of points in the output plane (C<$u,$v>), find the best-fit (using singular-value decomposition) 2D polynomial to describe the mapping back to the image plane (C<$x,$y>). The order of the fit is controlled by the C<$nf> parameter (the maximum power of the polynomial is C<$nf - 1>), and you can restrict the terms to fit using the C<FIT> option. C<$px> and C<$py> are C<np> by C<np> element piddles which describe a polynomial mapping (of order C<np-1>) from the I<output> C<(u,v)> image to the I<input> C<(x,y)> image: x = sum(j=0,np-1) sum(i=0,np-1) px(i,j) * u^i * v^j y = sum(j=0,np-1) sum(i=0,np-1) py(i,j) * u^i * v^j The transformation is returned for the reverse direction (ie output to input image) since that is what is required by the L<warp2d()|/warp2d> routine. The L<applywarp2d()|/applywarp2d> routine can be used to convert a set of C<$u,$v> points given C<$px> and C<$py>. Options: =for options FIT - which terms to fit? default ones(byte,$nf,$nf) THRESH - in svd, remove terms smaller than THRESH * max value default is 1.0e-5 =over 4 =item FIT C<FIT> allows you to restrict which terms of the polynomial to fit: only those terms for which the FIT piddle evaluates to true will be evaluated. If a 2D piddle is sent in, then it is used for the x and y polynomials; otherwise C<$fit-E<gt>slice(":,:,(0)")> will be used for C<$px> and C<$fit-E<gt>slice(":,:,(1)")> will be used for C<$py>. =item THRESH Remove all singular values whose valus is less than C<THRESH> times the largest singular value. =back The number of points must be at least equal to the number of terms to fit (C<$nf*$nf> points for the default value of C<FIT>). =for example # points in original image $x = pdl( 0, 0, 100, 100 ); $y = pdl( 0, 100, 100, 0 ); # get warped to these positions $u = pdl( 10, 10, 90, 90 ); $v = pdl( 10, 90, 90, 10 ); # # shift of origin + scale x/y axis only $fit = byte( [ [1,1], [0,0] ], [ [1,0], [1,0] ] ); ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2, { FIT => $fit } ); print "px = ${px}py = $py"; px = [ [-12.5 1.25] [ 0 0] ] py = [ [-12.5 0] [ 1.25 0] ] # # Compared to allowing all 4 terms ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2 ); print "px = ${px}py = $py"; px = [ [ -12.5 1.25] [ 1.110223e-16 -1.1275703e-17] ] py = [ [ -12.5 1.6653345e-16] [ 1.25 -5.8546917e-18] ] =head2 applywarp2d =for ref Transform a set of points using a 2-D polynomial mapping =for usage ( $x, $y ) = applywarp2d( $px, $py, $u, $v ) Convert a set of points (stored in 1D piddles C<$u,$v>) to C<$x,$y> using the 2-D polynomial with coefficients stored in C<$px> and C<$py>. See L<fitwarp2d()|/fitwarp2d> for more information on the format of C<$px> and C<$py>. =cut # use SVD to fit data. Assuming no errors. sub _svd ($$$) { my $basis = shift; my $y = shift; my $thresh = shift; # if we had errors for these points, would normalise the # basis functions, and the output array, by these errors here # perform the SVD my ( $svd_u, $svd_w, $svd_v ) = svd( $basis ); # remove any singular values $svd_w *= ( $svd_w >= ($svd_w->max * $thresh ) ); # perform the back substitution # my $tmp = $y x $svd_u; if ( $PDL::Bad::Status ) { $tmp /= $svd_w->setvaltobad(0.0); $tmp->inplace->setbadtoval(0.0); } else { # not checked my $mask = ($svd_w == 0.0); $tmp /= ( $svd_w + $mask ); $tmp *= ( 1 - $mask ); } my $ans = sumover( $svd_v * $tmp ); return $ans; } # sub: _svd() sub _mkbasis ($$$$) { my $fit = shift; my $npts = shift; my $u = shift; my $v = shift; my $n = $fit->getdim(0) - 1; my $ncoeff = sum( $fit ); my $basis = zeroes( $u->type, $ncoeff, $npts ); my $k = 0; foreach my $j ( 0 .. $n ) { my $tmp_v = $v**$j; foreach my $i ( 0 .. $n ) { if ( $fit->at($i,$j) ) { my $tmp = $basis->slice("($k),:"); $tmp .= $tmp_v * $u**$i; $k++; } } } return $basis; } # sub: _mkbasis() sub PDL::fitwarp2d { croak "Usage: (\$px,\$py) = fitwarp2d(x(m);y(m);u(m);v(m);\$nf; { options })" if $#_ < 4 or ( $#_ >= 5 and ref($_[5]) ne "HASH" ); my $x = shift; my $y = shift; my $u = shift; my $v = shift; my $nf = shift; my $opts = PDL::Options->new( { FIT => ones(byte,$nf,$nf), THRESH => 1.0e-5 } ); $opts->options( $_[0] ) if $#_ > -1; my $oref = $opts->current(); # safety checks my $npts = $x->nelem; croak "fitwarp2d: x, y, u, and v must be the same size (and 1D)" unless $npts == $y->nelem and $npts == $u->nelem and $npts == $v->nelem and $x->getndims == 1 and $y->getndims == 1 and $u->getndims == 1 and $v->getndims == 1; my $svd_thresh = $$oref{THRESH}; croak "fitwarp2d: THRESH option must be >= 0." if $svd_thresh < 0; my $fit = $$oref{FIT}; my $fit_ndim = $fit->getndims(); croak "fitwarp2d: FIT option must be sent a (\$nf,\$nf[,2]) element piddle" unless UNIVERSAL::isa($fit,"PDL") and ($fit_ndim == 2 or ($fit_ndim == 3 and $fit->getdim(2) == 2)) and $fit->getdim(0) == $nf and $fit->getdim(1) == $nf; # how many coeffs to fit (first we ensure $fit is either 0 or 1) $fit = convert( $fit != 0, byte ); my ( $fitx, $fity, $ncoeffx, $ncoeffy, $ncoeff ); if ( $fit_ndim == 2 ) { $fitx = $fit; $fity = $fit; $ncoeff = $ncoeffx = $ncoeffy = sum( $fit ); } else { $fitx = $fit->slice(",,(0)"); $fity = $fit->slice(",,(1)"); $ncoeffx = sum($fitx); $ncoeffy = sum($fity); $ncoeff = $ncoeffx > $ncoeffy ? $ncoeffx : $ncoeffy; } croak "fitwarp2d: number of points must be >= \$ncoeff" unless $npts >= $ncoeff; # create the basis functions for the SVD fitting my ( $basisx, $basisy ); $basisx = _mkbasis( $fitx, $npts, $u, $v ); if ( $fit_ndim == 2 ) { $basisy = $basisx; } else { $basisy = _mkbasis( $fity, $npts, $u, $v ); } my $px = _svd( $basisx, $x, $svd_thresh ); my $py = _svd( $basisy, $y, $svd_thresh ); # convert into $nf x $nf element piddles, if necessary my $nf2 = $nf * $nf; return ( $px->reshape($nf,$nf), $py->reshape($nf,$nf) ) if $ncoeff == $nf2 and $ncoeffx == $ncoeffy; # re-create the matrix my $xtmp = zeroes( $nf, $nf ); my $ytmp = zeroes( $nf, $nf ); my $kx = 0; my $ky = 0; foreach my $i ( 0 .. ($nf - 1) ) { foreach my $j ( 0 .. ($nf - 1) ) { if ( $fitx->at($i,$j) ) { $xtmp->set($i,$j, $px->at($kx) ); $kx++; } if ( $fity->at($i,$j) ) { $ytmp->set($i,$j, $py->at($ky) ); $ky++; } } } return ( $xtmp, $ytmp ) } # sub: fitwarp2d *fitwarp2d = \&PDL::fitwarp2d; sub PDL::applywarp2d { # checks croak "Usage: (\$x,\$y) = applywarp2d(px(nf,nf);py(nf,nf);u(m);v(m);)" if $#_ != 3; my $px = shift; my $py = shift; my $u = shift; my $v = shift; my $npts = $u->nelem; # safety check croak "applywarp2d: u and v must be the same size (and 1D)" unless $npts == $u->nelem and $npts == $v->nelem and $u->getndims == 1 and $v->getndims == 1; my $nf = $px->getdim(0); my $nf2 = $nf * $nf; # could remove terms with 0 coeff here # (would also have to remove them from px/py for # the matrix multiplication below) # my $mat = _mkbasis( ones(byte,$nf,$nf), $npts, $u, $v ); my $x = reshape( $mat x $px->clump(-1)->transpose(), $npts ); my $y = reshape( $mat x $py->clump(-1)->transpose(), $npts ); return ( $x, $y ); } # sub: applywarp2d *applywarp2d = \&PDL::applywarp2d; =head2 warp2d =for sig Signature: (img(m,n); double px(np,np); double py(np,np); [o] warp(m,n); { options }) =for ref Warp a 2D image given a polynomial describing the I<reverse> mapping. =for usage $out = warp2d( $img, $px, $py, { options } ); Apply the polynomial transformation encoded in the C<$px> and C<$py> piddles to warp the input image C<$img> into the output image C<$out>. The format for the polynomial transformation is described in the documentation for the L<fitwarp2d()|/fitwarp2d> routine. At each point C<x,y>, the closest 16 pixel values are combined with an interpolation kernel to calculate the value at C<u,v>. The interpolation is therefore done in the image, rather than Fourier, domain. By default, a C<tanh> kernel is used, but this can be changed using the C<KERNEL> option discussed below (the choice of kernel depends on the frequency content of the input image). The routine is based on the C<warping> command from the Eclipse data-reduction package - see http://www.eso.org/eclipse/ - and for further details on image resampling see Wolberg, G., "Digital Image Warping", 1990, IEEE Computer Society Press ISBN 0-8186-8944-7). Currently the output image is the same size as the input one, which means data will be lost if the transformation reduces the pixel scale. This will (hopefully) be changed soon. =for example $img = rvals(byte,501,501); imag $img, { JUSTIFY => 1 }; # # use a not-particularly-obvious transformation: # x = -10 + 0.5 * $u - 0.1 * $v # y = -20 + $v - 0.002 * $u * $v # $px = pdl( [ -10, 0.5 ], [ -0.1, 0 ] ); $py = pdl( [ -20, 0 ], [ 1, 0.002 ] ); $wrp = warp2d( $img, $px, $py ); # # see the warped image imag $warp, { JUSTIFY => 1 }; The options are: =for options KERNEL - default value is tanh NOVAL - default value is 0 C<KERNEL> is used to specify which interpolation kernel to use (to see what these kernels look like, use the L<warp2d_kernel()|/warp2d_kernel> routine). The options are: =over 4 =item tanh Hyperbolic tangent: the approximation of an ideal box filter by the product of symmetric tanh functions. =item sinc For a correctly sampled signal, the ideal filter in the fourier domain is a rectangle, which produces a C<sinc> interpolation kernel in the spatial domain: sinc(x) = sin(pi * x) / (pi * x) However, it is not ideal for the C<4x4> pixel region used here. =item sinc2 This is the square of the sinc function. =item lanczos Although defined differently to the C<tanh> kernel, the result is very similar in the spatial domain. The Lanczos function is defined as L(x) = sinc(x) * sinc(x/2) if abs(x) < 2 = 0 otherwise =item hann This kernel is derived from the following function: H(x) = a + (1-a) * cos(2*pi*x/(N-1)) if abs(x) < 0.5*(N-1) = 0 otherwise with C<a = 0.5> and N currently equal to 2001. =item hamming This kernel uses the same C<H(x)> as the Hann filter, but with C<a = 0.54>. =back C<NOVAL> gives the value used to indicate that a pixel in the output image does not map onto one in the input image. =cut # support routine { my %warp2d = map { ($_,1) } qw( tanh sinc sinc2 lanczos hamming hann ); # note: convert to lower case sub _check_kernel ($$) { my $kernel = lc shift; my $code = shift; barf "Unknown kernel $kernel sent to $code\n" . "\tmust be one of [" . join(',',keys %warp2d) . "]\n" unless exists $warp2d{$kernel}; return $kernel; } } sub PDL::warp2d { my $opts = PDL::Options->new( { KERNEL => "tanh", NOVAL => 0 } ); $opts->options( pop(@_) ) if ref($_[$#_]) eq "HASH"; die "Usage: warp2d( in(m,n), px(np,np); py(np,np); [o] out(m,n), {Options} )" if $#_<2 || $#_>3; my $img = shift; my $px = shift; my $py = shift; my $out = $#_ == -1 ? PDL->null() : shift; # safety checks my $copt = $opts->current(); my $kernel = _check_kernel( $$copt{KERNEL}, "warp2d" ); &PDL::_warp2d_int( $img, $px, $py, $out, $kernel, $$copt{NOVAL} ); return $out; } *warp2d = \&PDL::warp2d; =head2 warp2d_kernel =for ref Return the specified kernel, as used by L<warp2d|/warp2d> =for usage ( $x, $k ) = warp2d_kernel( $name ) The valid values for C<$name> are the same as the C<KERNEL> option of L<warp2d()|/warp2d>. =for example line warp2d_kernel( "hamming" ); =cut sub PDL::warp2d_kernel ($) { my $kernel = _check_kernel( shift, "warp2d_kernel" ); my $nelem = _get_kernel_size(); my $x = zeroes( $nelem ); my $k = zeroes( $nelem ); &PDL::_warp2d_kernel_int( $x, $k, $kernel ); return ( $x, $k ); # return _get_kernel( $kernel ); } *warp2d_kernel = \&PDL::warp2d_kernel; *warp2d_kernel = \&PDL::warp2d_kernel; ; =head1 AUTHORS Copyright (C) Karl Glazebrook 1997 with additions by Robin Williams (rjrw@ast.leeds.ac.uk), Tim Jeness (timj@jach.hawaii.edu), and Doug Burke (burke@ifa.hawaii.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/ImageND.pm������������������������������������������������������������������0000644�0601750�0601001�00000036424�13110402067�014116� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::ImageND; @EXPORT_OK = qw( kernctr PDL::PP convolve ninterpol PDL::PP rebin circ_mean circ_mean_p PDL::PP convolveND ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::ImageND ; =head1 NAME PDL::ImageND - useful image processing in N dimensions =head1 DESCRIPTION These routines act on PDLs as N-dimensional objects, not as threaded sets of 0-D or 1-D objects. The file is sort of a catch-all for broadly functional routines, most of which could legitimately be filed elsewhere (and probably will, one day). ImageND is not a part of the PDL core (v2.4) and hence must be explicitly loaded. =head1 SYNOPSIS use PDL::ImageND; $b = $a->convolveND($kernel,{bound=>'periodic'}); $b = $a->rebin(50,30,10); =cut =head1 FUNCTIONS =cut use Carp; =head2 convolve =for sig Signature: (a(m); b(n); indx adims(p); indx bdims(q); [o]c(m)) =for ref N-dimensional convolution (Deprecated; use convolveND) =for usage $new = convolve $a, $kernel Convolve an array with a kernel, both of which are N-dimensional. This routine does direct convolution (by copying) but uses quasi-periodic boundary conditions: each dim "wraps around" to the next higher row in the next dim. This routine is kept for backwards compatibility with earlier scripts; for most purposes you want L<convolveND|PDL::ImageND/convolveND> instead: it runs faster and handles a variety of boundary conditions. =for bad convolve does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut # Custom Perl wrapper sub PDL::convolve{ my($a,$b,$c) = @_; barf("Usage: convolve(a(*), b(*), [o]c(*)") if $#_<1 || $#_>2; $c = PDL->null if $#_<2; &PDL::_convolve_int( $a->clump(-1), $b->clump(-1), long([$a->dims]), long([$b->dims]), ($c->getndims>1? $c->clump(-1) : $c) ); $c->setdims([$a->dims]); if($a->is_inplace) { $a .= $c; $a->set_inplace(0); return $a; } return $c; } *convolve = \&PDL::convolve; =head2 ninterpol() =for ref N-dimensional interpolation routine =for sig Signature: ninterpol(point(),data(n),[o]value()) =for usage $value = ninterpol($point, $data); C<ninterpol> uses C<interpol> to find a linearly interpolated value in N dimensions, assuming the data is spread on a uniform grid. To use an arbitrary grid distribution, need to find the grid-space point from the indexing scheme, then call C<ninterpol> -- this is far from trivial (and ill-defined in general). See also L<interpND|PDL::Primitive/interpND>, which includes boundary conditions and allows you to switch the method of interpolation, but which runs somewhat slower. =cut *ninterpol = \&PDL::ninterpol; sub PDL::ninterpol { use PDL::Math 'floor'; use PDL::Primitive 'interpol'; print 'Usage: $a = ninterpolate($point(s), $data);' if $#_ != 1; my ($p, $y) = @_; my ($ip) = floor($p); # isolate relevant N-cube $y = $y->slice(join (',',map($_.':'.($_+1),list $ip))); for (list ($p-$ip)) { $y = interpol($_,$y->xvals,$y); } $y; } =head2 rebin =for sig Signature: (a(m); [o]b(n); int ns => n) =for ref N-dimensional rebinning algorithm =for usage $new = rebin $a, $dim1, $dim2,..;. $new = rebin $a, $template; $new = rebin $a, $template, {Norm => 1}; Rebin an N-dimensional array to newly specified dimensions. Specifying `Norm' keeps the sum constant, otherwise the intensities are kept constant. If more template dimensions are given than for the input pdl, these dimensions are created; if less, the final dimensions are maintained as they were. So if C<$a> is a 10 x 10 pdl, then C<rebin($a,15)> is a 15 x 10 pdl, while C<rebin($a,15,16,17)> is a 15 x 16 x 17 pdl (where the values along the final dimension are all identical). Expansion is performed by sampling; reduction is performed by averaging. If you want different behavior, use L<PDL::Transform::map|PDL::Transform/map> instead. PDL::Transform::map runs slower but is more flexible. =for bad rebin does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut # Custom Perl wrapper sub PDL::rebin { my($a) = shift; my($opts) = ref $_[-1] eq "HASH" ? pop : {}; my(@idims) = $a->dims; my(@odims) = ref $_[0] ? $_[0]->dims : @_; my($i,$b); foreach $i (0..$#odims) { if ($i > $#idims) { # Just dummy extra dimensions $a = $a->dummy($i,$odims[$i]); next; # rebin_int can cope with all cases, but code # 1->n and n->1 separately for speed } elsif ($odims[$i] != $idims[$i]) { # If something changes if (!($odims[$i] % $idims[$i])) { # Cells map 1 -> n my ($r) = $odims[$i]/$idims[$i]; $b = $a->mv($i,0)->dummy(0,$r)->clump(2); } elsif (!($idims[$i] % $odims[$i])) { # Cells map n -> 1 my ($r) = $idims[$i]/$odims[$i]; $a = $a->mv($i,0); # -> copy so won't corrupt input PDL $b = $a->slice("0:-1:$r")->copy; foreach (1..$r-1) { $b += $a->slice("$_:-1:$r"); } $b /= $r; } else { # Cells map n -> m &PDL::_rebin_int($a->mv($i,0), $b = null, $odims[$i]); } $a = $b->mv(0,$i); } } if (exists $opts->{Norm} and $opts->{Norm}) { my ($norm) = 1; for $i (0..$#odims) { if ($i > $#idims) { $norm /= $odims[$i]; } else { $norm *= $idims[$i]/$odims[$i]; } } return $a * $norm; } else { # Explicit copy so i) can't corrupt input PDL through this link # ii) don't waste space on invisible elements return $a -> copy; } } *rebin = \&PDL::rebin; =head2 circ_mean_p =for ref Calculates the circular mean of an n-dim image and returns the projection. Optionally takes the center to be used. =for usage $cmean=circ_mean_p($im); $cmean=circ_mean_p($im,{Center => [10,10]}); =cut sub circ_mean_p { my ($a,$opt) = @_; my ($rad,$sum,$norm); if (defined $opt) { $rad = long PDL::rvals($a,$opt); } else { $rad = long rvals $a; } $sum = zeroes($rad->max+1); PDL::indadd $a->clump(-1), $rad->clump(-1), $sum; # this does the real work $norm = zeroes($rad->max+1); PDL::indadd pdl(1), $rad->clump(-1), $norm; # equivalent to get norm $sum /= $norm; return $sum; } =head2 circ_mean =for ref Smooths an image by applying circular mean. Optionally takes the center to be used. =for usage circ_mean($im); circ_mean($im,{Center => [10,10]}); =cut sub circ_mean { my ($a,$opt) = @_; my ($rad,$sum,$norm,$a1); if (defined $opt) { $rad = long PDL::rvals($a,$opt); } else { $rad = long rvals $a; } $sum = zeroes($rad->max+1); PDL::indadd $a->clump(-1), $rad->clump(-1), $sum; # this does the real work $norm = zeroes($rad->max+1); PDL::indadd pdl(1), $rad->clump(-1), $norm; # equivalent to get norm $sum /= $norm; $a1 = $a->clump(-1); $a1 .= $sum->index($rad->clump(-1)); return $a; } =head2 kernctr =for ref `centre' a kernel (auxiliary routine to fftconvolve) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); kernctr centres a small kernel to emulate the behaviour of the direct convolution routines. =cut *kernctr = \&PDL::kernctr; sub PDL::kernctr { # `centre' the kernel, to match kernel & image sizes and # emulate convolve/conv2d. FIX: implement with phase shifts # in fftconvolve, with option tag barf "Must have image & kernel for kernctr" if $#_ != 1; my ($imag, $kern) = @_; my (@ni) = $imag->dims; my (@nk) = $kern->dims; barf "Kernel and image must have same number of dims" if $#ni != $#nk; my ($newk) = zeroes(double,@ni); my ($k,$n,$d,$i,@stri,@strk,@b); for ($i=0; $i <= $#ni; $i++) { $k = $nk[$i]; $n = $ni[$i]; barf "Kernel must be smaller than image in all dims" if ($n < $k); $d = int(($k-1)/2); $stri[$i][0] = "0:$d,"; $strk[$i][0] = (-$d-1).":-1,"; $stri[$i][1] = $d == 0 ? '' : ($d-$k+1).':-1,'; $strk[$i][1] = $d == 0 ? '' : '0:'.($k-$d-2).','; } # kernel is split between the 2^n corners of the cube my ($nchunk) = 2 << $#ni; CHUNK: for ($i=0; $i < $nchunk; $i++) { my ($stri,$strk); for ($n=0, $b=$i; $n <= $#ni; $n++, $b >>= 1) { next CHUNK if $stri[$n][$b & 1] eq ''; $stri .= $stri[$n][$b & 1]; $strk .= $strk[$n][$b & 1]; } chop ($stri); chop ($strk); ($t = $newk->slice($stri)) .= $kern->slice($strk); } $newk; } =head2 convolveND =for sig Signature: (k0(); SV *k; SV *aa; SV *a) =for ref Speed-optimized convolution with selectable boundary conditions =for usage $new = convolveND($a, $kernel, [ {options} ]); Conolve an array with a kernel, both of which are N-dimensional. If the kernel has fewer dimensions than the array, then the extra array dimensions are threaded over. There are options that control the boundary conditions and method used. The kernel's origin is taken to be at the kernel's center. If your kernel has a dimension of even order then the origin's coordinates get rounded up to the next higher pixel (e.g. (1,2) for a 3x4 kernel). This mimics the behavior of the earlier L<convolve|convolve> and L<fftconvolve|PDL::FFT/fftconvolve()> routines, so convolveND is a drop-in replacement for them. The kernel may be any size compared to the image, in any dimension. The kernel and the array are not quite interchangeable (as in mathematical convolution): the code is inplace-aware only for the array itself, and the only allowed boundary condition on the kernel is truncation. convolveND is inplace-aware: say C<convolveND(inplace $a ,$k)> to modify a variable in-place. You don't reduce the working memory that way -- only the final memory. OPTIONS Options are parsed by PDL::Options, so unique abbreviations are accepted. =over 3 =item boundary (default: 'truncate') The boundary condition on the array, which affects any pixel closer to the edge than the half-width of the kernel. The boundary conditions are the same as those accepted by L<range|PDL::Slices/range>, because this option is passed directly into L<range|PDL::Slices/range>. Useful options are 'truncate' (the default), 'extend', and 'periodic'. You can select different boundary conditions for different axes -- see L<range|PDL::Slices/range> for more detail. The (default) truncate option marks all the near-boundary pixels as BAD if you have bad values compiled into your PDL and the array's badflag is set. =item method (default: 'auto') The method to use for the convolution. Acceptable alternatives are 'direct', 'fft', or 'auto'. The direct method is an explicit copy-and-multiply operation; the fft method takes the Fourier transform of the input and output kernels. The two methods give the same answer to within double-precision numerical roundoff. The fft method is much faster for large kernels; the direct method is faster for tiny kernels. The tradeoff occurs when the array has about 400x more pixels than the kernel. The default method is 'auto', which chooses direct or fft convolution based on the size of the input arrays. =back NOTES At the moment there's no way to thread over kernels. That could/should be fixed. The threading over input is cheesy and should probably be fixed: currently the kernel just gets dummy dimensions added to it to match the input dims. That does the right thing tersely but probably runs slower than a dedicated threadloop. The direct copying code uses PP primarily for the generic typing: it includes its own threadloops. =for bad convolveND does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut use PDL::Options; # Perl wrapper conditions the data to make life easier for the PP sub. sub PDL::convolveND { my($a0,$k,$opt0) = @_; my $inplace = $a0->is_inplace; my $a = $a0->new_or_inplace; barf("convolveND: kernel (".join("x",$k->dims).") has more dims than source (".join("x",$a->dims).")\n") if($a->ndims < $k->ndims); # Coerce stuff all into the same type. Try to make sense. # The trivial conversion leaves dataflow intact (nontrivial conversions # don't), so the inplace code is OK. Non-inplace code: let the existing # PDL code choose what type is best. my $type; if($inplace) { $type = $a0->get_datatype; } else { my $z = $a->flat->index(0) + $k->flat->index(0); $type = $z->get_datatype; } $a = $a->convert($type); $k = $k->convert($type); ## Handle options -- $def is a static variable so it only gets set up once. our $def; unless(defined($def)) { $def = new PDL::Options( { Method=>'a', Boundary=>'t' } ); $def->minmatch(1); $def->casesens(0); } my $opt = $def->options(PDL::Options::ifhref($opt0)); ### # If the kernel has too few dimensions, we thread over the other # dims -- this is the same as supplying the kernel with dummy dims of # order 1, so, er, we do that. $k = $k->dummy($a->dims - 1, 1) if($a->ndims > $k->ndims); my $kdims = pdl($k->dims); ### # Decide whether to FFT or directly convolve: if we're in auto mode, # choose based on the relative size of the image and kernel arrays. my $fft = ( ($opt->{Method} =~ m/^a/i) ? ( $a->nelem > 2500 and ($a->nelem) <= ($k->nelem * 500) ) : ( $opt->{Method} !~ m/^[ds]/i ) ); ### # Pad the array to include boundary conditions my $adims = pdl($a->dims); my $koff = ($kdims/2)->ceil - 1; my $aa = $a->range( -$koff, $adims + $kdims, $opt->{Boundary} ) ->sever; if($fft) { # The eval here keeps conflicts from happening at compile time eval "use PDL::FFT" ; print "convolveND: using FFT method\n" if($PDL::debug); # FFT works best on doubles; do our work there then cast back # at the end. $aa = double($aa); my $aai = $aa->zeroes; my $kk = $aa->zeroes; my $kki = $aa->zeroes; my $tmp; # work around new perl -d "feature" ($tmp = $kk->range( - ($kdims/2)->floor, $kdims, 'p')) .= $k; PDL::fftnd($kk, $kki); PDL::fftnd($aa, $aai); { my($ii) = $kk * $aai + $aa * $kki; $aa = $aa * $kk - $kki * $aai; $aai .= $ii; } PDL::ifftnd($aa,$aai); $a .= $aa->range( $koff, $adims); } else { print "convolveND: using direct method\n" if($PDL::debug); ### The first argument is a dummy to set $GENERIC. &PDL::_convolveND_int( $k->flat->index(0), $k, $aa, $a ); } $a; } *convolveND = \&PDL::convolveND; ; =head1 AUTHORS Copyright (C) Karl Glazebrook and Craig DeForest, 1997, 2003 All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/ImageRGB.pm�����������������������������������������������������������������0000644�0601750�0601001�00000015132�13110402060�014211� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::ImageRGB; @EXPORT_OK = qw( interlrgb rgbtogr bytescl cquant PDL::PP cquant_c ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::ImageRGB ; =head1 NAME PDL::ImageRGB -- some utility functions for RGB image data handling =head1 DESCRIPTION Collection of a few commonly used routines involved in handling of RGB, palette and grayscale images. Not much more than a start. Should be a good place to exercise some of the thread/map/clump PP stuff. Other stuff that should/could go here: =over 3 =item * color space conversion =item * common image filters =item * image rebinning =back =head1 SYNOPSIS use PDL::ImageRGB; =cut use vars qw( $typecheck $EPS ); use PDL::Core; use PDL::Basic; use PDL::Primitive; use PDL::Types; use Carp; use strict 'vars'; $PDL::ImageRGB::EPS = 1e-7; # there is probably a more portable way =head1 FUNCTIONS =head2 cquant =for ref quantize and reduce colours in 8-bit images =for usage ($out, $lut) = cquant($image [,$ncols]); This function does color reduction for <=8bit displays and accepts 8bit RGB and 8bit palette images. It does this through an interface to the ppm_quant routine from the pbmplus package that implements the median cut routine which intellegently selects the 'best' colors to represent your image on a <= 8bit display (based on the median cut algorithm). Optional args: $ncols sets the maximum nunmber of colours used for the output image (defaults to 256). There are images where a different color reduction scheme gives better results (it seems this is true for images containing large areas with very smoothly changing colours). Returns a list containing the new palette image (type PDL_Byte) and the RGB colormap. =cut # full threading support intended *cquant = \&PDL::cquant; sub PDL::cquant { barf 'Usage: ($out,$olut) = cquant($image[,$ncols])' if $#_<0 || $#_>1; my $image = shift; my $ncols; if ($#_ >= 0 ) { $ncols=shift; } else { $ncols = 256; }; my @Dims = $image->dims; my ($out, $olut) = (null,null); barf "input must be byte (3,x,x)" if (@Dims < 2) || ($Dims[0] != 3) || ($image->get_datatype != $PDL_B); cquant_c($image,$out,$olut,$ncols); return ($out,$olut); } =head2 interlrgb =for ref Make an RGB image from a palette image and its lookup table. =for usage $rgb = $palette_im->interlrgb($lut) Input should be of an integer type and the lookup table (3,x,...). Will perform the lookup for any N-dimensional input pdl (i.e. 0D, 1D, 2D, ...). Uses the index command but will not dataflow by default. If you want it to dataflow the dataflow_forward flag must be set in the $lut piddle (you can do that by saying $lut->set_dataflow_f(1)). =cut # interlace a palette image, input as 8bit-image, RGB-lut (3,x,..) to # (R,G,B) format for each pixel in the image # should already support threading *interlrgb=\&PDL::interlrgb; sub PDL::interlrgb { my ($pdl,$lut) = @_; my $res; # for our purposes $lut should be (3,z) where z is the number # of colours in the lut barf "expecting (3,x) input" if ($lut->dims)[0] != 3; # do the conversion as an implicitly threaded index lookup if ($lut->fflows) { $res = $lut->xchg(0,1)->index($pdl->dummy(0)); } else { $res = $lut->xchg(0,1)->index($pdl->dummy(0))->sever; } return $res; } =head2 rgbtogr =for ref Converts an RGB image to a grey scale using standard transform =for usage $gr = $rgb->rgbtogr Performs a conversion of an RGB input image (3,x,....) to a greyscale image (x,.....) using standard formula: Grey = 0.301 R + 0.586 G + 0.113 B =cut # convert interlaced rgb image to grayscale # will convert any (3,...) dim pdl, i.e. also single lines, # stacks of RGB images, etc since implicit threading takes care of this # should already support threading *rgbtogr = \&PDL::rgbtogr; sub PDL::rgbtogr { barf "Usage: \$im->rgbtogr" if $#_ < 0; my $im = shift; barf "rgbtogr: expecting RGB (3,...) input" if (($im->dims)[0] != 3); my $type = $im->get_datatype; my $rgb = float([77,150,29])/256; # vector for rgb conversion my $oim = null; # flag PP we want it to allocate inner($im,$rgb,$oim); # do the conversion as a threaded inner prod return $oim->convert($type); # convert back to original type } =head2 bytescl =for ref Scales a pdl into a specified data range (default 0-255) =for usage $scale = $im->bytescl([$top]) By default $top=255, otherwise you have to give the desired top value as an argument to C<bytescl>. Normally C<bytescl> doesn't rescale data that fits already in the bounds 0..$top (it only does the type conversion if required). If you want to force it to rescale so that the max of the output is at $top and the min at 0 you give a negative $top value to indicate this. =cut # scale any pdl linearly so that its data fits into the range # 0<=x<=$ncols where $ncols<=255 # returns scaled data with type converted to byte # doesn't rescale but just typecasts if data already fits into range, i.e. # data ist not necessarily stretched to 0..$ncols # needs some changes for full threading support ?? (explicit threading?) *bytescl = \&PDL::bytescl; sub PDL::bytescl { barf 'Usage: bytescl $im[,$top]' if $#_ < 0; my $pdl = shift; my ($top,$force) = (255,0); $top = shift if $#_ > -1; if ($top < 0) { $force=1; $top *= -1; } $top = 255 if $top > 255; print "bytescl: scaling from 0..$top\n" if $PDL::debug; my ($max, $min); $max = max $pdl; $min = min $pdl; return byte $pdl if ($min >= 0 && $max <= $top && !$force); # check for pathological cases if (($max-$min) < $EPS) { print "bytescl: pathological case\n" if $PDL::debug; return byte $pdl if (abs($max) < $EPS) || ($max >= 0 && $max <= $top); return byte ($pdl/$max); } my $type = $pdl->get_datatype > $PDL_F ? $PDL_D : $PDL_F; return byte ($top*($pdl->convert($type)-$min)/($max-$min)+0.5); } ;# Exit with OK status 1; =head1 BUGS This package doesn't yet contain enough useful functions! =head1 AUTHOR Copyright 1997 Christian Soeller <c.soeller@auckland.ac.nz> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut *cquant_c = \&PDL::cquant_c; ; # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/�������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402070�012604� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/Browser.pm���������������������������������������������������������������0000644�0601750�0601001�00000002541�13110402054�014571� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Browser; @EXPORT_OK = qw( PDL::PP browse ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Browser ; =head1 NAME PDL::IO::Browser -- 2D data browser for PDL =head1 DESCRIPTION cursor terminal browser for piddles. =head1 SYNOPSIS use PDL::IO::Browser; =cut =head1 FUNCTIONS =cut =head2 browse =for sig Signature: (a(n,m)) =head2 browse =for ref browse a 2D array using terminal cursor keys =for usage browse $data This uses the CURSES library to allow one to scroll around a PDL array using the cursor keys. =for bad browse does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *browse = \&PDL::browse; ; =head1 AUTHOR Copyright (C) Robin Williams 1997 (rjrw@ast.leeds.ac.uk). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/GD.pm��������������������������������������������������������������������0000644�0601750�0601001�00000147663�13110402060�013454� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::GD; @EXPORT_OK = qw( PDL::PP write_png PDL::PP write_png_ex PDL::PP write_true_png PDL::PP write_true_png_ex write_png_best write_true_png_best recompress_png_best load_lut read_png read_true_png PDL::PP _read_true_png PDL::PP _read_png PDL::PP _gd_image_to_pdl_true PDL::PP _gd_image_to_pdl PDL::PP _pdl_to_gd_image_true PDL::PP _pdl_to_gd_image_lut read_png_lut PDL::PP _read_png_lut PDL::PP _gdImageColorAllocates PDL::PP _gdImageColorAllocateAlphas PDL::PP _gdImageSetPixels PDL::PP _gdImageLines PDL::PP _gdImageDashedLines PDL::PP _gdImageRectangles PDL::PP _gdImageFilledRectangles PDL::PP _gdImageFilledArcs PDL::PP _gdImageArcs PDL::PP _gdImageFilledEllipses gdAlphaBlend gdTrueColor gdTrueColorAlpha gdFree gdFontGetLarge gdFontGetSmall gdFontGetMediumBold gdFontGetGiant gdFontGetTiny ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::GD ; =head1 NAME PDL::IO::GD - Interface to the GD image library. =head1 SYNOPSIS my $pdl = sequence(byte, 30, 30); write_png($pdl, load_lut($lutfile), "test.png"); write_true_png(sequence(100, 100, 3), "test_true.png"); my $image = read_png("test.png"); my $image = read_true_png("test_true_read.png"); write_true_png($image, "test_true_read.out.png"); my $lut = read_png_lut("test.png"); $pdl = sequence(byte, 30, 30); write_png_ex($pdl, load_lut($lutfile), "test_nocomp.png", 0); write_png_ex($pdl, load_lut($lutfile), "test_bestcomp1.png", 9); write_png_best($pdl, load_lut($lutfile), "test_bestcomp2.png"); $pdl = sequence(100, 100, 3); write_true_png_ex($pdl, "test_true_nocomp.png", 0); write_true_png_ex($pdl, "test_true_bestcomp1.png", 9); write_true_png_best($pdl, "test_true_bestcomp2.png"); recompress_png_best("test_recomp_best.png"); =head1 DESCRIPTION This is the "General Interface" for the PDL::IO::GD library, and is actually several years old at this point (read: stable). If you're feeling frisky, try the new OO interface described below. The general version just provides several image IO utility functions you can use with piddle variables. It's deceptively useful, however. =cut =head1 FUNCTIONS =cut =head2 write_png =for sig Signature: (byte img(x,y); byte lut(i,j); char* filename) Writes a 2-d PDL variable out to a PNG file, using the supplied color look-up-table piddle (hereafter referred to as a LUT). The LUT contains a line for each value 0-255 with a corresponding R, G, and B value. =for bad write_png does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *write_png = \&PDL::write_png; =head2 write_png_ex =for sig Signature: (img(x,y); lut(i,j); char* filename; int level) =for ref Same as write_png(), except you can specify the compression level (0-9) as the last argument. =for bad write_png_ex does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *write_png_ex = \&PDL::write_png_ex; =head2 write_true_png =for sig Signature: (img(x,y,z); char* filename) Writes an (x, y, z(3)) PDL variable out to a PNG file, using a true color format. This means a larger file on disk, but can contain more than 256 colors. =for bad write_true_png does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *write_true_png = \&PDL::write_true_png; =head2 write_true_png_ex =for sig Signature: (img(x,y,z); char* filename; int level) =for ref Same as write_true_png(), except you can specify the compression level (0-9) as the last argument. =for bad write_true_png_ex does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *write_true_png_ex = \&PDL::write_true_png_ex; =head2 write_png_best( $img(piddle), $lut(piddle), $filename ) Like write_png(), but it assumes the best PNG compression (9). =cut sub write_png_best { my $img = shift; my $lut = shift; my $filename = shift; return write_png_ex( $img, $lut, $filename, 9 ); } # End of write_png_best()... =head2 write_true_png_best( $img(piddle), $filename ) Like write_true_png(), but it assumes the best PNG compression (9). =cut sub write_true_png_best { my $img = shift; my $filename = shift; return write_true_png_ex( $img, $filename, 9 ); } # End of write_true_png_best()... =head2 load_lut( $filename ) Loads a color look up table from an ASCII file. returns a piddle =cut sub load_lut { return xchg(byte(cat(rcols(shift))), 0, 1); } # end of load_lut()... =head2 read_png( $filename ) Reads a (palette) PNG image into a (new) PDL variable. =cut sub read_png { my $filename = shift; # Get the image dims... my $x = _get_png_xs($filename); my $y = _get_png_ys($filename); #print "\$x=$x\t\$y=$y\n"; my $temp = zeroes(long, $x, $y); _read_png($temp, $filename); return byte($temp); } # End of read_png()... =head2 read_png_true( $filename ) Reads a true color PNG image into a (new) PDL variable. =cut sub read_true_png { my $filename = shift; # Get the image dims... my $x = _get_png_xs($filename); my $y = _get_png_ys($filename); #print "\$x=$x\t\$y=$y\n"; my $temp = zeroes(long, $x, $y, 3); _read_true_png($temp, $filename); return byte($temp); } # End of read_png()... *_read_true_png = \&PDL::_read_true_png; *_read_png = \&PDL::_read_png; *_gd_image_to_pdl_true = \&PDL::_gd_image_to_pdl_true; *_gd_image_to_pdl = \&PDL::_gd_image_to_pdl; *_pdl_to_gd_image_true = \&PDL::_pdl_to_gd_image_true; *_pdl_to_gd_image_lut = \&PDL::_pdl_to_gd_image_lut; =head2 my $lut = read_png_lut( $filename ) Reads a color LUT from an already-existing palette PNG file. =cut sub read_png_lut { my $filename = shift; my $lut = zeroes(byte, 3, 256); _read_png_lut($lut, $filename); return $lut; } # End of read_png_lut()... *_read_png_lut = \&PDL::_read_png_lut; *_gdImageColorAllocates = \&PDL::_gdImageColorAllocates; *_gdImageColorAllocateAlphas = \&PDL::_gdImageColorAllocateAlphas; *_gdImageSetPixels = \&PDL::_gdImageSetPixels; *_gdImageLines = \&PDL::_gdImageLines; *_gdImageDashedLines = \&PDL::_gdImageDashedLines; *_gdImageRectangles = \&PDL::_gdImageRectangles; *_gdImageFilledRectangles = \&PDL::_gdImageFilledRectangles; *_gdImageFilledArcs = \&PDL::_gdImageFilledArcs; *_gdImageArcs = \&PDL::_gdImageArcs; *_gdImageFilledEllipses = \&PDL::_gdImageFilledEllipses; ; =head1 OO INTERFACE Object Oriented interface to the GD image library. =head1 SYNOPSIS # Open an existing file: # my $gd = PDL::IO::GD->new( { filename => "test.png" } ); # Query the x and y sizes: my $x = $gd->SX(); my $y = $gd->SY(); # Grab the PDL of the data: my $pdl = $gd->to_pdl(); # Kill this thing: $gd->DESTROY(); # Create a new object: # my $im = PDL::IO::GD->new( { x => 300, y => 300 } ); # Allocate some colors: # my $black = $im->ColorAllocate( 0, 0, 0 ); my $red = $im->ColorAllocate( 255, 0, 0 ); my $green = $im->ColorAllocate( 0, 255, 0 ); my $blue = $im->ColorAllocate( 0, 0, 255 ); # Draw a rectangle: $im->Rectangle( 10, 10, 290, 290, $red ); # Add some text: $im->String( gdFontGetLarge(), 20, 20, "Test Large Font!", $green ); # Write the output file: $im->write_Png( "test2.png" ); =head1 DESCRIPTION This is the Object-Oriented interface from PDL to the GD image library. See L<http://www.boutell.com/gd/> for more information on the GD library and how it works. =head2 IMPLEMENTATION NOTES Surprisingly enough, this interface has nothing to do with the other Perl->GD interface module, aka 'GD' (as in 'use GD;'). This is done from scratch over the years. Requires at least version 2.0.22 of the GD library, but it's only been thoroughly tested with gd-2.0.33, so it would be best to use that. The 2.0.22 requirement has to do with a change in GD's font handling functions, so if you don't use those, then don't worry about it. I should also add, the statement about "thoroughly tested" above is mostly a joke. This OO interface is very young, and it has I<barely> been tested at all, so if something breaks, email me and I'll get it fixed ASAP (for me). Functions that manipulate and query the image objects generally have a 'gdImage' prefix on the function names (ex: gdImageString()). I've created aliases here for all of those member functions so you don't have to keep typing 'gdImage' in your code, but the long version are in there as well. =head1 METHODS =cut use PDL; use PDL::Slices; use PDL::IO::Misc; # # Some helper functions: # sub _pkg_name { return "PDL::IO::GD::" . (shift) . "()"; } # ID a file type from it's filename: sub _id_image_file { my $filename = shift; return 'png' if( $filename =~ /\.png$/ ); return 'jpg' if( $filename =~ /\.jpe?g$/ ); return 'wbmp' if( $filename =~ /\.w?bmp$/ ); return 'gd' if( $filename =~ /\.gd$/ ); return 'gd2' if( $filename =~ /\.gd2$/ ); return 'gif' if( $filename =~ /\.gif$/ ); return 'xbm' if( $filename =~ /\.xbm$/ ); return undef; } # End of _id_image_file()... # Load a new file up (don't read it yet): sub _img_ptr_from_file { my $filename = shift; my $type = shift; return _gdImageCreateFromPng( $filename ) if( $type eq 'png' ); return _gdImageCreateFromJpeg( $filename ) if( $type eq 'jpg' ); return _gdImageCreateFromWBMP( $filename ) if( $type eq 'wbmp' ); return _gdImageCreateFromGd( $filename ) if( $type eq 'gd' ); return _gdImageCreateFromGd2( $filename ) if( $type eq 'gd2' ); return _gdImageCreateFromGif( $filename ) if( $type eq 'gif' ); return _gdImageCreateFromXbm( $filename ) if( $type eq 'xbm' ); return undef; } # End of _img_ptr_from_file()... # ID a file type from it's "magic" header in the image data: sub _id_image_data { my $data = shift; my $magic = substr($data,0,4); return 'png' if( $magic eq "\x89PNG" ); return 'jpg' if( $magic eq "\377\330\377\340" ); return 'jpg' if( $magic eq "\377\330\377\341" ); return 'jpg' if( $magic eq "\377\330\377\356" ); return 'gif' if( $magic eq "GIF8" ); return 'gd2' if( $magic eq "gd2\000" ); # Still need filters for WBMP and .gd! return undef; } # End of _id_image_data()... # Load a new data scalar up: sub _img_ptr_from_data { my $data = shift; my $type = shift; return _gdImageCreateFromPngPtr( $data ) if( $type eq 'png' ); return _gdImageCreateFromJpegPtr( $data ) if( $type eq 'jpg' ); return _gdImageCreateFromWBMPPtr( $data ) if( $type eq 'wbmp' ); return _gdImageCreateFromGdPtr( $data ) if( $type eq 'gd' ); return _gdImageCreateFromGd2Ptr( $data ) if( $type eq 'gd2' ); return _gdImageCreateFromGifPtr( $data ) if( $type eq 'gif' ); return undef; } # End of _img_ptr_from_data()... =head2 new Creates a new PDL::IO::GD object. Accepts a hash describing how to create the object. Accepts a single hash ( with curly braces ), an inline hash (the same, but without the braces) or a single string interpreted as a filename. Thus the following are all equivalent: PDL::IO::GD->new( {filename => 'image.png'} ); PDL::IO::GD->new( filename => 'image.png' ); PDL::IO::GD->new( 'image.png' ); If the hash has: pdl => $pdl_var (lut => $lut_piddle) Then a new GD is created from that PDL variable. filename => $file Then a new GD is created from the image file. x => $num, y => $num Then a new GD is created as a palette image, with size x, y x => $num, y => $num, true_color => 1 Then a new GD is created as a true color image, with size x, y data => $scalar (type => $typename) Then a new GD is created from the file data stored in $scalar. If no type is given, then it will try to guess the type of the data, but this will not work for WBMP and gd image types. For those types, you _must_ specify the type of the data, or the operation will fail. Valid types are: 'jpg', 'png', 'gif', 'gd', 'gd2', 'wbmp'. Example: my $gd = PDL::IO::GD->new({ pdl => $pdl_var }); my $gd = PDL::IO::GD->new({ pdl => $pdl_var, lut => $lut_piddle }); my $gd = PDL::IO::GD->new({ filename => "image.png" }); my $gd = PDL::IO::GD->new({ x => 100, y => 100 }); my $gd = PDL::IO::GD->new({ x => 100, y => 100, true_color => 1 }); my $gd = PDL::IO::GD->new({ data => $imageData }); my $gd = PDL::IO::GD->new({ data => $imageData, type => 'wbmp' }); =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; #my $self = $class->SUPER::new( @_ ); my $self = {}; my $sub = _pkg_name( "new" ); # Figure out our options: # I want a single hash. I handle several cases here my $options; if( @_ == 1 && ref $_[0] eq 'HASH' ) { # single hash argument. Just take it $options = shift; } elsif( @_ == 1 && ! ref $_[0] ) { # single scalar argument. Treat it as a filename by default my $filename = shift; $options = { filename => $filename }; } else { # the only other acceptable option is an inline hash. This is valid if I # have an even number of arguments, and the even-indexed ones (the keys) # are scalars if( @_ % 2 == 0 ) { my @pairs = @_; my $Npairs = scalar(@pairs)/2; use List::MoreUtils 'none'; if( List::MoreUtils::none { ref $pairs[2*$_] } 0..$Npairs-1 ) { # treat the arguments as a hash $options = { @pairs } } } } if( !defined $options ) { die <<EOF; PDL::IO::GD::new couldn't parse its arguments. Expected a hash-ref or an inline hash or just a filename EOF } if( defined( $options->{pdl} ) ) { # Create it from a PDL variable: my $pdl = $options->{pdl}; $pdl->make_physical(); my $num_dims = scalar( $pdl->dims() ); if( $num_dims == 2 ) { if( defined( $options->{lut} ) ) { my $ptr = zeroes( longlong, 1 ); my $lut = $options->{lut}; _pdl_to_gd_image_lut( $pdl, $lut, $ptr ); # print STDERR "in new (with lut), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_lut() failed!\n" if( $self->{IMG_PTR} == 0 ); } else { my $ptr = zeroes( longlong, 1 ); my $lut = sequence(byte, 255)->slice("*3,:"); _pdl_to_gd_image_lut( $pdl, $lut, $ptr ); # print STDERR "in new (no lut), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_lut() failed!\n" if( $self->{IMG_PTR} == 0 ); } } elsif( $num_dims == 3 ) { my $ptr = zeroes( longlong, 1 ); _pdl_to_gd_image_true( $pdl, $ptr ); # print STDERR "in new (ndims=3), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_true() failed!\n" if( $self->{IMG_PTR} == 0 ); } else { die "Can't create a PDL::IO::GD from a PDL with bad dims!\n"; } } elsif( exists( $options->{filename} ) ) { # Create it from a file: if( !defined $options->{filename} ) { die "PDL::IO::GD::new got an undefined filename. Giving up.\n"; } # Figure out what type of file it is: $self->{input_type} = _id_image_file( $options->{filename} ) or die "$sub: Can't determine image type of filename => \'$options->{filename}\'!\n"; # Read in the file: $self->{IMG_PTR} = _img_ptr_from_file( $options->{filename}, $self->{input_type} ) or die "$sub: Can't read in the input file!\n"; } elsif( defined( $options->{x} ) && defined( $options->{y} ) ) { # Create an empty image: my $done = 0; if( defined( $options->{true_color} ) ) { if( $options->{true_color} ) { # Create an empty true color image: $self->{IMG_PTR} = _gdImageCreateTrueColor( $options->{x}, $options->{y} ); die "$sub: _gdImageCreateTrueColor() failed!\n" if( $self->{IMG_PTR} == 0 ); $done = 1; } } unless( $done ) { # Create an empty palette image: $self->{IMG_PTR} = _gdImageCreatePalette( $options->{x}, $options->{y} ); die "$sub: _gdImageCreatePalette() failed!\n" if( $self->{IMG_PTR} == 0 ); } } elsif( defined( $options->{data} ) ) { # Create an image from the given image data: # Figure out what type of file it is: if( defined( $options->{type} ) && ( $options->{type} eq 'jpg' || $options->{type} eq 'png' || $options->{type} eq 'gif' || $options->{type} eq 'wbmp' || $options->{type} eq 'gd' || $options->{type} eq 'gd2' ) ) { $self->{input_type} = $options->{type}; } else { $self->{input_type} = _id_image_data( $options->{data} ) or die "$sub: Can't determine image type given data!\n"; } # Load the data: $self->{IMG_PTR} = _img_ptr_from_data( $options->{data}, $self->{input_type} ) or die "$sub: Can't load the input image data!\n"; } # Bless and return: # bless ($self, $class); return $self; } # End of new()... =head2 to_pdl When you're done playing with your GDImage and want a piddle back, use this function to return one. =cut sub to_pdl { my $self = shift; my $sub = _pkg_name( "to_pdl" ); my $x = $self->gdImageSX(); my $y = $self->gdImageSY(); if( $self->gdImageTrueColor() ) { my $pdl = zeroes(byte, $x, $y, 3); _gd_image_to_pdl_true( $pdl, $self->{IMG_PTR} ); return $pdl; } my $pdl = zeroes(byte, $x, $y); _gd_image_to_pdl( $pdl, $self->{IMG_PTR} ); return $pdl; } # End of to_pdl()... =head2 apply_lut( $lut(piddle) ) Does a $im->ColorAllocate() for and entire LUT piddle at once. The LUT piddle format is the same as for the general interface above. =cut sub apply_lut { my $self = shift; my $lut = shift; # Let the PDL threading engine sort this out: $self->ColorAllocates( $lut->slice("(0),:"), $lut->slice("(1),:"), $lut->slice("(2),:") ); } # End of apply_lut()... sub DESTROY { my $self = shift; my $sub = _pkg_name( "DESTROY" ); #print STDERR sprintf("$sub: destroying gdImagePtr: 0x%p (%d) (%ld) (%lld)!\n", $self->{IMG_PTR}, $self->{IMG_PTR},$self->{IMG_PTR},$self->{IMG_PTR}); if( defined( $self->{IMG_PTR} ) ) { _gdImageDestroy( $self->{IMG_PTR} ); delete( $self->{IMG_PTR} ); } } # End of DESTROY()... =head2 WARNING: All of the docs below this point are auto-generated (not to mention the actual code), so read with a grain of salt, and B<always> check the main GD documentation about how that function works and what it does. =cut =head2 write_Png $image->write_Png( $filename ) =cut sub write_Png { my $self = shift; return _gdImagePng ( $self->{IMG_PTR}, @_ ); } # End of write_Png()... =head2 write_PngEx $image->write_PngEx( $filename, $level ) =cut sub write_PngEx { my $self = shift; return _gdImagePngEx ( $self->{IMG_PTR}, @_ ); } # End of write_PngEx()... =head2 write_WBMP $image->write_WBMP( $fg, $filename ) =cut sub write_WBMP { my $self = shift; return _gdImageWBMP ( $self->{IMG_PTR}, @_ ); } # End of write_WBMP()... =head2 write_Jpeg $image->write_Jpeg( $filename, $quality ) =cut sub write_Jpeg { my $self = shift; return _gdImageJpeg ( $self->{IMG_PTR}, @_ ); } # End of write_Jpeg()... =head2 write_Gd $image->write_Gd( $filename ) =cut sub write_Gd { my $self = shift; return _gdImageGd ( $self->{IMG_PTR}, @_ ); } # End of write_Gd()... =head2 write_Gd2 $image->write_Gd2( $filename, $cs, $fmt ) =cut sub write_Gd2 { my $self = shift; return _gdImageGd2 ( $self->{IMG_PTR}, @_ ); } # End of write_Gd2()... =head2 write_Gif $image->write_Gif( $filename ) =cut sub write_Gif { my $self = shift; return _gdImageGif ( $self->{IMG_PTR}, @_ ); } # End of write_Gif()... =head2 get_Png_data $image->get_Png_data( ) =cut sub get_Png_data { my $self = shift; return _gdImagePngPtr ( $self->{IMG_PTR}, @_ ); } # End of get_Png_data()... =head2 get_PngEx_data $image->get_PngEx_data( $level ) =cut sub get_PngEx_data { my $self = shift; return _gdImagePngPtrEx ( $self->{IMG_PTR}, @_ ); } # End of get_PngEx_data()... =head2 get_WBMP_data $image->get_WBMP_data( $fg ) =cut sub get_WBMP_data { my $self = shift; return _gdImageWBMPPtr ( $self->{IMG_PTR}, @_ ); } # End of get_WBMP_data()... =head2 get_Jpeg_data $image->get_Jpeg_data( $quality ) =cut sub get_Jpeg_data { my $self = shift; return _gdImageJpegPtr ( $self->{IMG_PTR}, @_ ); } # End of get_Jpeg_data()... =head2 get_Gd_data $image->get_Gd_data( ) =cut sub get_Gd_data { my $self = shift; return _gdImageGdPtr ( $self->{IMG_PTR}, @_ ); } # End of get_Gd_data()... =head2 get_Gd2_data $image->get_Gd2_data( $cs, $fmt ) =cut sub get_Gd2_data { my $self = shift; return _gdImageGd2Ptr ( $self->{IMG_PTR}, @_ ); } # End of get_Gd2_data()... =head2 SetPixel $image->SetPixel( $x, $y, $color ) Alias for gdImageSetPixel. =cut sub SetPixel { return gdImageSetPixel ( @_ ); } # End of SetPixel()... =head2 gdImageSetPixel $image->gdImageSetPixel( $x, $y, $color ) =cut sub gdImageSetPixel { my $self = shift; return _gdImageSetPixel ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetPixel()... =head2 GetPixel $image->GetPixel( $x, $y ) Alias for gdImageGetPixel. =cut sub GetPixel { return gdImageGetPixel ( @_ ); } # End of GetPixel()... =head2 gdImageGetPixel $image->gdImageGetPixel( $x, $y ) =cut sub gdImageGetPixel { my $self = shift; return _gdImageGetPixel ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetPixel()... =head2 AABlend $image->AABlend( ) Alias for gdImageAABlend. =cut sub AABlend { return gdImageAABlend ( @_ ); } # End of AABlend()... =head2 gdImageAABlend $image->gdImageAABlend( ) =cut sub gdImageAABlend { my $self = shift; return _gdImageAABlend ( $self->{IMG_PTR}, @_ ); } # End of gdImageAABlend()... =head2 Line $image->Line( $x1, $y1, $x2, $y2, $color ) Alias for gdImageLine. =cut sub Line { return gdImageLine ( @_ ); } # End of Line()... =head2 gdImageLine $image->gdImageLine( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageLine { my $self = shift; return _gdImageLine ( $self->{IMG_PTR}, @_ ); } # End of gdImageLine()... =head2 DashedLine $image->DashedLine( $x1, $y1, $x2, $y2, $color ) Alias for gdImageDashedLine. =cut sub DashedLine { return gdImageDashedLine ( @_ ); } # End of DashedLine()... =head2 gdImageDashedLine $image->gdImageDashedLine( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageDashedLine { my $self = shift; return _gdImageDashedLine ( $self->{IMG_PTR}, @_ ); } # End of gdImageDashedLine()... =head2 Rectangle $image->Rectangle( $x1, $y1, $x2, $y2, $color ) Alias for gdImageRectangle. =cut sub Rectangle { return gdImageRectangle ( @_ ); } # End of Rectangle()... =head2 gdImageRectangle $image->gdImageRectangle( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageRectangle { my $self = shift; return _gdImageRectangle ( $self->{IMG_PTR}, @_ ); } # End of gdImageRectangle()... =head2 FilledRectangle $image->FilledRectangle( $x1, $y1, $x2, $y2, $color ) Alias for gdImageFilledRectangle. =cut sub FilledRectangle { return gdImageFilledRectangle ( @_ ); } # End of FilledRectangle()... =head2 gdImageFilledRectangle $image->gdImageFilledRectangle( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageFilledRectangle { my $self = shift; return _gdImageFilledRectangle ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledRectangle()... =head2 SetClip $image->SetClip( $x1, $y1, $x2, $y2 ) Alias for gdImageSetClip. =cut sub SetClip { return gdImageSetClip ( @_ ); } # End of SetClip()... =head2 gdImageSetClip $image->gdImageSetClip( $x1, $y1, $x2, $y2 ) =cut sub gdImageSetClip { my $self = shift; return _gdImageSetClip ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetClip()... =head2 GetClip $image->GetClip( $x1P, $y1P, $x2P, $y2P ) Alias for gdImageGetClip. =cut sub GetClip { return gdImageGetClip ( @_ ); } # End of GetClip()... =head2 gdImageGetClip $image->gdImageGetClip( $x1P, $y1P, $x2P, $y2P ) =cut sub gdImageGetClip { my $self = shift; return _gdImageGetClip ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetClip()... =head2 BoundsSafe $image->BoundsSafe( $x, $y ) Alias for gdImageBoundsSafe. =cut sub BoundsSafe { return gdImageBoundsSafe ( @_ ); } # End of BoundsSafe()... =head2 gdImageBoundsSafe $image->gdImageBoundsSafe( $x, $y ) =cut sub gdImageBoundsSafe { my $self = shift; return _gdImageBoundsSafe ( $self->{IMG_PTR}, @_ ); } # End of gdImageBoundsSafe()... =head2 Char $image->Char( $f, $x, $y, $c, $color ) Alias for gdImageChar. =cut sub Char { return gdImageChar ( @_ ); } # End of Char()... =head2 gdImageChar $image->gdImageChar( $f, $x, $y, $c, $color ) =cut sub gdImageChar { my $self = shift; return _gdImageChar ( $self->{IMG_PTR}, @_ ); } # End of gdImageChar()... =head2 CharUp $image->CharUp( $f, $x, $y, $c, $color ) Alias for gdImageCharUp. =cut sub CharUp { return gdImageCharUp ( @_ ); } # End of CharUp()... =head2 gdImageCharUp $image->gdImageCharUp( $f, $x, $y, $c, $color ) =cut sub gdImageCharUp { my $self = shift; return _gdImageCharUp ( $self->{IMG_PTR}, @_ ); } # End of gdImageCharUp()... =head2 String $image->String( $f, $x, $y, $s, $color ) Alias for gdImageString. =cut sub String { return gdImageString ( @_ ); } # End of String()... =head2 gdImageString $image->gdImageString( $f, $x, $y, $s, $color ) =cut sub gdImageString { my $self = shift; return _gdImageString ( $self->{IMG_PTR}, @_ ); } # End of gdImageString()... =head2 StringUp $image->StringUp( $f, $x, $y, $s, $color ) Alias for gdImageStringUp. =cut sub StringUp { return gdImageStringUp ( @_ ); } # End of StringUp()... =head2 gdImageStringUp $image->gdImageStringUp( $f, $x, $y, $s, $color ) =cut sub gdImageStringUp { my $self = shift; return _gdImageStringUp ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringUp()... =head2 String16 $image->String16( $f, $x, $y, $s, $color ) Alias for gdImageString16. =cut sub String16 { return gdImageString16 ( @_ ); } # End of String16()... =head2 gdImageString16 $image->gdImageString16( $f, $x, $y, $s, $color ) =cut sub gdImageString16 { my $self = shift; return _gdImageString16 ( $self->{IMG_PTR}, @_ ); } # End of gdImageString16()... =head2 StringUp16 $image->StringUp16( $f, $x, $y, $s, $color ) Alias for gdImageStringUp16. =cut sub StringUp16 { return gdImageStringUp16 ( @_ ); } # End of StringUp16()... =head2 gdImageStringUp16 $image->gdImageStringUp16( $f, $x, $y, $s, $color ) =cut sub gdImageStringUp16 { my $self = shift; return _gdImageStringUp16 ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringUp16()... =head2 Polygon $image->Polygon( $p, $n, $c ) Alias for gdImagePolygon. =cut sub Polygon { return gdImagePolygon ( @_ ); } # End of Polygon()... =head2 gdImagePolygon $image->gdImagePolygon( $p, $n, $c ) =cut sub gdImagePolygon { my $self = shift; return _gdImagePolygon ( $self->{IMG_PTR}, @_ ); } # End of gdImagePolygon()... =head2 FilledPolygon $image->FilledPolygon( $p, $n, $c ) Alias for gdImageFilledPolygon. =cut sub FilledPolygon { return gdImageFilledPolygon ( @_ ); } # End of FilledPolygon()... =head2 gdImageFilledPolygon $image->gdImageFilledPolygon( $p, $n, $c ) =cut sub gdImageFilledPolygon { my $self = shift; return _gdImageFilledPolygon ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledPolygon()... =head2 ColorAllocate $image->ColorAllocate( $r, $g, $b ) Alias for gdImageColorAllocate. =cut sub ColorAllocate { return gdImageColorAllocate ( @_ ); } # End of ColorAllocate()... =head2 gdImageColorAllocate $image->gdImageColorAllocate( $r, $g, $b ) =cut sub gdImageColorAllocate { my $self = shift; return _gdImageColorAllocate ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorAllocate()... =head2 ColorAllocateAlpha $image->ColorAllocateAlpha( $r, $g, $b, $a ) Alias for gdImageColorAllocateAlpha. =cut sub ColorAllocateAlpha { return gdImageColorAllocateAlpha ( @_ ); } # End of ColorAllocateAlpha()... =head2 gdImageColorAllocateAlpha $image->gdImageColorAllocateAlpha( $r, $g, $b, $a ) =cut sub gdImageColorAllocateAlpha { my $self = shift; return _gdImageColorAllocateAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorAllocateAlpha()... =head2 ColorClosest $image->ColorClosest( $r, $g, $b ) Alias for gdImageColorClosest. =cut sub ColorClosest { return gdImageColorClosest ( @_ ); } # End of ColorClosest()... =head2 gdImageColorClosest $image->gdImageColorClosest( $r, $g, $b ) =cut sub gdImageColorClosest { my $self = shift; return _gdImageColorClosest ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorClosest()... =head2 ColorClosestAlpha $image->ColorClosestAlpha( $r, $g, $b, $a ) Alias for gdImageColorClosestAlpha. =cut sub ColorClosestAlpha { return gdImageColorClosestAlpha ( @_ ); } # End of ColorClosestAlpha()... =head2 gdImageColorClosestAlpha $image->gdImageColorClosestAlpha( $r, $g, $b, $a ) =cut sub gdImageColorClosestAlpha { my $self = shift; return _gdImageColorClosestAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorClosestAlpha()... =head2 ColorClosestHWB $image->ColorClosestHWB( $r, $g, $b ) Alias for gdImageColorClosestHWB. =cut sub ColorClosestHWB { return gdImageColorClosestHWB ( @_ ); } # End of ColorClosestHWB()... =head2 gdImageColorClosestHWB $image->gdImageColorClosestHWB( $r, $g, $b ) =cut sub gdImageColorClosestHWB { my $self = shift; return _gdImageColorClosestHWB ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorClosestHWB()... =head2 ColorExact $image->ColorExact( $r, $g, $b ) Alias for gdImageColorExact. =cut sub ColorExact { return gdImageColorExact ( @_ ); } # End of ColorExact()... =head2 gdImageColorExact $image->gdImageColorExact( $r, $g, $b ) =cut sub gdImageColorExact { my $self = shift; return _gdImageColorExact ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorExact()... =head2 ColorExactAlpha $image->ColorExactAlpha( $r, $g, $b, $a ) Alias for gdImageColorExactAlpha. =cut sub ColorExactAlpha { return gdImageColorExactAlpha ( @_ ); } # End of ColorExactAlpha()... =head2 gdImageColorExactAlpha $image->gdImageColorExactAlpha( $r, $g, $b, $a ) =cut sub gdImageColorExactAlpha { my $self = shift; return _gdImageColorExactAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorExactAlpha()... =head2 ColorResolve $image->ColorResolve( $r, $g, $b ) Alias for gdImageColorResolve. =cut sub ColorResolve { return gdImageColorResolve ( @_ ); } # End of ColorResolve()... =head2 gdImageColorResolve $image->gdImageColorResolve( $r, $g, $b ) =cut sub gdImageColorResolve { my $self = shift; return _gdImageColorResolve ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorResolve()... =head2 ColorResolveAlpha $image->ColorResolveAlpha( $r, $g, $b, $a ) Alias for gdImageColorResolveAlpha. =cut sub ColorResolveAlpha { return gdImageColorResolveAlpha ( @_ ); } # End of ColorResolveAlpha()... =head2 gdImageColorResolveAlpha $image->gdImageColorResolveAlpha( $r, $g, $b, $a ) =cut sub gdImageColorResolveAlpha { my $self = shift; return _gdImageColorResolveAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorResolveAlpha()... =head2 ColorDeallocate $image->ColorDeallocate( $color ) Alias for gdImageColorDeallocate. =cut sub ColorDeallocate { return gdImageColorDeallocate ( @_ ); } # End of ColorDeallocate()... =head2 gdImageColorDeallocate $image->gdImageColorDeallocate( $color ) =cut sub gdImageColorDeallocate { my $self = shift; return _gdImageColorDeallocate ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorDeallocate()... =head2 TrueColorToPalette $image->TrueColorToPalette( $ditherFlag, $colorsWanted ) Alias for gdImageTrueColorToPalette. =cut sub TrueColorToPalette { return gdImageTrueColorToPalette ( @_ ); } # End of TrueColorToPalette()... =head2 gdImageTrueColorToPalette $image->gdImageTrueColorToPalette( $ditherFlag, $colorsWanted ) =cut sub gdImageTrueColorToPalette { my $self = shift; return _gdImageTrueColorToPalette ( $self->{IMG_PTR}, @_ ); } # End of gdImageTrueColorToPalette()... =head2 ColorTransparent $image->ColorTransparent( $color ) Alias for gdImageColorTransparent. =cut sub ColorTransparent { return gdImageColorTransparent ( @_ ); } # End of ColorTransparent()... =head2 gdImageColorTransparent $image->gdImageColorTransparent( $color ) =cut sub gdImageColorTransparent { my $self = shift; return _gdImageColorTransparent ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorTransparent()... =head2 FilledArc $image->FilledArc( $cx, $cy, $w, $h, $s, $e, $color, $style ) Alias for gdImageFilledArc. =cut sub FilledArc { return gdImageFilledArc ( @_ ); } # End of FilledArc()... =head2 gdImageFilledArc $image->gdImageFilledArc( $cx, $cy, $w, $h, $s, $e, $color, $style ) =cut sub gdImageFilledArc { my $self = shift; return _gdImageFilledArc ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledArc()... =head2 Arc $image->Arc( $cx, $cy, $w, $h, $s, $e, $color ) Alias for gdImageArc. =cut sub Arc { return gdImageArc ( @_ ); } # End of Arc()... =head2 gdImageArc $image->gdImageArc( $cx, $cy, $w, $h, $s, $e, $color ) =cut sub gdImageArc { my $self = shift; return _gdImageArc ( $self->{IMG_PTR}, @_ ); } # End of gdImageArc()... =head2 FilledEllipse $image->FilledEllipse( $cx, $cy, $w, $h, $color ) Alias for gdImageFilledEllipse. =cut sub FilledEllipse { return gdImageFilledEllipse ( @_ ); } # End of FilledEllipse()... =head2 gdImageFilledEllipse $image->gdImageFilledEllipse( $cx, $cy, $w, $h, $color ) =cut sub gdImageFilledEllipse { my $self = shift; return _gdImageFilledEllipse ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledEllipse()... =head2 FillToBorder $image->FillToBorder( $x, $y, $border, $color ) Alias for gdImageFillToBorder. =cut sub FillToBorder { return gdImageFillToBorder ( @_ ); } # End of FillToBorder()... =head2 gdImageFillToBorder $image->gdImageFillToBorder( $x, $y, $border, $color ) =cut sub gdImageFillToBorder { my $self = shift; return _gdImageFillToBorder ( $self->{IMG_PTR}, @_ ); } # End of gdImageFillToBorder()... =head2 Fill $image->Fill( $x, $y, $color ) Alias for gdImageFill. =cut sub Fill { return gdImageFill ( @_ ); } # End of Fill()... =head2 gdImageFill $image->gdImageFill( $x, $y, $color ) =cut sub gdImageFill { my $self = shift; return _gdImageFill ( $self->{IMG_PTR}, @_ ); } # End of gdImageFill()... =head2 CopyRotated $image->CopyRotated( $dstX, $dstY, $srcX, $srcY, $srcWidth, $srcHeight, $angle ) Alias for gdImageCopyRotated. =cut sub CopyRotated { return gdImageCopyRotated ( @_ ); } # End of CopyRotated()... =head2 gdImageCopyRotated $image->gdImageCopyRotated( $dstX, $dstY, $srcX, $srcY, $srcWidth, $srcHeight, $angle ) =cut sub gdImageCopyRotated { my $self = shift; return _gdImageCopyRotated ( $self->{IMG_PTR}, @_ ); } # End of gdImageCopyRotated()... =head2 SetBrush $image->SetBrush( ) Alias for gdImageSetBrush. =cut sub SetBrush { return gdImageSetBrush ( @_ ); } # End of SetBrush()... =head2 gdImageSetBrush $image->gdImageSetBrush( ) =cut sub gdImageSetBrush { my $self = shift; return _gdImageSetBrush ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetBrush()... =head2 SetTile $image->SetTile( ) Alias for gdImageSetTile. =cut sub SetTile { return gdImageSetTile ( @_ ); } # End of SetTile()... =head2 gdImageSetTile $image->gdImageSetTile( ) =cut sub gdImageSetTile { my $self = shift; return _gdImageSetTile ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetTile()... =head2 SetAntiAliased $image->SetAntiAliased( $c ) Alias for gdImageSetAntiAliased. =cut sub SetAntiAliased { return gdImageSetAntiAliased ( @_ ); } # End of SetAntiAliased()... =head2 gdImageSetAntiAliased $image->gdImageSetAntiAliased( $c ) =cut sub gdImageSetAntiAliased { my $self = shift; return _gdImageSetAntiAliased ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetAntiAliased()... =head2 SetAntiAliasedDontBlend $image->SetAntiAliasedDontBlend( $c, $dont_blend ) Alias for gdImageSetAntiAliasedDontBlend. =cut sub SetAntiAliasedDontBlend { return gdImageSetAntiAliasedDontBlend ( @_ ); } # End of SetAntiAliasedDontBlend()... =head2 gdImageSetAntiAliasedDontBlend $image->gdImageSetAntiAliasedDontBlend( $c, $dont_blend ) =cut sub gdImageSetAntiAliasedDontBlend { my $self = shift; return _gdImageSetAntiAliasedDontBlend ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetAntiAliasedDontBlend()... =head2 SetStyle $image->SetStyle( $style, $noOfPixels ) Alias for gdImageSetStyle. =cut sub SetStyle { return gdImageSetStyle ( @_ ); } # End of SetStyle()... =head2 gdImageSetStyle $image->gdImageSetStyle( $style, $noOfPixels ) =cut sub gdImageSetStyle { my $self = shift; return _gdImageSetStyle ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetStyle()... =head2 SetThickness $image->SetThickness( $thickness ) Alias for gdImageSetThickness. =cut sub SetThickness { return gdImageSetThickness ( @_ ); } # End of SetThickness()... =head2 gdImageSetThickness $image->gdImageSetThickness( $thickness ) =cut sub gdImageSetThickness { my $self = shift; return _gdImageSetThickness ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetThickness()... =head2 Interlace $image->Interlace( $interlaceArg ) Alias for gdImageInterlace. =cut sub Interlace { return gdImageInterlace ( @_ ); } # End of Interlace()... =head2 gdImageInterlace $image->gdImageInterlace( $interlaceArg ) =cut sub gdImageInterlace { my $self = shift; return _gdImageInterlace ( $self->{IMG_PTR}, @_ ); } # End of gdImageInterlace()... =head2 AlphaBlending $image->AlphaBlending( $alphaBlendingArg ) Alias for gdImageAlphaBlending. =cut sub AlphaBlending { return gdImageAlphaBlending ( @_ ); } # End of AlphaBlending()... =head2 gdImageAlphaBlending $image->gdImageAlphaBlending( $alphaBlendingArg ) =cut sub gdImageAlphaBlending { my $self = shift; return _gdImageAlphaBlending ( $self->{IMG_PTR}, @_ ); } # End of gdImageAlphaBlending()... =head2 SaveAlpha $image->SaveAlpha( $saveAlphaArg ) Alias for gdImageSaveAlpha. =cut sub SaveAlpha { return gdImageSaveAlpha ( @_ ); } # End of SaveAlpha()... =head2 gdImageSaveAlpha $image->gdImageSaveAlpha( $saveAlphaArg ) =cut sub gdImageSaveAlpha { my $self = shift; return _gdImageSaveAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageSaveAlpha()... =head2 TrueColor $image->TrueColor( ) Alias for gdImageTrueColor. =cut sub TrueColor { return gdImageTrueColor ( @_ ); } # End of TrueColor()... =head2 gdImageTrueColor $image->gdImageTrueColor( ) =cut sub gdImageTrueColor { my $self = shift; return _gdImageTrueColor ( $self->{IMG_PTR}, @_ ); } # End of gdImageTrueColor()... =head2 ColorsTotal $image->ColorsTotal( ) Alias for gdImageColorsTotal. =cut sub ColorsTotal { return gdImageColorsTotal ( @_ ); } # End of ColorsTotal()... =head2 gdImageColorsTotal $image->gdImageColorsTotal( ) =cut sub gdImageColorsTotal { my $self = shift; return _gdImageColorsTotal ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorsTotal()... =head2 Red $image->Red( $c ) Alias for gdImageRed. =cut sub Red { return gdImageRed ( @_ ); } # End of Red()... =head2 gdImageRed $image->gdImageRed( $c ) =cut sub gdImageRed { my $self = shift; return _gdImageRed ( $self->{IMG_PTR}, @_ ); } # End of gdImageRed()... =head2 Green $image->Green( $c ) Alias for gdImageGreen. =cut sub Green { return gdImageGreen ( @_ ); } # End of Green()... =head2 gdImageGreen $image->gdImageGreen( $c ) =cut sub gdImageGreen { my $self = shift; return _gdImageGreen ( $self->{IMG_PTR}, @_ ); } # End of gdImageGreen()... =head2 Blue $image->Blue( $c ) Alias for gdImageBlue. =cut sub Blue { return gdImageBlue ( @_ ); } # End of Blue()... =head2 gdImageBlue $image->gdImageBlue( $c ) =cut sub gdImageBlue { my $self = shift; return _gdImageBlue ( $self->{IMG_PTR}, @_ ); } # End of gdImageBlue()... =head2 Alpha $image->Alpha( $c ) Alias for gdImageAlpha. =cut sub Alpha { return gdImageAlpha ( @_ ); } # End of Alpha()... =head2 gdImageAlpha $image->gdImageAlpha( $c ) =cut sub gdImageAlpha { my $self = shift; return _gdImageAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageAlpha()... =head2 GetTransparent $image->GetTransparent( ) Alias for gdImageGetTransparent. =cut sub GetTransparent { return gdImageGetTransparent ( @_ ); } # End of GetTransparent()... =head2 gdImageGetTransparent $image->gdImageGetTransparent( ) =cut sub gdImageGetTransparent { my $self = shift; return _gdImageGetTransparent ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetTransparent()... =head2 GetInterlaced $image->GetInterlaced( ) Alias for gdImageGetInterlaced. =cut sub GetInterlaced { return gdImageGetInterlaced ( @_ ); } # End of GetInterlaced()... =head2 gdImageGetInterlaced $image->gdImageGetInterlaced( ) =cut sub gdImageGetInterlaced { my $self = shift; return _gdImageGetInterlaced ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetInterlaced()... =head2 SX $image->SX( ) Alias for gdImageSX. =cut sub SX { return gdImageSX ( @_ ); } # End of SX()... =head2 gdImageSX $image->gdImageSX( ) =cut sub gdImageSX { my $self = shift; return _gdImageSX ( $self->{IMG_PTR}, @_ ); } # End of gdImageSX()... =head2 SY $image->SY( ) Alias for gdImageSY. =cut sub SY { return gdImageSY ( @_ ); } # End of SY()... =head2 gdImageSY $image->gdImageSY( ) =cut sub gdImageSY { my $self = shift; return _gdImageSY ( $self->{IMG_PTR}, @_ ); } # End of gdImageSY()... =head2 ColorAllocates $image->ColorAllocates( $r(pdl), $g(pdl), $b(pdl) ) Alias for gdImageColorAllocates. =cut sub ColorAllocates { return gdImageColorAllocates ( @_ ); } # End of ColorAllocates()... =head2 gdImageColorAllocates $image->gdImageColorAllocates( $r(pdl), $g(pdl), $b(pdl) ) =cut sub gdImageColorAllocates { my $self = shift; return _gdImageColorAllocates ( @_, $self->{IMG_PTR} ); } # End of gdImageColorAllocates()... =head2 ColorAllocateAlphas $image->ColorAllocateAlphas( $r(pdl), $g(pdl), $b(pdl), $a(pdl) ) Alias for gdImageColorAllocateAlphas. =cut sub ColorAllocateAlphas { return gdImageColorAllocateAlphas ( @_ ); } # End of ColorAllocateAlphas()... =head2 gdImageColorAllocateAlphas $image->gdImageColorAllocateAlphas( $r(pdl), $g(pdl), $b(pdl), $a(pdl) ) =cut sub gdImageColorAllocateAlphas { my $self = shift; return _gdImageColorAllocateAlphas ( @_, $self->{IMG_PTR} ); } # End of gdImageColorAllocateAlphas()... =head2 SetPixels $image->SetPixels( $x(pdl), $y(pdl), $color(pdl) ) Alias for gdImageSetPixels. =cut sub SetPixels { return gdImageSetPixels ( @_ ); } # End of SetPixels()... =head2 gdImageSetPixels $image->gdImageSetPixels( $x(pdl), $y(pdl), $color(pdl) ) =cut sub gdImageSetPixels { my $self = shift; return _gdImageSetPixels ( @_, $self->{IMG_PTR} ); } # End of gdImageSetPixels()... =head2 Lines $image->Lines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageLines. =cut sub Lines { return gdImageLines ( @_ ); } # End of Lines()... =head2 gdImageLines $image->gdImageLines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageLines { my $self = shift; return _gdImageLines ( @_, $self->{IMG_PTR} ); } # End of gdImageLines()... =head2 DashedLines $image->DashedLines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageDashedLines. =cut sub DashedLines { return gdImageDashedLines ( @_ ); } # End of DashedLines()... =head2 gdImageDashedLines $image->gdImageDashedLines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageDashedLines { my $self = shift; return _gdImageDashedLines ( @_, $self->{IMG_PTR} ); } # End of gdImageDashedLines()... =head2 Rectangles $image->Rectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageRectangles. =cut sub Rectangles { return gdImageRectangles ( @_ ); } # End of Rectangles()... =head2 gdImageRectangles $image->gdImageRectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageRectangles { my $self = shift; return _gdImageRectangles ( @_, $self->{IMG_PTR} ); } # End of gdImageRectangles()... =head2 FilledRectangles $image->FilledRectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageFilledRectangles. =cut sub FilledRectangles { return gdImageFilledRectangles ( @_ ); } # End of FilledRectangles()... =head2 gdImageFilledRectangles $image->gdImageFilledRectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageFilledRectangles { my $self = shift; return _gdImageFilledRectangles ( @_, $self->{IMG_PTR} ); } # End of gdImageFilledRectangles()... =head2 FilledArcs $image->FilledArcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl), $style(pdl) ) Alias for gdImageFilledArcs. =cut sub FilledArcs { return gdImageFilledArcs ( @_ ); } # End of FilledArcs()... =head2 gdImageFilledArcs $image->gdImageFilledArcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl), $style(pdl) ) =cut sub gdImageFilledArcs { my $self = shift; return _gdImageFilledArcs ( @_, $self->{IMG_PTR} ); } # End of gdImageFilledArcs()... =head2 Arcs $image->Arcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl) ) Alias for gdImageArcs. =cut sub Arcs { return gdImageArcs ( @_ ); } # End of Arcs()... =head2 gdImageArcs $image->gdImageArcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl) ) =cut sub gdImageArcs { my $self = shift; return _gdImageArcs ( @_, $self->{IMG_PTR} ); } # End of gdImageArcs()... =head2 FilledEllipses $image->FilledEllipses( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $color(pdl) ) Alias for gdImageFilledEllipses. =cut sub FilledEllipses { return gdImageFilledEllipses ( @_ ); } # End of FilledEllipses()... =head2 gdImageFilledEllipses $image->gdImageFilledEllipses( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $color(pdl) ) =cut sub gdImageFilledEllipses { my $self = shift; return _gdImageFilledEllipses ( @_, $self->{IMG_PTR} ); } # End of gdImageFilledEllipses()... =head1 CLASS FUNCTIONS =cut =head2 gdImageCopy gdImageCopy ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $w, $h ) =cut sub gdImageCopy { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $w = shift; my $h = shift; return _gdImageCopy ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $w, $h ); } # End of gdImageCopy()... =head2 gdImageCopyMerge gdImageCopyMerge ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ) =cut sub gdImageCopyMerge { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $w = shift; my $h = shift; my $pct = shift; return _gdImageCopyMerge ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ); } # End of gdImageCopyMerge()... =head2 gdImageCopyMergeGray gdImageCopyMergeGray ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ) =cut sub gdImageCopyMergeGray { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $w = shift; my $h = shift; my $pct = shift; return _gdImageCopyMergeGray ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ); } # End of gdImageCopyMergeGray()... =head2 gdImageCopyResized gdImageCopyResized ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ) =cut sub gdImageCopyResized { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $dstW = shift; my $dstH = shift; my $srcW = shift; my $srcH = shift; return _gdImageCopyResized ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ); } # End of gdImageCopyResized()... =head2 gdImageCopyResampled gdImageCopyResampled ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ) =cut sub gdImageCopyResampled { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $dstW = shift; my $dstH = shift; my $srcW = shift; my $srcH = shift; return _gdImageCopyResampled ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ); } # End of gdImageCopyResampled()... =head2 gdImageCompare gdImageCompare ( $im1(PDL::IO::GD), $im2(PDL::IO::GD) ) =cut sub gdImageCompare { my $im1 = shift; my $im2 = shift; return _gdImageCompare ( $im1->{IMG_PTR}, $im2->{IMG_PTR} ); } # End of gdImageCompare()... =head2 gdImagePaletteCopy gdImagePaletteCopy ( $dst(PDL::IO::GD), $src(PDL::IO::GD) ) =cut sub gdImagePaletteCopy { my $dst = shift; my $src = shift; return _gdImagePaletteCopy ( $dst->{IMG_PTR}, $src->{IMG_PTR} ); } # End of gdImagePaletteCopy()... =head2 StringTTF $image->StringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) Alias for gdImageStringTTF. =cut sub StringTTF { return gdImageStringTTF ( @_ ); } # End of StringTTF()... =head2 gdImageStringTTF $image->gdImageStringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) =cut sub gdImageStringTTF { my $self = shift; return _gdImageStringTTF ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringTTF()... =head2 StringFT $image->StringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) Alias for gdImageStringFT. =cut sub StringFT { return gdImageStringFT ( @_ ); } # End of StringFT()... =head2 gdImageStringFT $image->gdImageStringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) =cut sub gdImageStringFT { my $self = shift; return _gdImageStringFT ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringFT()... =head1 AUTHOR Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut # Exit with OK status 1; �����������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/HDF/���������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402052�013205� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/HDF/SD.pm����������������������������������������������������������������0000644�0601750�0601001�00000106330�13110402052�014054� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::HDF::SD; @EXPORT_OK = qw( ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::HDF::SD ; =head1 NAME PDL::IO::HDF::SD - PDL interface to the HDF4 SD library. =head1 SYNOPSIS use PDL; use PDL::IO::HDF::SD; # # Creating and writing an HDF file # # Create an HDF file: my $hdf = PDL::IO::HDF::SD->new("-test.hdf"); # Define some data my $data = sequence(short, 500, 5); # Put data in file as 'myData' dataset with the names # of dimensions ('dim1' and 'dim2') $hdf->SDput("myData", $data , ['dim1','dim2']); # Put some local attributes in 'myData' # # Set the fill value to 0 my $res = $hdf->SDsetfillvalue("myData", 0); # Set the valid range from 0 to 2000 $res = $hdf->SDsetrange("myData", [0, 2000]); # Set the default calibration for 'myData' (scale factor = 1, other = 0) $res = $hdf->SDsetcal("myData"); # Set a global text attribute $res = $hdf->SDsettextattr('This is a global text test!!', "myGText" ); # Set a local text attribute for 'myData' $res = $hdf->SDsettextattr('This is a local text testl!!', "myLText", "myData" ); # Set a global value attribute (you can put all values you want) $res = $hdf->SDsetvalueattr( PDL::short( 20 ), "myGValue"); # Set a local value attribute (you can put all values you want) $res = $hdf->SDsetvalueattr( PDL::long( [20, 15, 36] ), "myLValues", "myData" ); # Close the file $hdf->close(); # # Reading from an HDF file: # # Open an HDF file in read only mode: my $hdf = PDL::IO::HDF::SD->new("test.hdf"); # Get a list of all datasets: my @dataset_list = $hdf->SDgetvariablename(); # Get a list of the names of all global attributes: my @globattr_list = $hdf->SDgetattributenames(); # Get a list of the names of all local attributes for a dataset: my @locattr_list = $hdf->SDgetattributenames("myData"); # Get the value of local attribute for a dataset: my $value = $hdf->SDgetattribut("myLText","myData"); # Get a PDL var of the entire dataset 'myData': my $data = $hdf->SDget("myData"); # Apply the scale factor of 'myData' $data *= $hdf->SDgetscalefactor("myData"); # Get the fill value and fill the PDL var in with BAD: $data->inplace->setvaltobad( $hdf->SDgetfillvalue("myData") ); # Get the valid range of a dataset: my @range = $hdf->SDgetrange("myData"); #Now you can do what you want with your data $hdf->close(); =head1 DESCRIPTION This library provides functions to read, write, and manipulate HDF4 files with HDF's SD interface. For more information on HDF4, see http://hdf.ncsa.uiuc.edu/ There have been a lot of changes starting with version 2.0, and these may affect your code. PLEASE see the 'Changes' file for a detailed description of what has been changed. If your code used to work with the circa 2002 version of this module, and does not work anymore, reading the 'Changes' is your best bet. In the documentation, the terms dataset and SDS (Scientific Data Set) are used interchangeably. =cut use PDL::Primitive; use PDL::Basic; use PDL::IO::HDF; require POSIX; sub _pkg_name { return "PDL::IO::HDF::SD::" . shift() . "()"; } # Convert a byte to a char: sub Byte2Char { my ($strB) = @_; my $strC; for(my $i=0; $i<$strB->nelem; $i++) { $strC .= chr( $strB->at($i) ); } return($strC); } # End of Byte2Char()... =head1 CLASS METHODS =head2 new =for ref Open or create a new HDF object. =for usage Arguments: 1 : The name of the file. if you want to write to it, prepend the name with the '+' character : "+name.hdf" if you want to create it, prepend the name with the '-' character : "-name.hdf" otherwise the file will be open in read only mode Returns the hdf object (die on error) =for example my $hdf = PDL::IO::HDF::SD->new("file.hdf"); =cut sub new { # General: my $type = shift; my $filename = shift; my $sub = _pkg_name( 'new' ); my $debug = 0; my $self = {}; if (substr($filename, 0, 1) eq '+') { # open for writing $filename = substr ($filename, 1); # chop off + $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } if (substr($filename, 0, 1) eq '-') { # Create new file $filename = substr ($filename, 1); # chop off - print "$sub: Creating HDF File $filename\n" if $debug; $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE; $self->{SDID} = PDL::IO::HDF::SD::_SDstart( $filename, $self->{ACCESS_MODE} ); my $res = PDL::IO::HDF::SD::_SDend( $self->{SDID} ); die "$sub: _ERR::Create\n" if( ($self->{SDID} == PDL::IO::HDF->FAIL ) || ( $res == PDL::IO::HDF->FAIL )); $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } unless( defined( $self->{ACCESS_MODE} ) ) { # Default to Read-only access: $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ; } $self->{FILE_NAME} = $filename; # SD interface: print "$sub: Loading HDF File $self->{FILE_NAME}\n" if $debug; $self->{SDID} = PDL::IO::HDF::SD::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} ); die "$sub: _ERR::SDstart\n" if( $self->{SDID} == PDL::IO::HDF->FAIL ); my $num_datasets = -999; my $num_global_attrs = -999; my $res = _SDfileinfo( $self->{SDID}, $num_datasets, $num_global_attrs ); die "$sub: ** sdFileInfo **\n" if($res == PDL::IO::HDF->FAIL); foreach my $i ( 0 .. $num_global_attrs-1 ) { print "$sub: Loading Global Attribute #$i\n" if $debug; my $attrname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $type = 0; my $count = 0; $res = _SDattrinfo( $self->{SDID}, $i, $attrname, $type, $count ); die "$sub: ** sdAttrInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$attrname = \'$attrname\'\n" if $debug; $self->{GLOBATTR}->{$attrname} = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$type}, $count ); $res = _SDreadattr( $self->{SDID}, $i, $self->{GLOBATTR}->{$attrname} ); die "$sub: ** sdReadAttr **\n" if($res == PDL::IO::HDF->FAIL); if( $type == PDL::IO::HDF->DFNT_CHAR ) { $self->{GLOBATTR}->{$attrname} = Byte2Char( $self->{GLOBATTR}->{$attrname} ); } } my @dataname; foreach my $i ( 0 .. $num_datasets-1 ) { print "$sub: Loading SDS #$i\n" if $debug; my $sds_id = _SDselect( $self->{SDID}, $i ); die "$sub: ** sdSelect **\n" if($sds_id == PDL::IO::HDF->FAIL); my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $rank = 0; my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 ); my $numtype = 0; my $num_attrs = 0; $res = _SDgetinfo($sds_id, $name, $rank, $dimsize, $numtype, $num_attrs); die "$sub: ** sdGetInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$name = \'$name\'\n" if $debug; print "$sub: \$dimsize = \'$dimsize\'\n" if $debug; $self->{DATASET}->{$name}->{TYPE} = $numtype; $self->{DATASET}->{$name}->{RANK} = $rank; $self->{DATASET}->{$name}->{SDSID} = $sds_id; # Load up information on the dimensions (named, unlimited, etc...): # foreach my $j ( 0 .. $self->{DATASET}->{$name}->{RANK}-1 ) { print "$sub: Loading SDS($i) Dimension #$j\n" if $debug; my $dim_id = _SDgetdimid( $sds_id, $j ); die "$sub: ** sdGetDimId **\n" if($dim_id == PDL::IO::HDF->FAIL); my $dimname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $size = 0; my $num_type = 0; my $num_dim_attrs = 0; $res = _SDdiminfo( $dim_id, $dimname, $size, $num_type, $num_dim_attrs ); die "$sub: ** sdDimInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$dimname = \'$dimname\'\n" if $debug; $self->{DATASET}->{$name}->{DIMS}->{$j}->{DIMID} = $dim_id; $self->{DATASET}->{$name}->{DIMS}->{$j}->{SIZE} = $size; $self->{DATASET}->{$name}->{DIMS}->{$j}->{NAME} = $dimname; # The size comes back as 0 if it has the HDF unlimited dimension thing going on: # So, lets figure out what the size is currently at: unless ( $size ) { $self->{DATASET}->{$name}->{DIMS}->{$j}->{REAL_SIZE} = _SDgetunlimiteddim( $sds_id, $j); } } # Load up info on the SDS's attributes: # foreach my $j ( 0 .. $num_attrs-1 ) { print "$sub: Loading SDS($i) Attribute #$j\n" if $debug; my $attrname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $type = 0; my $count = 0; $res = _SDattrinfo( $sds_id, $j, $attrname, $type, $count); die "$sub: ** sdAttrInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$attrname = \'$attrname\'\n" if $debug; $self->{DATASET}->{$name}->{ATTRS}->{$attrname} = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$type}, $count ); $res = _SDreadattr( $sds_id, $j, $self->{DATASET}->{$name}->{ATTRS}->{$attrname} ); die "$sub: ** sdReadAttr **\n" if($res == PDL::IO::HDF->FAIL); # FIXME: This should be a constant if( $type == PDL::IO::HDF->DFNT_CHAR ) { $self->{DATASET}->{$name}->{ATTRS}->{$attrname} = Byte2Char( $self->{DATASET}->{$name}->{ATTRS}->{$attrname} ); } } } bless $self, $type; # Now that we're blessed, run our own accessors: # Default to using this (it's a good thing :) $self->Chunking( 1 ); return $self; } # End of new()... =head2 Chunking =for ref Accessor for the chunking mode on this HDF file. 'Chunking' is an internal compression and tiling the HDF library can perform on an SDS. This variable only affects they way SDput() works, and is ON by default. The code modifications enabled by this flag automatically partition the dataset to chunks of at least 100x100 values in size. The logic on this is pretty fancy, and would take a while to doc out here. If you _really_ have to know how it auto-partitions the data, then look at the code. Someday over the rainbow, I'll add some features for better control of the chunking parameters, if the need arises. For now, it's just stupid easy to use. =for usage Arguments: 1 (optional): new value for the chunking flag. =for example # See if chunking is currently on for this file: my $chunkvar = $hdf->Chunking(); # Turn the chunking off: my $newvar = $hdf->Chunking( 0 ); # Turn the chunking back on: my $newvar = $hdf->Chunking( 1 ); =cut # See the changelog for more docs on this feature: sub Chunking { my $self = shift; my $var = shift; if( defined( $var ) ) { $self->{CHUNKING} = $var ? 1 : 0; } return $self->{CHUNKING}; } # End of Chunking()... =head2 SDgetvariablenames =for ref get the list of datasets. =for usage No arguments Returns the list of dataset or undef on error. =for example my @DataList = $hdfobj->SDgetvariablenames(); =cut sub SDgetvariablenames { my($self) = @_; return keys %{$self->{DATASET}}; } # End of SDgetvariablenames()... sub SDgetvariablename { my $self = shift; return $self->SDgetvariablenames( @_ ); } # End of SDgetvariablename()... =head2 SDgetattributenames =for ref Get a list of the names of the global or SDS attributes. =for usage Arguments: 1 (optional) : The name of the SD dataset from which you want to get the attributes. This arg is optional, and without it, it will return the list of global attribute names. Returns a list of names or undef on error. =for example # For global attributes : my @attrList = $hdf->SDgetattributenames(); # For SDS attributes : my @attrList = $hdf->SDgetattributenames("dataset_name"); =cut sub SDgetattributenames { my($self, $name) = @_; if( defined( $name ) ) { return( undef ) unless defined( $self->{DATASET}->{$name} ); return keys %{ $self->{DATASET}->{$name}->{ATTRS} }; } else { return keys %{ $self->{GLOBATTR} }; } } # End of SDgetattributenames()... # Wrapper (this is now defunct): sub SDgetattributname { my $self = shift; return $self->SDgetattributenames( @_ ); } # End of SDgetattributname()... =head2 SDgetattribute =for ref Get a global or SDS attribute value. =for usage Arguments: 1 : The name of the attribute. 2 (optional): The name of the SDS from which you want to get the attribute value. Without this arg, it returns the global attribute value of that name. Returns an attribute value or undef on error. =for example # for global attributs : my $attr = $hdf->SDgetattribute("attr_name"); # for local attributs : my $attr = $hdf->SDgetattribute("attr_name", "dataset_name"); =cut sub SDgetattribute { my($self, $name, $dataset) = @_; if( defined($dataset) ) { # It's an SDS attribute: return( undef ) unless defined( $self->{DATASET}->{$dataset} ); return $self->{DATASET}->{$dataset}->{ATTRS}->{$name}; } else { # Global attribute: return( undef ) unless defined( $self->{GLOBATTR}->{$name} ); return $self->{GLOBATTR}->{$name}; } } # End of SDgetattribute()... # Wrapper (this is now defunct): sub SDgetattribut { my $self = shift; return $self->SDgetattribute( @_ ); } # End of SDgetattribut()... =head2 SDgetfillvalue =for ref Get the fill value of an SDS. =for usage Arguments: 1 : The name of the SDS from which you want to get the fill value. Returns the fill value or undef on error. =for example my $fillvalue = $hdf->SDgetfillvalue("dataset_name"); =cut sub SDgetfillvalue { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return ($self->{DATASET}->{$name}->{ATTRS}->{_FillValue})->at(0); } # End of SDgetfillvalue()... =head2 SDgetrange =for ref Get the valid range of an SDS. =for usage Arguments: 1 : the name of the SDS from which you want to get the valid range. Returns a list of two elements [min, max] or undef on error. =for example my @range = $hdf->SDgetrange("dataset_name"); =cut sub SDgetrange { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return $self->{DATASET}->{$name}->{ATTRS}->{valid_range}; } # End of SDgetrange()... =head2 SDgetscalefactor =for ref Get the scale factor of an SDS. =for usage Arguments: 1 : The name of the SDS from which you want to get the scale factor. Returns the scale factor or undef on error. =for example my $scale = $hdf->SDgetscalefactor("dataset_name"); =cut sub SDgetscalefactor { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return ($self->{DATASET}->{$name}->{ATTRS}->{scale_factor})->at(0); } # End of SDgetscalefactor()... =head2 SDgetdimsize =for ref Get the dimensions of a dataset. =for usage Arguments: 1 : The name of the SDS from which you want to get the dimensions. Returns an array of n dimensions with their sizes or undef on error. =for example my @dim = $hdf->SDgetdimsize("dataset_name"); =cut sub SDgetdimsize { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dims; foreach( sort keys %{ $self->{DATASET}->{$name}->{DIMS} } ) { push @dims, $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE}; } return( @dims ); } # End of SDgetdimsize()... =head2 SDgetunlimiteddimsize =for ref Get the actual dimensions of an SDS with 'unlimited' dimensions. =for usage Arguments: 1 : The name of the SDS from which you want to the dimensions. Returns an array of n dimensions with the dim sizes or undef on error. =for example my @dims = $hdf->SDgetunlimiteddimsize("dataset_name"); =cut sub SDgetunlimiteddimsize { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dim; foreach( sort keys %{$self->{DATASET}{$name}{DIMS}} ) { if( $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE} == 0 ) { $dim[ $_ ] = $self->{DATASET}->{$name}->{DIMS}->{$_}->{REAL_SIZE}; } else { $dim[ $_ ] = $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE}; } } return(@dim); } # End of SDgetunlimiteddimsize()... # Wrapper (this is now defunct): sub SDgetdimsizeunlimit { my $self = shift; return $self->SDgetunlimiteddimsize( @_ ); } # End of SDgetdimsizeunlimit()... =head2 SDgetdimnames =for ref Get the names of the dimensions of a dataset. =for usage Arguments: 1 : the name of a dataset you want to get the dimensions'names . Returns an array of n dimensions with their names or an empty list if error. =for example my @dim_names = $hdf->SDgetdimnames("dataset_name"); =cut sub SDgetdimnames { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dims=(); foreach( sort keys %{ $self->{DATASET}->{$name}->{DIMS} } ) { push @dims,$self->{DATASET}->{$name}->{DIMS}->{$_}->{NAME}; } return(@dims); } # End of SDgetdimnames()... sub SDgetdimname { my $self = shift; return $self->SDgetdimnames( @_ ); } # End of SDgetdimname(); =head2 SDgetcal =for ref Get the calibration factor from an SDS. =for usage Arguments: 1 : The name of the SDS Returns (scale factor, scale factor error, offset, offset error, data type), or undef on error. =for example my ($cal, $cal_err, $off, $off_err, $d_type) = $hdf->SDgetcal("dataset_name"); =cut sub SDgetcal { my ($self, $name ) = @_; my ($cal, $cal_err, $off, $off_err, $type); return( undef ) unless defined( $self->{DATASET}->{$name} ); return( undef ) unless defined( $self->{DATASET}->{$name}->{ATTRS}->{scale_factor} ); $cal = $self->{DATASET}->{$name}->{ATTRS}->{scale_factor}; $cal_err = $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err}; $off = $self->{DATASET}->{$name}->{ATTRS}->{add_offset}; $off_err = $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err}; $type = $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt}; return( $cal, $cal_err, $off, $off_err, $type ); } # End of SDgetcal()... =head2 SDget =for ref Get a the data from and SDS, or just a slice of that SDS. =for usage Arguments: 1 : The name of the SDS you want to get. 2 (optional): The start array ref of the slice. 3 (optional): The size array ref of the slice (HDF calls this the 'edge'). 4 (optional): The stride array ref of the slice. Returns a PDL of data if ok, PDL::null on error. If the slice arguments are not given, this function will read the entire SDS from the file. The type of the returned PDL variable is the PDL equivalent of what was stored in the HDF file. =for example # Get the entire SDS: my $pdldata = $hdf->SDget("dataset_name"); # get a slice of the dataset my $start = [10,50,10]; # the start position of the slice is [10, 50, 10] my $edge = [20,20,20]; # read 20 values on each dimension from @start my $stride = [1, 1, 1]; # Don't skip values my $pdldata = $hdf->SDget( "dataset_name", $start, $edge, $stride ); =cut sub SDget { my($self, $name, $start, $end, $stride) = @_; my $sub = _pkg_name( 'SDget' ); return null unless defined( $self->{DATASET}->{$name} ); unless( defined( $end ) ) { # \@end was not passed in, so we need to set everything else to defaults: ($start, $end) = []; my @dimnames=$self->SDgetdimnames($name); for my $dim (0 .. $#dimnames) { my $use_size = $self->{DATASET}->{$name}->{DIMS}->{$dim}->{SIZE} || $self->{DATASET}->{$name}->{DIMS}->{$dim}->{REAL_SIZE}; $$end[ $dim ] = $use_size; $$start[ $dim ] = 0; $$stride[ $dim ] = 1; } } my $c_start = pack ("L*", @$start); my $c_end = pack ("L*", @$end); my $c_stride = pack ("L*", @$stride); #print STDERR "$sub: start:[".join(',',@$start) # ."]=>$c_start end:[".join(',',@$end) # ."]=>$c_end stride:[".join(',',@$stride)."]=>$c_stride\n"; my $buff = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$self->{DATASET}->{$name}->{TYPE}}, reverse @$end ); my $res = _SDreaddata( $self->{DATASET}->{$name}->{SDSID}, $c_start, $c_stride, $c_end, $buff ); if($res == PDL::IO::HDF->FAIL) { $buff = null; print "$sub: Error returned from _SDreaddata()!\n"; } return $buff; } # End of SDget()... =head2 SDsetfillvalue =for ref Set the fill value for an SDS. =for usage Arguments: 1 : The name of the SDS. 2 : The fill value. Returns true on success, undef on error. =for example my $res = $hdf->SDsetfillvalue("dataset_name",$fillvalue); =cut sub SDsetfillvalue { my ($self, $name, $value) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); $value = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($value); $self->{DATASET}->{$name}->{ATTRS}->{_FillValue} = $value; return( _SDsetfillvalue($self->{DATASET}->{$name}->{SDSID}, $value) + 1 ); } # End of SDsetfillvalue()... =head2 SDsetrange =for ref Set the valid range of an SDS. =for usage Arguments: 1 : The name of the SDS 2 : an anonymous array of two elements : [min, max]. Returns true on success, undef on error. =for example my $res = $hdf->SDsetrange("dataset_name", [$min, $max]); =cut sub SDsetrange { my ($self, $name, $range) = @_; return undef unless defined( $self->{DATASET}->{$name} ); my $min = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($$range[0]); my $max = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($$range[1]); $range = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($range); $self->{DATASET}->{$name}->{ATTRS}->{valid_range} = $range; return( _SDsetrange($self->{DATASET}->{$name}->{SDSID}, $max, $min) + 1 ); } # End of SDsetrange()... =head2 SDsetcal =for ref Set the HDF calibration for an SDS. In HDF lingo, this means to define: scale factor scale factor error offset offset error =for usage Arguments: 1 : The name of the SDS. 2 (optional): the scale factor (default is 1) 3 (optional): the scale factor error (default is 0) 4 (optional): the offset (default is 0) 5 (optional): the offset error (default is 0) Returns true on success, undef on error. NOTE: This is not required to make a valid HDF SDS, but is there if you want to use it. =for example # Create the dataset: my $res = $hdf->SDsetcal("dataset_name"); # To just set the scale factor: $res = $hdf->SDsetcal("dataset_name", $scalefactor); # To set all calibration parameters: $res = $hdf->SDsetcal("dataset_name", $scalefactor, $scale_err, $offset, $off_err); =cut sub SDsetcal { my $self = shift; my $name = shift; return( undef ) unless defined( $self->{DATASET}->{$name} ); $self->{DATASET}->{$name}->{ATTRS}->{scale_factor} = shift || 1; $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err} = shift || 0; $self->{DATASET}->{$name}->{ATTRS}->{add_offset} = shift || 0; $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err} = shift || 0; # PDL_Double is the default type: $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt} = shift || 6; return( _SDsetcal( $self->{DATASET}->{$name}->{SDSID}, $self->{DATASET}->{$name}->{ATTRS}->{scale_factor}, $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err}, $self->{DATASET}->{$name}->{ATTRS}->{add_offset}, $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err}, $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt} ) + 1); } # End of SDsetcal()... =head2 SDsetcompress =for ref Set the internal compression on an SDS. =for usage Arguments: 1 : The name of the SDS. 2 (optional): The gzip compression level ( 1 - 9 ). If not specified, then 6 is used. Returns true on success, undef on failure. WARNING: This is a fairly buggy feature with many version of the HDF library. Please just use the 'Chunking' features instead, as they work far better, and are more reliable. =for example my $res = $hdf->SDsetfillvalue("dataset_name",$deflate_value); =cut sub SDsetcompress { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); # NOTE: Behavior change from the old version: # it used to set to 6 if the passed value was greater than 8 # it now sets it to 9 if it's greater than 9. my $deflate = shift || 6; $deflate = 9 if( $deflate > 9 ); return( 1 + _SDsetcompress( $self->{DATASET}->{$name}->{SDSID}, $deflate ) ); } # End of SDsetcompress()... =head2 SDsettextattr =for ref Add a text HDF attribute, either globally, or to an SDS. =for usage Arguments: 1 : The text you want to add. 2 : The name of the attribute 3 (optional): The name of the SDS. Returns true on success, undef on failure. =for example # Set a global text attribute: my $res = $hdf->SDsettextattr("my_text", "attribut_name"); # Set a local text attribute for 'dataset_name': $res = $hdf->SDsettextattr("my_text", "attribut_name", "dataset_name"); =cut sub SDsettextattr { my ($self, $text, $name, $dataset) = @_; if( defined($dataset) ) { return( undef ) unless defined( $self->{DATASET}->{$dataset} ); $self->{DATASET}->{$dataset}->{ATTRS}->{$name} = $text; return( _SDsetattr_text( $self->{DATASET}->{$dataset}->{SDSID}, $name, $text, length($text) ) + 1 ); } # Implied else it's a global attribute: $self->{GLOBATTR}->{$name} = $text; return( _SDsetattr_text( $self->{SDID}, $name, $text, length($text) ) + 1); } # End of SDsettextattr()... =head2 SDsetvalueattr =for ref Add a non-text HDF attribute, either globally, or to an SDS. =for usage Arguments: 1 : A pdl of value(s) you want to store. 2 : The name of the attribute. 3 (optional): the name of the SDS. Returns true on success, undef on failure. =for example my $attr = sequence( long, 4 ); # Set a global attribute: my $res = $hdf->SDsetvalueattr($attribute, "attribute_name"); # Set a local attribute for 'dataset_name': $res = $hdf->SDsetvalueattr($attribute, "attribute_name", "dataset_name"); =cut sub SDsetvalueattr { my ($self, $values, $name, $dataset) = @_; if( defined($dataset) ) { return( undef ) unless defined( $self->{DATASET}->{$dataset} ); $self->{DATASET}->{$dataset}->{ATTRS}->{$name} = $values; return( _SDsetattr_values( $self->{DATASET}->{$dataset}->{SDSID}, $name, $values, $values->nelem(), $PDL::IO::HDF::SDtypeTMAP->{$values->get_datatype()} ) + 1); } # Implied else it's a global attribute: $self->{GLOBATTR}->{$name} = $values; return( _SDsetattr_values( $self->{SDID}, $name, $values, $values->nelem(), $PDL::IO::HDF::SDtypeTMAP->{$values->get_datatype()} ) + 1); } # End of SDsetvalueattr()... =head2 SDsetdimname =for ref Set or rename the dimensions of an SDS. =for usage Arguments: 1 : The name of the SDS. 2 : An anonymous array with the dimensions names. For dimensions you want to leave alone, leave 'undef' placeholders. Returns true on success, undef on failure. =for example # Rename all dimensions my $res = $hdf->SDsetdimname("dataset_name", ['dim1','dim2','dim3']); # Rename some dimensions $res = $hdf->SDsetdimname("dataset_name", ['dim1', undef ,'dim3']); =cut # FIXME: There are several problems with this: # - The return code is an aggregate, and not necessarily accurate # - It bails on the first error without trying the rest. If that is still # desired, then it should run the check first, and if it's ok, then actually # make the HDF library call. sub SDsetdimname { my ($self, $name, $dimname) = @_; return undef unless defined( $self->{DATASET}->{$name} ); my $res = 0; foreach( sort keys %{$self->{DATASET}->{$name}->{DIMS}} ) { return( undef ) unless defined( $$dimname[ $_ ] ); $res = _SDsetdimname( $self->{DATASET}->{$name}->{DIMS}->{$_}->{DIMID}, $$dimname[ $_ ] ) + 1; } return( $res ); } # End of SDsetdimname()... =head2 SDput =for ref Write to a SDS in an HDF file or create and write to it if it doesn't exist. =for usage Arguments: 1 : The name of the SDS. 2 : A pdl of data. 3 (optional): An anonymous array of the dim names (only for creation) 4 (optional): An anonymous array of the start of the slice to store (only for putting a slice) Returns true on success, undef on failure. The datatype of the SDS in the HDF file will match the PDL equivalent as much as possible. =for example my $data = sequence( float, 10, 20, 30 ); #any value you want # Simple case: create a new dataset with a $data pdl my $result = $hdf->SDput("dataset_name", $data); # Above, but also naming the dims: $res = $hdf->SDput("dataset_name", $data, ['dim1','dim2','dim3']); # Just putting a slice in there: my $start = [x,y,z]; $res = $hdf->SDput("dataset_name", $data->slice("..."), undef, $start); =cut sub SDput { my($self, $name, $data, $dimname_p, $from) = @_; my $sub = _pkg_name( 'SDput' ); my $rank = $data->getndims(); my $dimsize = pack ("L*", reverse $data->dims); # If this dataset doesn't already exist, then create it: # unless ( defined( $self->{DATASET}->{$name} ) ) { my $hdf_type = $PDL::IO::HDF::SDtypeTMAP->{$data->get_datatype()}; my $res = _SDcreate( $self->{SDID}, $name, $hdf_type, $rank, $dimsize ); return( undef ) if ($res == PDL::IO::HDF->FAIL); $self->{DATASET}->{$name}->{SDSID} = $res; $self->{DATASET}->{$name}->{TYPE} = $hdf_type; $self->{DATASET}->{$name}->{RANK} = $rank; if( $self->Chunking() ) { # Setup chunking on this dataset: my @chunk_lens; my $min_chunk_size = 100; my $num_chunks = 10; my $total_chunks = 1; foreach my $dimsize ( $data->dims() ) { my $chunk_size = ($dimsize + 9) / $num_chunks; my $num_chunks_this_dim = $num_chunks; if( $chunk_size < $min_chunk_size ) { $chunk_size = $min_chunk_size; # Re-calc the num_chunks_per_dim: $num_chunks_this_dim = POSIX::ceil( $dimsize / $chunk_size ); } push(@chunk_lens, $chunk_size); $total_chunks *= $num_chunks_this_dim; } my $chunk_lengths = pack("L*", reverse @chunk_lens); $res = _SDsetchunk( $self->{DATASET}->{$name}->{SDSID}, $rank, $chunk_lengths ); return( undef ) if ($res == PDL::IO::HDF->FAIL); $res = _SDsetchunkcache( $self->{DATASET}->{$name}->{SDSID}, $total_chunks, 0); return( undef ) if ($res == PDL::IO::HDF->FAIL); } # End of chunking section... } # End of dataset creation... my $start = []; my $stride = []; if( defined( $from ) ) { $start = $from; foreach($data->dims) { push(@$stride, 1); } } else { # $from was not defined, so assume we're doing all of it: foreach($data->dims) { push(@$start, 0); push(@$stride, 1); } } $start = pack ("L*", @$start); $stride = pack ("L*", @$stride); $data->make_physical(); $res = _SDwritedata( $self->{DATASET}->{$name}->{SDSID}, $start, $stride, $dimsize, $data ); return( undef ) if ($res == PDL::IO::HDF->FAIL); foreach my $j ( 0 .. $rank-1 ) { # Probably not a good way to bail: my $dim_id = _SDgetdimid( $self->{DATASET}->{$name}->{SDSID}, $j ); return( undef ) if( $dim_id == PDL::IO::HDF->FAIL); if( defined( @$dimname_p[$j] ) ) { $res = _SDsetdimname( $dim_id, @$dimname_p[$j] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); } my $dimname = " "x(PDL::IO::HDF->MAX_NC_NAME); my $size = 0; my $num_dim_attrs = 0; $res = _SDdiminfo( $dim_id, $dimname, $size, $numtype=0, $num_dim_attrs); return( undef ) if ($res == PDL::IO::HDF->FAIL); $self->{DATASET}->{$name}->{DIMS}->{$j}->{NAME} = $dimname; $self->{DATASET}->{$name}->{DIMS}->{$j}->{SIZE} = $size; $self->{DATASET}->{$name}->{DIMS}->{$j}->{DIMID} = $dim_id; } return( 1 ); } # End of SDput()... =head2 close =for ref Close an HDF file. =for usage No arguments. =for example my $result = $hdf->close(); =cut # NOTE: This may not be enough, since there may be opened datasets as well! SDendaccess()! sub close { my $self = shift; my $sdid = $self->{SDID}; $self = undef; return( _SDend( $sdid ) + 1); } # End of close()... sub DESTROY { my $self = shift; $self->close; } # End of DESTROY()... =head1 CURRENT AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 PREVIOUS AUTHORS Patrick Leilde patrick.leilde@ifremer.fr contribs of Olivier Archer olivier.archer@ifremer.fr =head1 SEE ALSO perl(1), PDL(1), PDL::IO::HDF(1). =cut ; # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/HDF.pm�������������������������������������������������������������������0000644�0601750�0601001�00000033244�13110402066�013556� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::HDF; @EXPORT_OK = qw( ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::HDF ; =head1 NAME PDL::IO::HDF - An interface library for HDF4 files. =head1 SYNOPSIS use PDL; use PDL::IO::HDF::VS; #### no doc for now #### =head1 DESCRIPTION This librairy provide functions to manipulate HDF4 files with VS and V interface (reading, writing, ...) For more information on HDF4, see http://www.hdfgroup.org/products/hdf4/ =head1 FUNCTIONS =cut use PDL::Primitive; use PDL::Basic; use strict; use PDL::IO::HDF; my $TMAP = { PDL::byte->[0] => 1, PDL::short->[0] => 2, PDL::ushort->[0] => 2, PDL::long->[0] => 4, PDL::float->[0] => 4, PDL::double->[0] => 8 }; sub _pkg_name { return "PDL::IO::HDF::VS::" . shift() . "()"; } =head2 new =for ref Open or create a new HDF object with VS and V interface. =for usage Arguments: 1 : The name of the HDF file. If you want to write to it, prepend the name with the '+' character : "+name.hdf" If you want to create it, prepend the name with the '-' character : "-name.hdf" Otherwise the file will be opened in read only mode. Returns the hdf object (die on error) =for example my $hdf = PDL::IO::HDF::VS->new("file.hdf"); =cut sub new { # general my $type = shift; my $filename = shift; my $self = {}; if (substr($filename, 0, 1) eq '+') { # open for writing $filename = substr ($filename, 1); # chop off + $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } if (substr($filename, 0, 1) eq '-') { # Creating $filename = substr ($filename, 1); # chop off - $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE; } unless( defined($self->{ACCESS_MODE}) ) { $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ; } $self->{FILE_NAME} = $filename; $self->{HID} = PDL::IO::HDF::VS::_Hopen( $self->{FILE_NAME}, $self->{ACCESS_MODE}, 20 ); if ($self->{HID}) { PDL::IO::HDF::VS::_Vstart( $self->{HID} ); my $SDID = PDL::IO::HDF::VS::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} ); #### search for vgroup my $vgroup = {}; my $vg_ref = -1; while( ($vg_ref = PDL::IO::HDF::VS::_Vgetid( $self->{HID}, $vg_ref )) != PDL::IO::HDF->FAIL) { my $vg_id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $vg_ref, 'r' ); my $n_entries = 0; my $vg_name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_Vinquire( $vg_id, $n_entries, $vg_name ); my $vg_class = ""; PDL::IO::HDF::VS::_Vgetclass( $vg_id, $vg_class ); $vgroup->{$vg_name}->{ref} = $vg_ref; $vgroup->{$vg_name}->{class} = $vg_class; my $n_pairs = PDL::IO::HDF::VS::_Vntagrefs( $vg_id ); for ( 0 .. $n_pairs-1 ) { my ($tag, $ref); $res = PDL::IO::HDF::VS::_Vgettagref( $vg_id, $_, $tag = 0, $ref = 0 ); if($tag == 1965) { # Vgroup my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'r' ); my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_Vgetname( $id, $name ); PDL::IO::HDF::VS::_Vdetach( $id ); $vgroup->{$vg_name}->{children}->{$name} = $ref; $vgroup->{$name}->{parents}->{$vg_name} = $vg_ref; } elsif($tag == 1962) { # Vdata my $id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $ref, 'r' ); my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_VSgetname( $id, $name ); my $class = ""; PDL::IO::HDF::VS::_VSgetclass( $id, $class ); PDL::IO::HDF::VS::_VSdetach( $id ); $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'VData'; $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref; $vgroup->{$vg_name}->{attach}->{$name}->{class} = $class if( $class ne '' ); } if( ($SDID != PDL::IO::HDF->FAIL) && ($tag == 720)) #tag for SDS tag/ref (see 702) { my $i = _SDreftoindex( $SDID, $ref ); my $sds_ID = _SDselect( $SDID, $i ); my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $rank = 0; my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 ); my $numtype = 0; my $nattrs = 0; $res = _SDgetinfo( $sds_ID, $name, $rank, $dimsize , $numtype, $nattrs ); $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'SDS_Data'; $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref; } } # for each pair... PDL::IO::HDF::VS::_Vdetach( $vg_id ); } # while vg_ref... PDL::IO::HDF::VS::_SDend( $SDID ); $self->{VGROUP} = $vgroup; #### search for vdata my $vdata_ref=-1; my $vdata_id=-1; my $vdata = {}; # get lone vdata (not member of a vgroup) my $lone=PDL::IO::HDF::VS::_VSlone($self->{HID}); my $MAX_REF = 0; while ( $vdata_ref = shift @$lone ) { my $mode="r"; if ( $self->{ACCESS_MODE} != PDL::IO::HDF->DFACC_READ ) { $mode="w"; } $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, $mode ); my $vdata_size = 0; my $n_records = 0; my $interlace = 0; my $fields = ""; my $vdata_name = ""; my $status = PDL::IO::HDF::VS::_VSinquire( $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name ); die "PDL::IO::HDF::VS::_VSinquire (vdata_id=$vdata_id)" unless $status; $vdata->{$vdata_name}->{REF} = $vdata_ref; $vdata->{$vdata_name}->{NREC} = $n_records; $vdata->{$vdata_name}->{INTERLACE} = $interlace; $vdata->{$vdata_name}->{ISATTR} = PDL::IO::HDF::VS::_VSisattr( $vdata_id ); my $field_index = 0; foreach my $onefield ( split( ",", $fields ) ) { $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{TYPE} = PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $field_index ); $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{INDEX} = $field_index; $field_index++; } PDL::IO::HDF::VS::_VSdetach( $vdata_id ); } # while vdata_ref... $self->{VDATA} = $vdata; } # if $self->{HDID}... bless($self, $type); } # End of new()... sub Vgetchildren { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{children} ); return keys %{$self->{VGROUP}->{$name}->{children}}; } # End of Vgetchildren()... # Now defunct: sub Vgetchilds { my $self = shift; return $self->Vgetchildren( @_ ); } # End of Vgetchilds()... sub Vgetattach { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{attach} ); return keys %{$self->{VGROUP}->{$name}->{children}}; } # End of Vgetattach()... sub Vgetparents { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{parents} ); return keys %{$self->{VGROUP}->{$name}->{parents}}; } # End of Vgetparents()... sub Vgetmains { my ($self) = @_; my @rlist; foreach( keys %{$self->{VGROUP}} ) { push(@rlist, $_) unless defined( $self->{VGROUP}->{$_}->{parents} ); } return @rlist; } # End of Vgetmains()... sub Vcreate { my($self, $name, $class, $where) = @_; my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, -1, 'w' ); return( undef ) if( $id == PDL::IO::HDF->FAIL ); my $res = _Vsetname($id, $name); $res = _Vsetclass($id, $class) if defined( $class ); $self->{VGROUP}->{$name}->{ref} = '???'; $self->{VGROUP}->{$name}->{class} = $class if defined( $class ); if( defined( $where ) ) { return( undef ) unless defined( $self->{VGROUP}->{$where} ); my $ref = $self->{VGROUP}->{$where}->{ref}; my $Pid = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'w' ); my $index = PDL::IO::HDF::VS::_Vinsert( $Pid, $id ); my ($t, $r) = (0, 0); $res = PDL::IO::HDF::VS::_Vgettagref( $Pid, $index, $t, $r ); PDL::IO::HDF::VS::_Vdetach( $Pid ); $self->{VGROUP}->{$name}->{parents}->{$where} = $ref; $self->{VGROUP}->{$where}->{children}->{$name} = $r; $self->{VGROUP}->{$name}->{ref} = $r; } return( _Vdetach( $id ) + 1 ); } # End of Vcreate()... =head2 close =for ref Close the VS interface. =for usage no arguments =for example my $result = $hdf->close(); =cut sub close { my $self = shift; _Vend( $self->{HID} ); my $Hid = $self->{HID}; $self = undef; return( _Hclose($Hid) + 1 ); } # End of close()... sub VSisattr { my($self, $name) = @_; return undef unless defined( $self->{VDATA}->{$name} ); return $self->{VDATA}->{$name}->{ISATTR}; } # End of VSisattr()... sub VSgetnames { my $self = shift; return keys %{$self->{VDATA}}; } # End of VSgetnames()... sub VSgetfieldnames { my ( $self, $name ) = @_; my $sub = _pkg_name( 'VSgetfieldnames' ); die "$sub: vdata name $name doesn't exist!\n" unless defined( $self->{VDATA}->{$name} ); return keys %{$self->{VDATA}->{$name}->{FIELDS}}; } # End of VSgetfieldnames()... # Now defunct: sub VSgetfieldsnames { my $self = shift; return $self->VSgetfieldnames( @_ ); } # End of VSgetfieldsnames()... sub VSread { my ( $self, $name, $field ) = @_; my $sub = _pkg_name( 'VSread' ); my $data = null; my $vdata_ref = PDL::IO::HDF::VS::_VSfind( $self->{HID}, $name ); die "$sub: vdata name $name doesn't exist!\n" unless $vdata_ref; my $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, 'r' ); my $vdata_size = 0; my $n_records = 0; my $interlace = 0; my $fields = ""; my $vdata_name = ""; my $status = PDL::IO::HDF::VS::_VSinquire( $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name ); my $data_type = PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} ); die "$sub: data_type $data_type not implemented!\n" unless defined( $PDL::IO::HDF::SDinvtypeTMAP->{$data_type} ); my $order = PDL::IO::HDF::VS::_VFfieldorder( $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} ); if($order == 1) { $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records ); } else { $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records, $order ); } $status = PDL::IO::HDF::VS::_VSsetfields( $vdata_id, $field ); die "$sub: _VSsetfields\n" unless $status; $status = PDL::IO::HDF::VS::_VSread( $vdata_id, $data, $n_records, $interlace); PDL::IO::HDF::VS::_VSdetach( $vdata_id ); return $data; } # End of VSread()... sub VSwrite { my($self, $name, $mode, $field, $value) = @_; return( undef ) if( $$value[0]->getndims > 2); #too many dims my $VD_id; my $res; my @foo = split( /:/, $name ); return( undef ) if defined( $self->{VDATA}->{$foo[0]} ); $VD_id = _VSattach( $self->{HID}, -1, 'w' ); return( undef ) if( $VD_id == PDL::IO::HDF->FAIL ); $res = _VSsetname( $VD_id, $foo[0] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); $res = _VSsetclass( $VD_id, $foo[1] ) if defined( $foo[1] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); my @listfield = split( /,/, $field ); for( my $i = 0; $i <= $#$value; $i++ ) { my $HDFtype = $PDL::IO::HDF::SDtypeTMAP->{$$value[$i]->get_datatype()}; $res = _VSfdefine( $VD_id, $listfield[$i], $HDFtype, $$value[$i]->getdim(1) ); return( undef ) unless $res; } $res = _VSsetfields( $VD_id, $field ); return( undef ) unless $res; my @sizeofPDL; my @sdimofPDL; foreach ( @$value ) { push(@sdimofPDL, $_->getdim(1)); push(@sizeofPDL, $TMAP->{$_->get_datatype()}); } $res = _WriteMultPDL( $VD_id, $$value[0]->getdim(0), $#$value+1, $mode, \@sizeofPDL, \@sdimofPDL, $value); return( undef ) if( _VSdetach($VD_id) == PDL::IO::HDF->FAIL ); return $res; } # End of VSwrite()... sub DESTROY { my $self = shift; $self->close; } # End of DESTROY()... =head1 CURRENT AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 PREVIOUS AUTHORS Olivier Archer olivier.archer@ifremer.fr contribs of Patrick Leilde patrick.leilde@ifremer.fr =head1 SEE ALSO perl(1), PDL(1), PDL::IO::HDF(1). =cut ; # Exit with OK status 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/Misc.pm������������������������������������������������������������������0000644�0601750�0601001�00000122100�13110402063�014033� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Misc; @EXPORT_OK = qw( rcols wcols swcols rgrep rdsa PDL::PP bswap2 PDL::PP bswap4 PDL::PP bswap8 isbigendian rasc rcube PDL::PP _rasc ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Misc ; =head1 NAME PDL::IO::Misc - misc IO routines for PDL =head1 DESCRIPTION Some basic I/O functionality: FITS, tables, byte-swapping =head1 SYNOPSIS use PDL::IO::Misc; =cut =head1 FUNCTIONS =cut use PDL::Primitive; use PDL::Types; use PDL::Options; use PDL::Bad; use Carp; use Symbol qw/ gensym /; use List::Util; use strict; =head2 bswap2 =for sig Signature: (x(); ) =for ref Swaps pairs of bytes in argument x() =for bad bswap2 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bswap2 = \&PDL::bswap2; =head2 bswap4 =for sig Signature: (x(); ) =for ref Swaps quads of bytes in argument x() =for bad bswap4 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bswap4 = \&PDL::bswap4; =head2 bswap8 =for sig Signature: (x(); ) =for ref Swaps octets of bytes in argument x() =for bad bswap8 does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bswap8 = \&PDL::bswap8; # Internal routine to extend PDL array by size $n along last dimension # - Would be nice to have a proper extend function rather than hack # - Is a NO-OP when handed a perl ARRAY ref rather than a piddle arg sub _ext_lastD { # Called by rcols and rgrep my ($a,$n) = @_; if (ref($_[0]) ne 'ARRAY') { my @nold = $a->dims; my @nnew = @nold; $nnew[-1] += $n; # add $n to the last dimension my $b = zeroes($a->type,@nnew); # New pdl my $bb = $b->mv(-1,0)->slice("0:".($nold[-1]-1))->mv(0,-1); $bb .= $a; $_[0] = $b; } 1; } # Implements PDL->at() for either 1D PDL or ARRAY arguments # TODO: Need to add support for multidim piddles parallel to rcols sub _at_1D ($$) { # Called by wcols and swcols my $data = $_[0]; my $index = $_[1]; if (ref $data eq 'ARRAY') { return $data->[$index]; } else { return $data->at($index); } } # squeezes "fluffy" perl list values into column data type sub _burp_1D { my $data = $_[0]->[0]; my $databox = $_[0]->[1]; my $index = $_[1]; my $start = $index - @{$databox} + 1; my $tmp; # work around for perl -d "feature" if (ref $data eq 'ARRAY') { push @{$data}, @{$databox}; } elsif ( ref($databox->[0]) eq "ARRAY" ) { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) ($tmp = $data->slice(":,$start:$index")) .= pdl($databox); } else { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) ($tmp = $data->slice("$start:$index")) .= pdl($databox); } $_[0] = [ $data, [] ]; } # taken outside of rcols() to avoid clutter sub _handle_types ($$$) { my $ncols = shift; my $deftype = shift; my $types = shift; barf "Unknown PDL type given for DEFTYPE.\n" unless ref($deftype) eq "PDL::Type"; my @cols = ref($types) eq "ARRAY" ? @$types : (); if ( $#cols > -1 ) { # truncate if required $#cols = $ncols if $#cols > $ncols; # check input values are sensible for ( 0 .. $#cols ) { barf "Unknown value '$cols[$_]' in TYPES array.\n" unless ref($cols[$_]) eq "PDL::Type"; } } # fill in any missing columns for ( ($#cols+1) .. $ncols ) { push @cols, $deftype; } return @cols; } # sub: _handle_types # Whether an object is an IO handle use Scalar::Util; sub _is_io_handle { my $h = shift; # reftype catches almost every handle, except: *MYHANDLE # fileno catches *MYHANDLE, but doesn't catch handles that aren't files my $reftype = Scalar::Util::reftype($h); return defined(fileno($h)) || (defined($reftype) && $reftype eq 'GLOB'); } =head2 rcols =for ref Read specified ASCII cols from a file into piddles and perl arrays (also see L</rgrep>). =for usage Usage: ($x,$y,...) = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, $col1, $col2, ... ) $x = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, [] ) ($x,$y,...) = rcols( *HANDLE|"filename", $col1, $col2, ..., { EXCLUDE => '/^!/' } ) ($x,$y,...) = rcols( *HANDLE|"filename", "/foo/", $col1, $col2, ... ) For each column number specified, a 1D output PDL will be generated. Anonymous arrays of column numbers generate 2D output piddles with dim0 for the column data and dim1 equal to the number of columns in the anonymous array(s). An empty anonymous array as column specification will produce a single output data piddle with dim(1) equal to the number of columns available. There are two calling conventions - the old version, where a pattern can be specified after the filename/handle, and the new version where options are given as as hash reference. This reference can be given as either the second or last argument. The default behaviour is to ignore lines beginning with a # character and lines that only consist of whitespace. Options exist to only read from lines that match, or do not match, supplied patterns, and to set the types of the created piddles. Can take file name or *HANDLE, and if no explicit column numbers are specified, all are assumed. For the allowed types, see L<PDL::Core/Datatype_conversions>. Options (case insensitive): EXCLUDE or IGNORE - ignore lines matching this pattern (default B<'/^#/'>). INCLUDE or KEEP - only use lines which match this pattern (default B<''>). LINES - a string pattern specifying which line numbers to use. Line numbers start at 0 and the syntax is 'a:b:c' to use every c'th matching line between a and b (default B<''>). DEFTYPE - default data type for stored data (if not specified, use the type stored in C<$PDL::IO::Misc::deftype>, which starts off as B<double>). TYPES - reference to an array of data types, one element for each column to be read in. Any missing columns use the DEFTYPE value (default B<[]>). COLSEP - splits on this string/pattern/qr{} between columns of data. Defaults to $PDL::IO::Misc::defcolsep. PERLCOLS - an array of column numbers which are to be read into perl arrays rather than piddles. Any columns not specified in the explicit list of columns to read will be returned after the explicit columns. (default B<undef>). COLIDS - if defined to an array reference, it will be assigned the column ID values obtained by splitting the first line of the file in the identical fashion to the column data. CHUNKSIZE - the number of input data elements to batch together before appending to each output data piddle (Default value is 100). If CHUNKSIZE is greater than the number of lines of data to read, the entire file is slurped in, lines split, and perl lists of column data are generated. At the end, effectively pdl(@column_data) produces any result piddles. VERBOSE - be verbose about IO processing (default C<$PDL::vebose>) =for example For example: $x = PDL->rcols 'file1'; # file1 has only one column of data $x = PDL->rcols 'file2', []; # file2 can have multiple columns, still 1 piddle output # (empty array ref spec means all possible data fields) ($x,$y) = rcols 'table.csv', { COLSEP => ',' }; # read CSV data file ($x,$y) = rcols *STDOUT; # default separator for lines like '32 24' # read in lines containing the string foo, where the first # example also ignores lines that begin with a # character. ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/' }; ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/', EXCLUDE => '' }; # ignore the first 27 lines of the file, reading in as ushort's ($x,$y) = rcols 'file3', { LINES => '27:-1', DEFTYPE => ushort }; ($x,$y) = rcols 'file3', { LINES => '27:', TYPES => [ ushort, ushort ] }; # read in the first column as a perl array and the next two as piddles # with the perl column returned after the piddle outputs ($x,$y,$name) = rcols 'file4', 1, 2 , { PERLCOLS => [ 0 ] }; printf "Number of names read in = %d\n", 1 + $#$name; # read in the first column as a perl array and the next two as piddles # with PERLCOLS changing the type of the first returned value to perl list ref ($name,$x,$y) = rcols 'file4', 0, 1, 2, { PERLCOLS => [ 0 ] }; # read in the first column as a perl array returned first followed by the # the next two data columns in the file as a single Nx2 piddle ($name,$xy) = rcols 'file4', 0, [1, 2], { PERLCOLS => [ 0 ] }; NOTES: 1. Quotes are required on patterns or use the qr{} quote regexp syntax. 2. Columns are separated by whitespace by default, use the COLSEP option separator to specify an alternate split pattern or string or specify an alternate default separator by setting C<$PDL::IO::Misc::defcolsep> . 3. Legacy support is present to use C<$PDL::IO::Misc::colsep> to set the column separator but C<$PDL::IO::Misc::colsep> is not defined by default. If you set the variable to a defined value it will get picked up. 4. LINES => '-1:0:3' may not work as you expect, since lines are skipped when read in, then the whole array reversed. 5. For consistency with wcols and rcols 1D usage, column data is loaded into the rows of the pdls (i.e., dim(0) is the elements read per column in the file and dim(1) is the number of columns of data read. =cut use vars qw/ $colsep $defcolsep $deftype /; $defcolsep = ' '; # Default column separator $deftype = double; # Default type for piddles my $defchunksize = 100; # Number of perl list items to append to piddle my $usecolsep; # This is the colsep value that is actually used # NOTE: XXX # need to look at the line-selection code. For instance, if want # lines => '-1:0:3', # read in all lines, reverse, then apply the step # -> fix point 4 above # # perhaps should just simplify the LINES option - ie remove # support for reversed arrays? sub rcols{ PDL->rcols(@_) } sub PDL::rcols { my $class = shift; barf 'Usage ($x,$y,...) = rcols( *HANDLE|"filename", ["/pattern/" or \%options], $col1, $col2, ..., [ \%options] )' if $#_<0; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; shift; # set up default options my $opt = new PDL::Options( { CHUNKSIZE => undef, COLIDS => undef, COLSEP => undef, DEFTYPE => $deftype, EXCLUDE => '/^#/', INCLUDE => undef, LINES => '', PERLCOLS => undef, TYPES => [], VERBOSE=> $PDL::verbose, } ); $opt->synonyms( { IGNORE => 'EXCLUDE', KEEP => 'INCLUDE' } ); # has the user supplied any options if ( defined($_[0]) ) { # ensure the old-style behaviour by setting the exclude pattern to undef if ( $_[0] =~ m|^/.*/$| ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "Regexp" ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "HASH" ) { $opt->options( shift ); } } # maybe the last element is a hash array as well $opt->options( pop ) if defined($_[-1]) and ref($_[-1]) eq "HASH"; # a reference to a hash array my $options = $opt->current(); # handle legacy colsep variable $usecolsep = (defined $colsep) ? qr{$colsep} : undef; $usecolsep = qr{$options->{COLSEP}} if $options->{COLSEP}; # what are the patterns? foreach my $pattern ( qw( INCLUDE EXCLUDE ) ) { if ( $options->{$pattern} and ref($options->{$pattern}) ne "Regexp" ) { if ( $options->{$pattern} =~ m|^/.*/$| ) { $options->{$pattern} =~ s|^/(.*)/$|$1|; $options->{$pattern} = qr($options->{$pattern}); } else { barf "rcols() - unable to process $pattern value.\n"; } } } # CHUNKSIZE controls memory/time tradeoff of piddle IO my $chunksize = $options->{CHUNKSIZE} || $defchunksize; my $nextburpindex = -1; # which columns are to be read into piddles and which into perl arrays? my @end_perl_cols = (); # unique perl cols to return at end my @perl_cols = (); # perl cols index list from PERLCOLS option @perl_cols = @{ $$options{PERLCOLS} } if $$options{PERLCOLS}; my @is_perl_col; # true if index corresponds to a perl column for (@perl_cols) { $is_perl_col[$_] = 1; }; # print STDERR "rcols: \@is_perl_col is @is_perl_col\n"; my ( @explicit_cols ) = @_; # call specified columns to read # print STDERR "rcols: \@explicit_cols is @explicit_cols\n"; # work out which line numbers are required # - the regexp's are a bit over the top my ( $a, $b, $c ); if ( $$options{LINES} ne '' ) { if ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*$/ ) { $a = $1; $b = $2; } elsif ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*:\s*([+]?\d*)\s*$/ ) { $a = $1; $b = $2; $c = $3; } else { barf "rcols() - unable to parse LINES option.\n"; } } # Since we do not know how many lines there are in advance, things get a bit messy my ( $index_start, $index_end ) = ( 0, -1 ); $index_start = $a if defined($a) and $a ne ''; $index_end = $b if defined($b) and $b ne ''; my $line_step = $c || 1; # $line_rev = 0/1 for normal order/reversed # $line_start/_end refer to the first and last line numbers that we want # (the values of which we may not know until we've read in all the file) my ( $line_start, $line_end, $line_rev ); if ( ($index_start >= 0 and $index_end < 0) ) { # eg 0:-1 $line_rev = 0; $line_start = $index_start; } elsif ( $index_end >= 0 and $index_start < 0 ) { # eg -1:0 $line_rev = 1; $line_start = $index_end; } elsif ( $index_end >= $index_start and $index_start >= 0 ) { # eg 0:10 $line_rev = 0; $line_start = $index_start; $line_end = $index_end; } elsif ( $index_start > $index_end and $index_end >= 0 ) { # eg 10:0 $line_rev = 1; $line_start = $index_end; $line_end = $index_start; } elsif ( $index_start <= $index_end ) { # eg -5:-1 $line_rev = 0; } else { # eg -1:-5 $line_rev = 1; } my @ret; my ($k,$fhline); my $line_num = -1; my $line_ctr = $line_step - 1; # ensure first line is always included my $index = -1; my $pdlsize = 0; my $extend = 10000; my $line_store; # line numbers of saved data RCOLS_IO: { if ($options->{COLIDS}) { print STDERR "rcols: processing COLIDS option\n" if $options->{VERBOSE}; undef $!; if (defined($fhline = <$fh>) ) { # grab first line's fields for column IDs $fhline =~ s/\r?\n$//; # handle DOS on unix files better my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); @{$options->{COLIDS}} = @v; } else { die "rcols: reading COLIDS info, $!" if $!; last RCOLS_IO; } } while( defined($fhline = <$fh>) ) { # chomp $fhline; $fhline =~ s/\r?\n$//; # handle DOS on unix files better $line_num++; # the order of these checks is important, particularly whether we # check for line_ctr before or after the pattern matching # Prior to PDL 2.003 the line checks were done BEFORE the # pattern matching # # need this first check, even with it almost repeated at end of loop, # incase the pattern matching excludes $line_num == $line_end, say last if defined($line_end) and $line_num > $line_end; next if defined($line_start) and $line_num < $line_start; next if $options->{EXCLUDE} and $fhline =~ /$options->{EXCLUDE}/; next if $options->{INCLUDE} and not $fhline =~ /$options->{INCLUDE}/; next unless ++$line_ctr == $line_step; $line_ctr = 0; $index++; my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); # map empty fields '' to undef value @v = map { $_ eq '' ? undef : $_ } @v; # if the first line, set up the output piddles using all the columns # if the user doesn't specify anything if ( $index == 0 ) { # Handle implicit multicolumns in command line if ($#explicit_cols < 0) { # implicit single col data @explicit_cols = ( 0 .. $#v ); } if (scalar(@explicit_cols)==1 and ref($explicit_cols[0]) eq "ARRAY") { if ( !scalar(@{$explicit_cols[0]}) ) { # implicit multi-col data @explicit_cols = ( [ 0 .. $#v ] ); } } my $implicit_pdls = 0; my $is_explicit = {}; foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY") { $implicit_pdls++ if !scalar(@$col); } else { $is_explicit->{$col} = 1; } } if ($implicit_pdls > 1) { die "rcols: only one implicit multicolumn piddle spec allowed, found $implicit_pdls!\n"; } foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY" and !scalar(@$col)) { @$col = grep { !$is_explicit->{$_} } ( 0 .. $#v ); } } # remove declared perl columns from pdl data list $k = 0; my @pdl_cols = (); foreach my $col (@explicit_cols) { # strip out declared perl cols so they won't be read into piddles if ( ref($col) eq "ARRAY" ) { @$col = grep { !$is_perl_col[$_] } @{$col}; push @pdl_cols, [ @{$col} ]; } elsif (!$is_perl_col[$col]) { push @pdl_cols, $col; } } # strip out perl cols in explicit col list for return at end @end_perl_cols = @perl_cols; foreach my $col (@explicit_cols) { if ( ref($col) ne "ARRAY" and defined($is_perl_col[$col]) ) { @end_perl_cols = grep { $_ != $col } @end_perl_cols; } }; # sort out the types of the piddles my @types = _handle_types( $#pdl_cols, $$options{DEFTYPE}, $$options{TYPES} ); if ( $options->{VERBOSE} ) { # dbg aid print "Reading data into piddles of type: [ "; foreach my $t ( @types ) { print $t->shortctype() . " "; } print "]\n"; } $k = 0; for (@explicit_cols) { # Using mixed list+piddle data structure for performance tradeoff # between memory usage (perl list) and speed of IO (PDL operations) if (ref($_) eq "ARRAY") { # use multicolumn piddle here push @ret, [ $class->zeroes($types[$k++],scalar(@{$_}),1), [] ]; } else { push @ret, ($is_perl_col[$_] ? [ [], [] ] : [ $class->zeroes($types[$k],1), [] ]); $k++ unless $is_perl_col[$_]; } } for (@end_perl_cols) { push @ret, [ [], [] ]; } $line_store = [ $class->zeroes(long,1), [] ]; # only need to store integers } # if necessary, extend PDL in buffered manner $k = 0; if ( $pdlsize < $index ) { for (@ret, $line_store) { _ext_lastD( $_->[0], $extend ); } $pdlsize += $extend; } # - stick perl arrays onto end of $ret $k = 0; for (@explicit_cols, @end_perl_cols) { if (ref($_) eq "ARRAY") { push @{ $ret[$k++]->[1] }, [ @v[ @$_ ] ]; } else { push @{ $ret[$k++]->[1] }, $v[$_]; } } # store the line number push @{$line_store->[1]}, $line_num; # need to burp out list if needed if ( $index >= $nextburpindex ) { for (@ret, $line_store) { _burp_1D($_,$index); } $nextburpindex = $index + $chunksize; } # Thanks to Frank Samuelson for this last if defined($line_end) and $line_num == $line_end; } } close($fh) unless $is_handle; # burp one final time if needed and # clean out additional ARRAY ref level for @ret for (@ret, $line_store) { _burp_1D($_,$index) if defined $_ and scalar @{$_->[1]}; $_ = $_->[0]; } # have we read anything in? if not, return empty piddles if ( $index == -1 ) { print "Warning: rcols() did not read in any data.\n" if $options->{VERBOSE}; if ( wantarray ) { foreach ( 0 .. $#explicit_cols ) { if ( $is_perl_col[$_] ) { $ret[$_] = PDL->null; } else { $ret[$_] = []; } } for ( @end_perl_cols ) { push @ret, []; } return ( @ret ); } else { return PDL->null; } } # if the user has asked for lines => 0:-1 or 0:10 or 1:10 or 1:-1, # - ie not reversed and the last line number is known - # then we can skip the following nastiness if ( $line_rev == 0 and $index_start >= 0 and $index_end >= -1 ) { for (@ret) { ## $_ = $_->mv(-1,0)->slice("0:${index}")->mv(0,-1) unless ref($_) eq 'ARRAY'; $_ = $_->mv(-1,0)->slice("0:${index}") unless ref($_) eq 'ARRAY'; # cols are dim(0) }; if ( $options->{VERBOSE} ) { if ( ref($ret[0]) eq 'ARRAY' ) { print "Read in ", scalar( @{ $ret[0] } ), " elements.\n"; } else { print "Read in ", $ret[0]->nelem, " elements.\n"; } } wantarray ? return(@ret) : return $ret[0]; } # Work out which line numbers we want. First we clean up the piddle # containing the line numbers that have been read in $line_store = $line_store->slice("0:${index}"); # work out the min/max line numbers required if ( $line_rev ) { if ( defined($line_start) and defined($line_end) ) { my $dummy = $line_start; $line_start = $line_end; $line_end = $dummy; } elsif ( defined($line_start) ) { $line_end = $line_start; } else { $line_start = $line_end; } } $line_start = $line_num + 1 + $index_start if $index_start < 0; $line_end = $line_num + 1 + $index_end if $index_end < 0; my $indices; { no warnings 'precedence'; if ( $line_rev ) { $indices = which( $line_store >= $line_end & $line_store <= $line_start )->slice('-1:0'); } else { $indices = which( $line_store >= $line_start & $line_store <= $line_end ); } } # truncate the piddles for my $col ( @explicit_cols ) { if ( ref($col) eq "ARRAY" ) { for ( @$col ) { $ret[$_] = $ret[$_]->index($indices); } } else { $ret[$col] = $ret[$col]->index($indices) unless $is_perl_col[$col] }; } # truncate/reverse/etc the perl arrays my @indices_array = list $indices; foreach ( @explicit_cols, @end_perl_cols ) { if ( $is_perl_col[$_] ) { my @temp = @{ $ret[$_] }; $ret[$_] = []; foreach my $i ( @indices_array ) { push @{ $ret[$_] }, $temp[$i] }; } } # print some diagnostics if ( $options->{VERBOSE} ) { my $done = 0; foreach my $col (@explicit_cols) { last if $done; next if $is_perl_col[$col]; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } foreach my $col (@explicit_cols, @end_perl_cols) { last if $done; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } } # fix 2D pdls to match what wcols generates foreach my $col (@ret) { next if ref($col) eq "ARRAY"; $col = $col->mv(0,1) if $col->ndims == 2; } wantarray ? return(@ret) : return $ret[0]; } =head2 wcols =for ref Write ASCII columns into file from 1D or 2D piddles and/or 1D listrefs efficiently. Can take file name or *HANDLE, and if no file/filehandle is given defaults to STDOUT. Options (case insensitive): HEADER - prints this string before the data. If the string is not terminated by a newline, one is added. (default B<''>). COLSEP - prints this string between columns of data. Defaults to $PDL::IO::Misc::defcolsep. FORMAT - A printf-style format string that is cycled through column output for user controlled formatting. =for usage Usage: wcols $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; # or wcols $format_string, $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; where the $dataN args are either 1D piddles, 1D perl array refs, or 2D piddles (as might be returned from rcols() with the [] column syntax and/or using the PERLCOLS option). dim(0) of all piddles written must be the same size. The printf-style $format_string, if given, overrides any FORMAT key settings in the option hash. e.g., =for example $x = random(4); $y = ones(4); wcols $x, $y+2, 'foo.dat'; wcols $x, $y+2, *STDERR; wcols $x, $y+2, '|wc'; $a = sequence(3); $b = zeros(3); $c = random(3); wcols $a,$b,$c; # Orthogonal version of 'print $a,$b,$c' :-) wcols "%10.3f", $a,$b; # Formatted wcols "%10.3f %10.5g", $a,$b; # Individual column formatting $a = sequence(3); $b = zeros(3); $units = [ 'm/sec', 'kg', 'MPH' ]; wcols $a,$b, { HEADER => "# a b" }; wcols $a,$b, { Header => "# a b", Colsep => ', ' }; # case insensitive option names! wcols " %4.1f %4.1f %s",$a,$b,$units, { header => "# Day Time Units" }; $a52 = sequence(5,2); $b = ones(5); $c = [ 1, 2, 4 ]; wcols $a52; # now can write out 2D pdls (2 columns data in output) wcols $b, $a52, $c # ...and mix and match with 1D listrefs as well NOTES: 1. Columns are separated by whitespace by default, use C<$PDL::IO::Misc::defcolsep> to modify the default value or the COLSEP option 2. Support for the C<$PDL::IO::Misc::colsep> global value of PDL-2.4.6 and earlier is maintained but the initial value of the global is undef until you set it. The value will be then be picked up and used as if defcolsep were specified. 3. Dim 0 corresponds to the column data dimension for both rcols and wcols. This makes wcols the reverse operation of rcols. =cut *wcols = \&PDL::wcols; sub PDL::wcols { barf 'Usage: wcols($optional_format_string, 1_or_2D_pdls, *HANDLE|"filename", [\%options])' if @_<1; # handle legacy colsep variable $usecolsep = (defined $colsep) ? $colsep : $defcolsep; # if last argument is a reference to a hash, parse the options my ($format_string, $step, $fh); my $header; if ( ref( $_[-1] ) eq "HASH" ) { my $opt = pop; foreach my $key ( keys %$opt ) { if ( $key =~ /^H/i ) { $header = $opt->{$key}; } # option: HEADER elsif ( $key =~ /^COLSEP/i ) { $usecolsep = $opt->{$key}; } # option: COLSEP elsif ( $key =~ /^FORMAT/i ) { $format_string = $opt->{$key}; } # option: FORMAT else { print "Warning: wcols does not understand option <$key>.\n"; } } } if (ref(\$_[0]) eq "SCALAR" || $format_string) { $format_string = shift if (ref(\$_[0]) eq "SCALAR"); # 1st arg not piddle, explicit format string overrides option hash FORMAT $step = $format_string; $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my $file = $_[-1]; my $file_opened; my $is_handle = !UNIVERSAL::isa($file,'PDL') && !UNIVERSAL::isa($file,'ARRAY') && _is_io_handle $file; if ($is_handle) { # file handle passed directly $fh = $file; pop; } else{ if (ref(\$file) eq "SCALAR") { # Must be a file name $fh = gensym; if (!$is_handle) { $file = ">$file" unless $file =~ /^\|/ or $file =~ /^\>/; open $fh, $file or barf "File $file can not be opened for writing\n"; } pop; $file_opened = 1; } else{ # Not a filehandle or filename, assume something else # (probably piddle) and send to STDOUT $fh = *STDOUT; } } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->dim(0); my @dogp = (); # need to break 2D pdls into a their 1D pdl components for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "wcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; push @dogp, $_; } else { barf "wcols: 1D args must have same number of elements\n" if $_->dim(0) != $n or $_->getndims > 2; if ( $_->getndims == 2 ) { push @dogp, $_->dog; } else { push @dogp, $_; } } } if ( defined $header ) { $header .= "\n" unless $header =~ m/\n$/; print $fh $header; } my $i; my $pcnt = scalar @dogp; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; my $pdone = 0; for (@dogp) { push @d,_at_1D($_,$i); $pdone++; if (@d == $step) { printf $fh $format_string,@d; printf $fh $usecolsep unless $pdone==$pcnt; $#d = -1; } } if (@d && !$i) { my $str; if ($#dogp>0) { $str = ($#dogp+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { my $pdone = 0; for (@dogp) { $pdone++; print $fh _at_1D($_,$i) . ( ($pdone==$pcnt) ? '' : $usecolsep ); } } print $fh "\n"; } close($fh) if $file_opened; return 1; } =head2 swcols =for ref generate string list from C<sprintf> format specifier and a list of piddles C<swcols> takes an (optional) format specifier of the printf sort and a list of 1D piddles as input. It returns a perl array (or array reference if called in scalar context) where each element of the array is the string generated by printing the corresponding element of the piddle(s) using the format specified. If no format is specified it uses the default print format. =for usage Usage: @str = swcols format, pdl1,pdl2,pdl3,...; or $str = swcols format, pdl1,pdl2,pdl3,...; =cut *swcols = \&PDL::swcols; sub PDL::swcols{ my ($format_string,$step); my @outlist; if (ref(\$_[0]) eq "SCALAR") { $step = $format_string = shift; # 1st arg not piddle $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->nelem; for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "swcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; } else { barf "swcols: 1D args must have same number of elements\n" if $_->nelem != $n or $_->getndims!=1; } } my $i; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; for (@p) { push @d,_at_1D($_,$i); if (@d == $step) { push @outlist,sprintf $format_string,@d; $#d = -1; } } if (@d && !$i) { my $str; if ($#p>0) { $str = ($#p+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { for (@p) { push @outlist,sprintf _at_1D($_,$i),$usecolsep; } } } wantarray ? return @outlist: return \@outlist; } =head2 rgrep =for ref Read columns into piddles using full regexp pattern matching. Options: UNDEFINED: This option determines what will be done for undefined values. For instance when reading a comma-separated file of the type C<1,2,,4> where the C<,,> indicates a missing value. The default value is to assign C<$PDL::undefval> to undefined values, but if C<UNDEFINED> is set this is used instead. This would normally be set to a number, but if it is set to C<Bad> and PDL is compiled with Badvalue support (see L<PDL::Bad/>) then undefined values are set to the appropriate badvalue and the column is marked as bad. DEFTYPE: Sets the default type of the columns - see the documentation for L</rcols()> TYPES: A reference to a Perl array with types for each column - see the documentation for L</rcols()> BUFFERSIZE: The number of lines to extend the piddle by. It might speed up the reading a little bit by setting this to the number of lines in the file, but in general L</rasc()> is a better choice Usage =for usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename") e.g. =for example ($a,$b) = rgrep {/Foo (.*) Bar (.*) Mumble/} $file; i.e. the vectors C<$a> and C<$b> get the progressive values of C<$1>, C<$2> etc. =cut sub rgrep (&@) { barf 'Usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename", [{OPTIONS}])' if $#_ > 2; my (@ret,@v,$nret); my ($m,$n)=(-1,0); # Count/PDL size my $pattern = shift; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; if (ref($pattern) ne "CODE") { die "Got a ".ref($pattern)." for rgrep?!"; } # set up default options my $opt = new PDL::Options( { DEFTYPE => $deftype, TYPES => [], UNDEFINED => $PDL::undefval, BUFFERSIZE => 10000 } ); # Check if the user specified options my $u_opt = $_[1] || {}; $opt->options( $u_opt); my $options = $opt->current(); # If UNDEFINED is set to .*bad.* then undefined are set to # bad - unless we have a Perl that is not compiled with Bad support my $undef_is_bad = ($$options{UNDEFINED} =~ /bad/i); if ($undef_is_bad && !$PDL::Bad::Status) { carp "UNDEFINED cannot be set to Badvalue when PDL hasn't been compiled with Bad value support - \$PDL::undefval used instead\n"; $undef_is_bad = 0; } barf "Unknown PDL type given for DEFTYPE.\n" unless ref($$options{DEFTYPE}) eq "PDL::Type"; while(<$fh>) { next unless @v = &$pattern; $m++; # Count got if ($m==0) { $nret = $#v; # Last index of values to return # Handle various columns as in rcols - added 18/04/05 my @types = _handle_types( $nret, $$options{DEFTYPE}, $$options{TYPES} ); for (0..$nret) { # Modified 18/04/05 to use specified precision. $ret[$_] = [ PDL->zeroes($types[$_], 1), [] ]; } } else { # perhaps should only carp once... carp "Non-rectangular rgrep" if $nret != $#v; } if ($n<$m) { for (0..$nret) { _ext_lastD( $ret[$_]->[0], $$options{BUFFERSIZE} ); # Extend PDL in buffered manner } $n += $$options{BUFFERSIZE}; } for(0..$nret) { # Set values - '1*' is to ensure numeric # We now (JB - 18/04/05) also check for defined values or not # Ideally this should include Badvalue support.. if ($v[$_] eq '') { # Missing value - let us treat this specially if ($undef_is_bad) { set $ret[$_]->[0], $m, $$options{DEFTYPE}->badvalue(); # And set bad flag on $ref[$_]! $ret[$_]->[0]->badflag(1); } else { set $ret[$_]->[0], $m, $$options{UNDEFINED}; } } else { set $ret[$_]->[0], $m, 1*$v[$_]; } } } close($fh) unless $is_handle; for (@ret) { $_ = $_->[0]->slice("0:$m")->copy; }; # Truncate wantarray ? return(@ret) : return $ret[0]; } =head2 rdsa =for ref Read a FIGARO/NDF format file. Requires non-PDL DSA module. Contact Frossie (frossie@jach.hawaii.edu) Usage: =for usage ([$xaxis],$data) = rdsa($file) =for example $a = rdsa 'file.sdf' Not yet tested with PDL-1.9X versions =cut sub rdsa{PDL->rdsa(@_)} use vars qw/ $dsa_loaded /; sub PDL::rdsa { my $class = shift; barf 'Usage: ([$xaxis],$data) = rdsa($file)' if $#_!=0; my $file = shift; my $pdl = $class->new; my $xpdl; eval 'use DSA' unless $dsa_loaded++; barf 'Cannot use DSA library' if $@ ne ""; my $status = 0; # Most of this stuff stolen from Frossie: dsa_open($status); dsa_named_input('IMAGE',$file,$status); goto skip if $status != 0; dsa_get_range('IMAGE',my $vmin,my $vmax,$status); my @data_dims; dsa_data_size('IMAGE',5, my $data_ndims, \@data_dims, my $data_elements, $status); dsa_map_data('IMAGE','READ','FLOAT',my $data_address,my $data_slot, $status); @data_dims = @data_dims[0..$data_ndims-1]; print "Dims of $file = @data_dims\n" if $PDL::verbose; $pdl->set_datatype($PDL_F); $pdl->setdims([@data_dims]); my $dref = $pdl->get_dataref; mem2string($data_address,4*$data_elements,$$dref); $pdl->upd_data(); if (wantarray) { # Map X axis values my @axis_dims; dsa_axis_size('IMAGE',1,5, my $axis_ndims, \@axis_dims, my $axis_elements, $status); dsa_map_axis_data('IMAGE',1,'READ','FLOAT',my $axis_address, my $axis_slot,$status); @axis_dims = @axis_dims[0..$axis_ndims-1]; $xpdl = $class->new; $xpdl->set_datatype($PDL_F); $xpdl->setdims([@axis_dims]); my $xref = $xpdl->get_dataref; mem2string($axis_address,4*$axis_elements,$$xref); $xpdl->upd_data(); } skip: dsa_close($status); barf("rdsa: obtained DSA error") if $status != 0; return ($xpdl,$pdl); } =head2 isbigendian =for ref Determine endianness of machine - returns 0 or 1 accordingly =cut sub PDL::isbigendian { return 0; }; *isbigendian = \&PDL::isbigendian; =head2 rasc =for ref Simple function to slurp in ASCII numbers quite quickly, although error handling is marginal (to nonexistent). =for usage $pdl->rasc("filename"|FILEHANDLE [,$noElements]); Where: filename is the name of the ASCII file to read or open file handle $noElements is the optional number of elements in the file to read. (If not present, all of the file will be read to fill up $pdl). $pdl can be of type float or double (for more precision). =for example # (test.num is an ascii file with 20 numbers. One number per line.) $in = PDL->null; $num = 20; $in->rasc('test.num',20); $imm = zeroes(float,20,2); $imm->rasc('test.num'); =cut sub rasc {PDL->rasc(@_)} sub PDL::rasc { use IO::File; my ($pdl, $file, $num) = @_; $num = -1 unless defined $num; my $fi = $file; my $is_openhandle = defined fileno $fi ? 1 : 0; unless ($is_openhandle) { barf 'usage: rasc $pdl, "filename"|FILEHANDLE, [$num_to_read]' if !defined $file || ref $file; $fi = new IO::File "<$file" or barf "Can't open $file"; } $pdl->_rasc(my $ierr=null,$num,$fi); close $fi unless $is_openhandle; return all $ierr > 0; } # ---------------------------------------------------------- =head2 rcube =for ref Read list of files directly into a large data cube (for efficiency) =for usage $cube = rcube \&reader_function, @files; =for example $cube = rcube \&rfits, glob("*.fits"); This IO function allows direct reading of files into a large data cube, Obviously one could use cat() but this is more memory efficient. The reading function (e.g. rfits, readfraw) (passed as a reference) and files are the arguments. The cube is created as the same X,Y dims and datatype as the first image specified. The Z dim is simply the number of images. =cut sub rcube { my $reader = shift; barf "Usage: blah" unless ref($reader) eq "CODE"; my $k=0; my ($im,$cube,$tmp,$nx,$ny); my $nz = scalar(@_); for my $file (@_) { print "Slice ($k) - reading file $file...\n" if $PDL::verbose; $im = &$reader($file); ($nx, $ny) = dims $im; if ($k == 0) { print "Creating $nx x $ny x $nz cube...\n" if $PDL::verbose; $cube = $im->zeroes($im->type,$nx,$ny,$nz); } else { barf "Dimensions do not match for file $file!\n" if $im->getdim(0) != $nx or $im->getdim(1) != $ny ; } $tmp = $cube->slice(":,:,($k)"); $tmp .= $im; $k++; } return $cube; } *_rasc = \&PDL::_rasc; ; =head1 AUTHOR Copyright (C) Karl Glazebrook 1997, Craig DeForest 2001, 2003, and Chris Marshall 2010. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/Pnm.pm�������������������������������������������������������������������0000644�0601750�0601001�00000030266�13110402064�013706� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Pnm; @EXPORT_OK = qw( rpnm wpnm PDL::PP pnminraw PDL::PP pnminascii PDL::PP pnmout ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Pnm ; =head1 NAME PDL::IO::Pnm -- pnm format I/O for PDL =head1 SYNOPSIS use PDL::IO::Pnm; $im = wpnm $pdl, $file, $format[, $raw]; rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; =head1 DESCRIPTION pnm I/O for PDL. =cut use PDL::Core qw/howbig convert/; use PDL::Types; use PDL::Basic; # for max/min use PDL::IO::Misc; use Carp; use File::Temp qw( tempfile ); # return the upper limit of data values an integer PDL data type # can hold sub dmax { my $type = shift; my $sz = 8*howbig($type); $sz-- if ($type == $PDL_S || $type == $PDL_L); # signed types return ((1 << $sz)-1); } # output any errors that have accumulated sub show_err { my ($file,$showflag) = @_; my $err; $showflag = 1 unless defined $showflag; if (-s "$file") { open(INPUT,$file) or barf "Can't open error file"; if ($showerr) { while (<INPUT>) { print STDERR "converter: $_"; }} else { $err = join('',<INPUT>); } } close INPUT; unlink $file; return $err unless $showflag; } # barf after showing any accumulated errors sub rbarf { my $err = show_err(shift, 0); $err = '' unless defined $err; barf @_,"converter error: $err"; } # carp after showing any accumulated errors sub rcarp { show_err(shift); carp @_; } =head1 FUNCTIONS =cut =head2 pnminraw =for sig Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n; int isbin; char* fd) =for ref Read in a raw pnm file. read a raw pnm file. The C<type> argument is only there to determine the type of the operation when creating C<im> or trigger the appropriate type conversion (maybe we want a byte+ here so that C<im> follows I<strictly> the type of C<type>). =for bad pnminraw does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pnminraw = \&PDL::pnminraw; =head2 pnminascii =for sig Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n; int format; char* fd) =for ref Read in an ascii pnm file. =for bad pnminascii does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pnminascii = \&PDL::pnminascii; =head2 pnmout =for sig Signature: (a(m); int israw; int isbin; char *fd) =for ref Write a line of pnm data. This function is implemented this way so that threading works naturally. =for bad pnmout does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pnmout = \&PDL::pnmout; ; =head2 rpnm =for ref Read a pnm (portable bitmap/pixmap, pbm/ppm) file into a piddle. =for usage Usage: $im = rpnm $file; Reads a file in pnm format (ascii or raw) into a pdl (magic numbers P1-P6). Based on the input format it returns pdls with arrays of size (width,height) if binary or grey value data (pbm and pgm) or (3,width,height) if rgb data (ppm). This also means for a palette image that the distinction between an image and its lookup table is lost which can be a problem in cases (but can hardly be avoided when using netpbm/pbmplus). Datatype is dependent on the maximum grey/color-component value (for raw and binary formats always PDL_B). rpnm tries to read chopped files by zero padding the missing data (well it currently doesn't, it barfs; I'll probably fix it when it becomes a problem for me ;). You can also read directly into an existing pdl that has to have the right size(!). This can come in handy when you want to read a sequence of images into a datacube. For details about the formats see appropriate manpages that come with the netpbm/pbmplus packages. =for example $stack = zeroes(byte,3,500,300,4); rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; reads an rgb image (that had better be of size (500,300)) into the first plane of a 3D RGB datacube (=4D pdl datacube). You can also do inplace transpose/inversion that way. =cut sub rpnm {PDL->rpnm(@_)} sub PDL::rpnm { barf 'Usage: $im = rpnm($file) or $im = $pdl->rpnm($file)' if $#_<0 || $#_>2; my ($pdl,$file,$maybe) = @_; if (ref($file)) { # $file is really a pdl in this case $pdl = $file; $file = $maybe; } else { $pdl = $pdl->initialize; } my ($errfh, $efile) = tempfile(); # catch STDERR open(SAVEERR, ">&STDERR"); open(STDERR, ">$efile") || barf "Can't redirect stderr"; my $succeed = open(PNM, $file); # redirection now in effect for child # close(STDERR); open(STDERR, ">&PDL::IO::Pnm::SAVEERR"); rbarf $efile,"Can't open pnm file '$file'" unless $succeed; binmode PNM; read(PNM,(my $magic),2); rbarf $efile, "Oops, this is not a PNM file" unless $magic =~ /P[1-6]/; print "reading pnm file with magic $magic\n" if $PDL::debug>1; my ($isrgb,$israw,$params) = (0,0,3); $israw = 1 if $magic =~ /P[4-6]/; $isrgb = 1 if $magic =~ /P[3,6]/; if ($magic =~ /P[1,4]/) { # PBM data $params = 2; $dims[2] = 1; } # get the header information my ($line, $pgot, @dims) = ("",0,0,0,0); while (($pgot<$params) && ($line=<PNM>)) { $line =~ s/#.*$//; next if $line =~ /^\s*$/; # just white space while ($line !~ /^\s*$/ && $pgot < $params) { if ($line =~ /\s*(\S+)(.*)$/) { $dims[$pgot++] = $1; $line = $2; } else { rbarf $efile, "no valid header info in pnm";} } } my $type = $PDL_B; do { TYPES: { my $pdlt; foreach $pdlt ($PDL_B,$PDL_US,$PDL_L){ if ($dims[2] <= dmax($pdlt)) { $type = $pdlt; last TYPES; } } rbarf $efile, "rraw: data from ascii pnm file out of range"; } }; # the file ended prematurely rbarf $efile, "no valid header info in pnm" if $pgot < $params; rbarf $efile, "Dimensions must be > 0" if ($dims[0] <= 0) || ($dims[1] <= 0); my @Dims = @dims[0,1]; $Dims[0] *= 3 if $isrgb; if ($pdl->getndims==1 && $pdl->getdim(0)==0 && $isrgb) { #input pdl is null local $PDL::debug = 0; # shut up $pdl = $pdl->zeroes(PDL::Type->new($type),3,@dims[0,1]); } my $npdl = $isrgb ? $pdl->clump(2) : $pdl; if ($israw) { pnminraw (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $magic eq "P4", 'PDL::IO::Pnm::PNM'); } else { my $form = $1 if $magic =~ /P([1-3])/; pnminascii (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $form, 'PDL::IO::Pnm::PNM'); } print("loaded pnm file, $dims[0]x$dims[1], gmax: $dims[2]", $isrgb ? ", RGB data":"", $israw ? ", raw" : " ASCII"," data\n") if $PDL::debug; unlink($efile); # need to byte swap for little endian platforms unless ( isbigendian() ) { if ($israw ) { $pdl->bswap2 if $type==$PDL_US or $pdl->type == ushort; $pdl->bswap4 if $type==$PDL_L; # not likely, but supported anyway } } return $pdl; } =head2 wpnm =for ref Write a pnm (portable bitmap/pixmap, pbm/ppm) file into a file. =for usage Usage: $im = wpnm $pdl, $file, $format[, $raw]; Writes data in a pdl into pnm format (ascii or raw) (magic numbers P1-P6). The $format is required (normally produced by B<wpic>) and routine just checks if data is compatible with that format. All conversions should already have been done. If possible, usage of B<wpic> is preferred. Currently RAW format is chosen if compliant with range of input data. Explicit control of ASCII/RAW is possible through the optional $raw argument. If RAW is set to zero it will enforce ASCII mode. Enforcing RAW is somewhat meaningless as the routine will always try to write RAW format if the data range allows (but maybe it should reduce to a RAW supported type when RAW == 'RAW'?). For details about the formats consult appropriate manpages that come with the netpbm/pbmplus packages. =cut *wpnm = \&PDL::wpnm; sub PDL::wpnm { barf ('Usage: wpnm($pdl,$filename,$format[,$raw]) ' . 'or $pdl->wpnm($filename,$format[,$raw])') if $#_ < 2; my ($pdl,$file,$type,$raw) = @_; my ($israw,$max,$isrgb,$magic) = (0,255,0,""); # need to copy input arg since bswap[24] work inplace # might be better if the bswap calls detected if run in # void context my $swap_inplace = $pdl->is_inplace; barf "wpnm: unknown format '$type'" if $type !~ /P[P,G,B]M/; # check the data my @Dims = $pdl->dims; barf "wpnm: expecting 3D (3,w,h) input" if ($type =~ /PPM/) && (($#Dims != 2) || ($Dims[0] != 3)); barf "wpnm: expecting 2D (w,h) input" if ($type =~ /P[G,B]M/) && ($#Dims != 1); barf "wpnm: user should convert float and double data to appropriate type" if ($pdl->get_datatype == $PDL_F) || ($pdl->get_datatype == $PDL_D); barf "wpnm: expecting prescaled data" if (($pdl->get_datatype != $PDL_B) || ($pdl->get_datatype != $PDL_US)) && ($pdl->min < 0); # check for raw format $israw = 1 if (($pdl->get_datatype == $PDL_B) || ($pdl->get_datatype == $PDL_US) || ($type =~ /PBM/)); $israw = 0 if (defined($raw) && !$raw); $magic = $israw ? "P4" : "P1" if $type =~ /PBM/; $magic = $israw ? "P5" : "P2" if $type =~ /PGM/; $magic = $israw ? "P6" : "P3" if $type =~ /PPM/; $isrgb = 1 if $magic =~ /P[3,6]/; # catch STDERR and sigpipe my ($errfh, $efile) = tempfile(); local $SIG{"PIPE"} = sub { show_err($efile); die "Bad write to pipe $? $!"; }; my $pref = ($file !~ /^\s*[|>]/) ? ">" : ""; # test for plain file name open(SAVEERR, ">&STDERR"); open(STDERR, ">$efile") || barf "Can't redirect stderr"; my $succeed = open(PNM, $pref . $file); # close(STDERR); open(STDERR, ">&PDL::IO::Pnm::SAVEERR"); rbarf $efile, "Can't open pnm file" unless $succeed; binmode PNM; $max =$pdl->max; print "writing ". ($israw ? "raw" : "ascii") . "format with magic $magic\n" if $PDL::debug; # write header print PNM "$magic\n"; print PNM "$Dims[-2] $Dims[-1]\n"; if ($type !~ /PBM/) { # fix maxval for raw output formats my $outmax = 0; if ($max < 256) { $outmax = "255"; } elsif ($max < 65536) { $outmax = "65535"; } else { $outmax = $max; }; print PNM "$outmax\n" unless $type =~ /PBM/; }; # if rgb clump first two dims together my $out = ($isrgb ? $pdl->slice(':,:,-1:0')->clump(2) : $pdl->slice(':,-1:0')); # handle byte swap issues for little endian platforms unless ( isbigendian() ) { if ($israw ) { # make copy if needed $out = $out->copy unless $swap_inplace; if ( (255 < $max) and ($max < 65536)) { $out->bswap2; } elsif ($max >= 65536) { $out->bswap4; } } } pnmout($out,$israw,$type eq "PBM",'PDL::IO::Pnm::PNM'); # check if our child returned an error (in case of a pipe) if (!(close PNM)) { my $err = show_err($efile,0); barf "wpnm: pbmconverter error: $err"; } unlink($efile); } ;# Exit with OK status 1; =head1 BUGS The stderr of the converters is redirected to a file. The filename is currently generated in a probably non-portable way. A method that avoids a file (and is portable) would be preferred. C<rpnm> currently relies on the fact that the header is separated from the image data by a newline. This is not required by the p[bgp]m formats (in fact any whitespace is allowed) but most of the pnm writers seem to comply with that. Truncated files are currently treated ungracefully (C<rpnm> just barfs). =head1 AUTHOR Copyright (C) 1996,1997 Christian Soeller <c.soeller@auckland.ac.nz> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ############################## END PM CODE ################################ # Exit with OK status 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/IO/Storable.pm��������������������������������������������������������������0000644�0601750�0601001�00000022311�13110402070�014714� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Storable; @EXPORT_OK = qw( ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Storable ; =head1 NAME PDL::IO::Storable - helper functions to make PDL usable with Storable =head1 SYNOPSIS use Storable; use PDL::IO::Storable; $hash = { 'foo' => 42, 'bar' => zeroes(23,45), }; store $hash, 'perlhash.dat'; =head1 DESCRIPTION C<Storable> implements object persistence for Perl data structures that can contain arbitrary Perl objects. This module implements the relevant methods to be able to store and retrieve piddles via Storable. =head1 FUNCTIONS =cut use Carp; { package PDL; # routines to make PDL work with Storable >= 1.03 # pdlpack() serializes a piddle, while pdlunpack() unserializes it. Earlier # versions of PDL didn't control for endianness, type sizes and enumerated type # values; this made stored data unportable across different architectures and # PDL versions. This is no longer the case, but the reading code is still able # to read the old files. The old files have no meta-information in them so it's # impossible to read them correctly with 100% accuracy, but we try to make an # educated guess # # Old data format: # # int type # int ndims # int dims[ndims] # data # # Note that here all the sizes and endiannesses are the native. This is # un-portable. Furthermore, the "type" is an enum, and its values could change # between PDL versions. Here I assume that the old format input data is indeed # native, so the old data files have the same portability issues, but at least # things will remain working and broken in the same way they were before # # # New format: # # uint64 0xFFFF FFFF FFFF FFFF # meant to be different from the old-style data # char type[16] # ' '-padded, left-aligned type string such as 'PDL_LL' # uint32 sizeof(type) # little-endian # uint32 one # native-endian. Used to determine the endianness # uint64 ndims # little-endian # uint64 dims[ndims] # little-endian # data # # The header data is all little-endian here. The data is stored with native # endianness. On load it is checked, and a swap happens, if it is required sub pdlpack { my ($pdl) = @_; my $hdr = pack( 'c8A16VL', (-1) x 8, $pdl->type->symbol, PDL::Core::howbig( $pdl->get_datatype ), 1 ); # I'd like this to be simply # my $dimhdr = pack( 'Q<*', $pdl->getndims, $pdl->dims ) # but my pack() may not support Q, so I break it up manually # # if sizeof(int) == 4 here, then $_>>32 will not return 0 necessarily (this in # undefined). I thus manually make sure this is the case # my $noMSW = (PDL::Core::howbig($PDL::Types::PDL_IND) < 8) ? 1 : 0; my $dimhdr = pack( 'V*', map( { $_ & 0xFFFFFFFF, $noMSW ? 0 : ($_ >> 32) } ($pdl->getndims, $pdl->dims ) ) ); my $dref = $pdl->get_dataref; return $hdr . $dimhdr . $$dref; } sub pdlunpack { use Config (); my ($pdl,$pack) = @_; my ($type, $ndims); my @dims = (); my $do_swap = 0; # first I try to infer the type of this storable my $offset = 0; my @magicheader = unpack( "ll", substr( $pack, $offset ) ); $offset += 8; if( $magicheader[0] != -1 || $magicheader[1] != -1 ) { print "PDL::IO::Storable detected an old-style pdl\n" if $PDL::verbose; # old-style data. I leave the data sizes, endianness native, since I don't # know any better. This at least won't break anything. # # The "type" however needs attention. Most-recent old-format data had these # values for the type: # # enum { byte, # short, # unsigned short, # long, # long long, # float, # double } # # The $type I read from the file is assumed to be in this enum even though # PDL may have added other types in the middle of this enum. my @reftypes = ($PDL::Types::PDL_B, $PDL::Types::PDL_S, $PDL::Types::PDL_U, $PDL::Types::PDL_L, $PDL::Types::PDL_LL, $PDL::Types::PDL_F, $PDL::Types::PDL_D); my $stride = $Config::Config{intsize}; ($type,$ndims) = unpack 'i2', $pack; @dims = $ndims > 0 ? unpack 'i*', substr $pack, 2*$stride, $ndims*$stride : (); $offset = (2+$ndims)*$stride; if( $type < 0 || $type >= @reftypes ) { croak "Reading in old-style pdl with unknown type: $type. Giving up."; } $type = $reftypes[$type]; } else { print "PDL::IO::Storable detected a new-style pdl\n" if $PDL::verbose; # new-style data. I KNOW the data sizes, endianness and the type enum my ($typestring) = unpack( 'A16', substr( $pack, $offset ) ); $offset += 16; $type = eval( '$PDL::Types::' . $typestring ); if( $@ ) { croak "PDL::IO::Storable couldn't parse type string '$typestring'. Giving up"; } my ($sizeof) = unpack( 'V', substr( $pack, $offset ) ); $offset += 4; if( $sizeof != PDL::Core::howbig( $type ) ) { croak "PDL::IO::Storable sees mismatched data type sizes when reading data of type '$typestring'\n" . "Stored data has sizeof = $sizeof, while here it is " . PDL::Core::howbig( $type ) . ".\n" . "Giving up"; } # check the endianness, if the "1" I read is interpreted as "1" on my # machine then the endiannesses match, and I can just read the data my ($one) = unpack( 'L', substr( $pack, $offset ) ); $offset += 4; if( $one == 1 ) { print "PDL::IO::Storable detected matching endianness\n" if $PDL::verbose; } else { print "PDL::IO::Storable detected non-matching endianness. Correcting data on load\n" if $PDL::verbose; # mismatched endianness. Let's make sure it's a big/little issue, not # something weird. If mismatched, the '00000001' should be seen as # '01000000' if( $one != 0x01000000 ) { croak "PDL::IO::Storable sees confused endianness. A '1' was read as '$one'.\n" . "This is neither matching nor swapped endianness. I don't know what's going on,\n" . "so I'm giving up." } # all righty. Everything's fine, but I need to swap all the data $do_swap = 1; } # mostly this acts like unpack('Q<'...), but works even if my unpack() # doesn't support 'Q'. This also makes sure that my PDL_Indx is large enough # to read this piddle sub unpack64bit { my ($count, $pack, $offset) = @_; return map { my ($lsw, $msw) = unpack('VV', substr($$pack, $$offset)); $$offset += 8; croak( "PDL::IO::Storable tried reading a file with dimensions that don't fit into 32 bits.\n" . "However here PDL_Indx can't store a number so large. Giving up." ) if( PDL::Core::howbig($PDL::Types::PDL_IND) < 8 && $msw != 0 ); (($msw << 32) | $lsw) } (1..$count); } ($ndims) = unpack64bit( 1, \$pack, \$offset ); @dims = unpack64bit( $ndims, \$pack, \$offset ) if $ndims > 0; } print "thawing PDL, Dims: [",join(',',@dims),"]\n" if $PDL::verbose; $pdl->make_null; # make this a real piddle -- this is the tricky bit! $pdl->set_datatype($type); $pdl->setdims([@dims]); my $dref = $pdl->get_dataref; $$dref = substr $pack, $offset; if( $do_swap && PDL::Core::howbig( $type ) != 1 ) { swapEndian( $$dref, PDL::Core::howbig( $type ) ); } $pdl->upd_data; return $pdl; } sub STORABLE_freeze { my ($self, $cloning) = @_; # return if $cloning; # Regular default serialization return UNIVERSAL::isa($self, "HASH") ? ("",{%$self}) # hash ref -> Storable : (pdlpack $self); # pack the piddle into a long string } sub STORABLE_thaw { my ($pdl,$cloning,$serial,$hashref) = @_; # print "in STORABLE_thaw\n"; # return if $cloning; my $class = ref $pdl; if (defined $hashref) { croak "serial data with hashref!" unless !defined $serial || $serial eq ""; for (keys %$hashref) { $pdl->{$_} = $hashref->{$_} } } else { # all the magic is happening in pdlunpack $pdl->pdlunpack($serial); # unpack our serial into this sv } } # have these as PDL methods =head2 store =for ref store a piddle using L<Storable|Storable> =for example $a = random 12,10; $a->store('myfile'); =cut =head2 freeze =for ref freeze a piddle using L<Storable|Storable> =for example $a = random 12,10; $frozen = $a->freeze; =cut sub store { require Storable; Storable::store(@_) } sub freeze { require Storable; Storable::freeze(@_) } } =head1 AUTHOR Copyright (C) 2013 Dima Kogan <dima@secretsauce.net> Copyright (C) 2002 Christian Soeller <c.soeller@auckland.ac.nz> All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ; # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Math.pm���������������������������������������������������������������������0000644�0601750�0601001�00000026434�13110402057�013542� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Math; @EXPORT_OK = qw( PDL::PP acos PDL::PP asin PDL::PP atan PDL::PP cosh PDL::PP sinh PDL::PP tan PDL::PP tanh PDL::PP ceil PDL::PP floor PDL::PP rint PDL::PP pow PDL::PP acosh PDL::PP asinh PDL::PP atanh PDL::PP erf PDL::PP erfc PDL::PP bessj0 PDL::PP bessj1 PDL::PP bessy0 PDL::PP bessy1 PDL::PP bessjn PDL::PP bessyn PDL::PP lgamma PDL::PP badmask PDL::PP isfinite PDL::PP erfi PDL::PP ndtri PDL::PP polyroots ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Math ; =head1 NAME PDL::Math - extended mathematical operations and special functions =head1 SYNOPSIS use PDL::Math; use PDL::Graphics::TriD; imag3d [SURF2D,bessj0(rvals(zeroes(50,50))/2)]; =head1 DESCRIPTION This module extends PDL with more advanced mathematical functions than provided by standard Perl. All the functions have one input pdl, and one output, unless otherwise stated. Many of the functions are linked from the system maths library or the Cephes maths library (determined when PDL is compiled); a few are implemented entirely in PDL. =cut ### Kludge for backwards compatibility with older scripts ### This should be deleted at some point later than 21-Nov-2003. BEGIN {use PDL::MatrixOps;} =head1 FUNCTIONS =cut =head2 acos =for sig Signature: (a(); [o]b()) =for ref The usual trigonometric function. Works inplace. =for bad acos processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *acos = \&PDL::acos; =head2 asin =for sig Signature: (a(); [o]b()) =for ref The usual trigonometric function. Works inplace. =for bad asin processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *asin = \&PDL::asin; =head2 atan =for sig Signature: (a(); [o]b()) =for ref The usual trigonometric function. Works inplace. =for bad atan processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *atan = \&PDL::atan; =head2 cosh =for sig Signature: (a(); [o]b()) =for ref The standard hyperbolic function. Works inplace. =for bad cosh processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cosh = \&PDL::cosh; =head2 sinh =for sig Signature: (a(); [o]b()) =for ref The standard hyperbolic function. Works inplace. =for bad sinh processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sinh = \&PDL::sinh; =head2 tan =for sig Signature: (a(); [o]b()) =for ref The usual trigonometric function. Works inplace. =for bad tan processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *tan = \&PDL::tan; =head2 tanh =for sig Signature: (a(); [o]b()) =for ref The standard hyperbolic function. Works inplace. =for bad tanh processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *tanh = \&PDL::tanh; =head2 ceil =for sig Signature: (a(); [o]b()) =for ref Round to integer values in floating-point format. Works inplace. =for bad ceil processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ceil = \&PDL::ceil; =head2 floor =for sig Signature: (a(); [o]b()) =for ref Round to integer values in floating-point format. Works inplace. =for bad floor processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *floor = \&PDL::floor; =head2 rint =for sig Signature: (a(); [o]b()) =for ref Round to integer values in floating-point format. =for method rint uses the 'round half to even' rounding method (also known as banker's rounding). Half-integers are rounded to the nearest even number. This avoids a slight statistical bias inherent in always rounding half-integers up or away from zero. If you are looking to round half-integers up (regardless of sign), try C<floor($x+0.5)>. If you want to round half-integers away from zero, try C<< floor(abs($x)+0.5)*($x<=>0) >>. Works inplace. =for bad rint processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rint = \&PDL::rint; =head2 pow =for sig Signature: (a(); b(); [o]c()) =for ref Synonym for `**'. Works inplace. =for bad pow processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pow = \&PDL::pow; =head2 acosh =for sig Signature: (a(); [o]b()) =for ref The standard hyperbolic function. Works inplace. =for bad acosh processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *acosh = \&PDL::acosh; =head2 asinh =for sig Signature: (a(); [o]b()) =for ref The standard hyperbolic function. Works inplace. =for bad asinh processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *asinh = \&PDL::asinh; =head2 atanh =for sig Signature: (a(); [o]b()) =for ref The standard hyperbolic function. Works inplace. =for bad atanh processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *atanh = \&PDL::atanh; =head2 erf =for sig Signature: (a(); [o]b()) =for ref The error function. Works inplace. =for bad erf processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *erf = \&PDL::erf; =head2 erfc =for sig Signature: (a(); [o]b()) =for ref The complement of the error function. Works inplace. =for bad erfc processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *erfc = \&PDL::erfc; =head2 bessj0 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the first kind, J_n Works inplace. =for bad bessj0 processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bessj0 = \&PDL::bessj0; =head2 bessj1 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the first kind, J_n Works inplace. =for bad bessj1 processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bessj1 = \&PDL::bessj1; =head2 bessy0 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the second kind, Y_n. Works inplace. =for bad bessy0 processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bessy0 = \&PDL::bessy0; =head2 bessy1 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the second kind, Y_n. Works inplace. =for bad bessy1 processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bessy1 = \&PDL::bessy1; =head2 bessjn =for sig Signature: (a(); int n(); [o]b()) =for ref The regular Bessel function of the first kind, J_n . This takes a second int argument which gives the order of the function required. Works inplace. =for bad bessjn processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bessjn = \&PDL::bessjn; =head2 bessyn =for sig Signature: (a(); int n(); [o]b()) =for ref The regular Bessel function of the first kind, Y_n . This takes a second int argument which gives the order of the function required. Works inplace. =for bad bessyn processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bessyn = \&PDL::bessyn; =head2 lgamma =for sig Signature: (a(); [o]b(); int[o]s()) =for ref log gamma function This returns 2 piddles -- the first set gives the log(gamma) values, while the second set, of integer values, gives the sign of the gamma function. This is useful for determining factorials, amongst other things. =for bad lgamma processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lgamma = \&PDL::lgamma; =head2 badmask =for sig Signature: (a(); b(); [o]c()) =for ref Clears all C<infs> and C<nans> in C<$a> to the corresponding value in C<$b>. badmask can be run with C<$a> inplace: badmask($a->inplace,0); $a->inplace->badmask(0); =for bad If bad values are present, these are also cleared. =cut *badmask = \&PDL::badmask; =head2 isfinite =for sig Signature: (a(); int [o]mask()) =for ref Sets C<$mask> true if C<$a> is not a C<NaN> or C<inf> (either positive or negative). Works inplace. =for bad Bad values are treated as C<NaN> or C<inf>. =cut *isfinite = \&PDL::isfinite; =head2 erfi =for sig Signature: (a(); [o]b()) =for ref The inverse of the error function. Works inplace. =for bad erfi processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *erfi = \&PDL::erfi; =head2 ndtri =for sig Signature: (a(); [o]b()) =for ref The value for which the area under the Gaussian probability density function (integrated from minus infinity) is equal to the argument (cf L<erfi|/erfi>). Works inplace. =for bad ndtri processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ndtri = \&PDL::ndtri; =head2 polyroots =for sig Signature: (cr(n); ci(n); [o]rr(m); [o]ri(m)) =for ref Complex roots of a complex polynomial, given coefficients in order of decreasing powers. =for usage ($rr, $ri) = polyroots($cr, $ci); =for bad polyroots does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *polyroots = \&PDL::polyroots; ; =head1 BUGS Hasn't been tested on all platforms to ensure Cephes versions are picked up automatically and used correctly. =head1 AUTHOR Copyright (C) R.J.R. Williams 1997 (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au) and Tuomas J. Lukka (Tuomas.Lukka@helsinki.fi). Portions (C) Craig DeForest 2002 (deforest@boulder.swri.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the PDL copyright notice should be included in the file. =cut # Exit with OK status 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/MatrixOps.pm����������������������������������������������������������������0000644�0601750�0601001�00000111177�13110402057�014576� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::MatrixOps; @EXPORT_OK = qw( identity stretcher inv det determinant PDL::PP eigens_sym PDL::PP eigens PDL::PP svd lu_decomp lu_decomp2 lu_backsub PDL::PP simq PDL::PP squaretotri ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::MatrixOps ; =head1 NAME PDL::MatrixOps -- Some Useful Matrix Operations =head1 SYNOPSIS $inv = $a->inv; $det = $a->det; ($lu,$perm,$par) = $a->lu_decomp; $x = lu_backsub($lu,$perm,$b); # solve $a x $x = $b =head1 DESCRIPTION PDL::MatrixOps is PDL's built-in matrix manipulation code. It contains utilities for many common matrix operations: inversion, determinant finding, eigenvalue/vector finding, singular value decomposition, etc. PDL::MatrixOps routines are written in a mixture of Perl and C, so that they are reliably present even when there is no FORTRAN compiler or external library available (e.g. L<PDL::Slatec|PDL::Slatec> or any of the PDL::GSL family of modules). Matrix manipulation, particularly with large matrices, is a challenging field and no one algorithm is suitable in all cases. The utilities here use general-purpose algorithms that work acceptably for many cases but might not scale well to very large or pathological (near-singular) matrices. Except as noted, the matrices are PDLs whose 0th dimension ranges over column and whose 1st dimension ranges over row. The matrices appear correctly when printed. These routines should work OK with L<PDL::Matrix|PDL::Matrix> objects as well as with normal PDLs. =head1 TIPS ON MATRIX OPERATIONS Like most computer languages, PDL addresses matrices in (column,row) order in most cases; this corresponds to (X,Y) coordinates in the matrix itself, counting rightwards and downwards from the upper left corner. This means that if you print a PDL that contains a matrix, the matrix appears correctly on the screen, but if you index a matrix element, you use the indices in the reverse order that you would in a math textbook. If you prefer your matrices indexed in (row, column) order, you can try using the L<PDL::Matrix|PDL::Matrix> object, which includes an implicit exchange of the first two dimensions but should be compatible with most of these matrix operations. TIMTOWDTI.) Matrices, row vectors, and column vectors can be multiplied with the 'x' operator (which is, of course, threadable): $m3 = $m1 x $m2; $col_vec2 = $m1 x $col_vec1; $row_vec2 = $row_vec1 x $m1; $scalar = $row_vec x $col_vec; Because of the (column,row) addressing order, 1-D PDLs are treated as _row_ vectors; if you want a _column_ vector you must add a dummy dimension: $rowvec = pdl(1,2); # row vector $colvec = $rowvec->(*1); # 1x2 column vector $matrix = pdl([[3,4],[6,2]]); # 2x2 matrix $rowvec2 = $rowvec x $matrix; # right-multiplication by matrix $colvec = $matrix x $colvec; # left-multiplication by matrix $m2 = $matrix x $rowvec; # Throws an error Implicit threading works correctly with most matrix operations, but you must be extra careful that you understand the dimensionality. In particular, matrix multiplication and other matrix ops need nx1 PDLs as row vectors and 1xn PDLs as column vectors. In most cases you must explicitly include the trailing 'x1' dimension in order to get the expected results when you thread over multiple row vectors. When threading over matrices, it's very easy to get confused about which dimension goes where. It is useful to include comments with every expression, explaining what you think each dimension means: $a = xvals(360)*3.14159/180; # (angle) $rot = cat(cat(cos($a),sin($a)), # rotmat: (col,row,angle) cat(-sin($a),cos($a))); =head1 ACKNOWLEDGEMENTS MatrixOps includes algorithms and pre-existing code from several origins. In particular, C<eigens_sym> is the work of Stephen Moshier, C<svd> uses an SVD subroutine written by Bryant Marks, and C<eigens> uses a subset of the Small Scientific Library by Kenneth Geisshirt. They are free software, distributable under same terms as PDL itself. =head1 NOTES This is intended as a general-purpose linear algebra package for small-to-mid sized matrices. The algorithms may not scale well to large matrices (hundreds by hundreds) or to near singular matrices. If there is something you want that is not here, please add and document it! =cut use Carp; use PDL::NiceSlice; use strict; =head1 FUNCTIONS =cut =head2 identity =for sig Signature: (n; [o]a(n,n)) =for ref Return an identity matrix of the specified size. If you hand in a scalar, its value is the size of the identity matrix; if you hand in a dimensioned PDL, the 0th dimension is the size of the matrix. =cut sub identity { my $n = shift; my $out = ((UNIVERSAL::isa($n,'PDL')) ? ( ($n->getndims > 0) ? zeroes($n->dim(0),$n->dim(0)) : zeroes($n->at(0),$n->at(0)) ) : zeroes($n,$n) ); my $tmp; # work around perl -d "feature" ($tmp = $out->diagonal(0,1))++; $out; } =head2 stretcher =for sig Signature: (a(n); [o]b(n,n)) =for usage $mat = stretcher($eigenvalues); =for ref Return a diagonal matrix with the specified diagonal elements =cut sub stretcher { my $in = shift; my $out = zeroes($in->dim(0),$in->dims); my $tmp; # work around for perl -d "feature" ($tmp = $out->diagonal(0,1)) += $in; $out; } =head2 inv =for sig Signature: (a(m,m); sv opt ) =for usage $a1 = inv($a, {$opt}); =for ref Invert a square matrix. You feed in an NxN matrix in $a, and get back its inverse (if it exists). The code is inplace-aware, so you can get back the inverse in $a itself if you want -- though temporary storage is used either way. You can cache the LU decomposition in an output option variable. C<inv> uses C<lu_decomp> by default; that is a numerically stable (pivoting) LU decomposition method. OPTIONS: =over 3 =item * s Boolean value indicating whether to complain if the matrix is singular. If this is false, singular matrices cause inverse to barf. If it is true, then singular matrices cause inverse to return undef. =item * lu (I/O) This value contains a list ref with the LU decomposition, permutation, and parity values for C<$a>. If you do not mention the key, or if the value is undef, then inverse calls C<lu_decomp>. If the key exists with an undef value, then the output of C<lu_decomp> is stashed here (unless the matrix is singular). If the value exists, then it is assumed to hold the LU decomposition. =item * det (Output) If this key exists, then the determinant of C<$a> get stored here, whether or not the matrix is singular. =back =cut *PDL::inv = \&inv; sub inv { my $a = shift; my $opt = shift; $opt = {} unless defined($opt); barf "inverse needs a square PDL as a matrix\n" unless(UNIVERSAL::isa($a,'PDL') && $a->dims >= 2 && $a->dim(0) == $a->dim(1) ); my ($lu,$perm,$par); if(exists($opt->{lu}) && ref $opt->{lu} eq 'ARRAY' && ref $opt->{lu}->[0] eq 'PDL') { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($a); @{$opt->{lu}} = ($lu,$perm,$par) if(ref $opt->{lu} eq 'ARRAY'); } my $det = (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : pdl(0); $opt->{det} = $det if exists($opt->{det}); unless($det->nelem > 1 || $det) { return undef if $opt->{s}; barf("PDL::inv: got a singular matrix or LU decomposition\n"); } my $idenA = $a->zeros; $idenA->diagonal(0,1) .= 1; my $out = lu_backsub($lu,$perm,$par,$idenA)->xchg(0,1)->sever; return $out unless($a->is_inplace); $a .= $out; $a; } =head2 det =for sig Signature: (a(m,m); sv opt) =for usage $det = det($a,{opt}); =for ref Determinant of a square matrix using LU decomposition (for large matrices) You feed in a square matrix, you get back the determinant. Some options exist that allow you to cache the LU decomposition of the matrix (note that the LU decomposition is invalid if the determinant is zero!). The LU decomposition is cacheable, in case you want to re-use it. This method of determinant finding is more rapid than recursive-descent on large matrices, and if you reuse the LU decomposition it's essentially free. OPTIONS: =over 3 =item * lu (I/O) Provides a cache for the LU decomposition of the matrix. If you provide the key but leave the value undefined, then the LU decomposition goes in here; if you put an LU decomposition here, it will be used and the matrix will not be decomposed again. =back =cut *PDL::det = \&det; sub det { my($a) = shift; my($opt) = shift; $opt = {} unless defined($opt); my($lu,$perm,$par); if(exists ($opt->{u}) and (ref $opt->{lu} eq 'ARRAY')) { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($a); $opt->{lu} = [$lu,$perm,$par] if(exists($opt->{lu})); } ( (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : 0 ); } =head2 determinant =for sig Signature: (a(m,m)) =for usage $det = determinant($a); =for ref Determinant of a square matrix, using recursive descent (threadable). This is the traditional, robust recursive determinant method taught in most linear algebra courses. It scales like C<O(n!)> (and hence is pitifully slow for large matrices) but is very robust because no division is involved (hence no division-by-zero errors for singular matrices). It's also threadable, so you can find the determinants of a large collection of matrices all at once if you want. Matrices up to 3x3 are handled by direct multiplication; larger matrices are handled by recursive descent to the 3x3 case. The LU-decomposition method L<det|det> is faster in isolation for single matrices larger than about 4x4, and is much faster if you end up reusing the LU decomposition of C<$a> (NOTE: check performance and threading benchmarks with new code). =cut *PDL::determinant = \&determinant; sub determinant { my($a) = shift; my($n); return undef unless( UNIVERSAL::isa($a,'PDL') && $a->getndims >= 2 && ($n = $a->dim(0)) == $a->dim(1) ); return $a->clump(2) if($n==1); if($n==2) { my($b) = $a->clump(2); return $b->index(0)*$b->index(3) - $b->index(1)*$b->index(2); } if($n==3) { my($b) = $a->clump(2); my $b3 = $b->index(3); my $b4 = $b->index(4); my $b5 = $b->index(5); my $b6 = $b->index(6); my $b7 = $b->index(7); my $b8 = $b->index(8); return ( $b->index(0) * ( $b4 * $b8 - $b5 * $b7 ) + $b->index(1) * ( $b5 * $b6 - $b3 * $b8 ) + $b->index(2) * ( $b3 * $b7 - $b4 * $b6 ) ); } my($i); my($sum) = zeroes($a->((0),(0))); # Do middle submatrices for $i(1..$n-2) { my $el = $a->(($i),(0)); next if( ($el==0)->all ); # Optimize away unnecessary recursion $sum += $el * (1-2*($i%2)) * determinant( $a->(0:$i-1,1:-1)-> append($a->($i+1:-1,1:-1))); } # Do beginning and end submatrices $sum += $a->((0),(0)) * determinant($a->(1:-1,1:-1)); $sum -= $a->((-1),(0)) * determinant($a->(0:-2,1:-1)) * (1 - 2*($n % 2)); return $sum; } =head2 eigens_sym =for sig Signature: ([phys]a(m); [o,phys]ev(n,n); [o,phys]e(n)) =for ref Eigenvalues and -vectors of a symmetric square matrix. If passed an asymmetric matrix, the routine will warn and symmetrize it, by taking the average value. That is, it will solve for 0.5*($a+$a->mv(0,1)). It's threadable, so if C<$a> is 3x3x100, it's treated as 100 separate 3x3 matrices, and both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context it hands back only the eigenvalues. Ultimately, it should switch to a faster algorithm in this case (as discarding the eigenvectors is wasteful). The algorithm used is due to J. vonNeumann, which was a rediscovery of L<Jacobi's Method|http://en.wikipedia.org/wiki/Jacobi_eigenvalue_algorithm> . The eigenvectors are returned in COLUMNS of the returned PDL. That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens_sym $a; # Make eigenvector matrix $vector = $ev->($n); # Select nth eigenvector as a column-vector $vector = $ev->(($n)); # Select nth eigenvector as a row-vector =for usage ($ev, $e) = eigens_sym($a); # e-vects & e-values $e = eigens_sym($a); # just eigenvalues =for bad eigens_sym ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::eigens_sym { my ($a) = @_; my (@d) = $a->dims; barf "Need real square matrix for eigens_sym" if $#d < 1 or $d[0] != $d[1]; my ($n) = $d[0]; my ($sym) = 0.5*($a + $a->mv(0,1)); my ($err) = PDL::max(abs($sym)); barf "Need symmetric component non-zero for eigens_sym" if $err == 0; $err = PDL::max(abs($a-$sym))/$err; warn "Using symmetrized version of the matrix in eigens_sym" if $err > 1e-5 && $PDL::debug; ## Get lower diagonal form ## Use whichND/indexND because whereND doesn't exist (yet?) and ## the combo is threadable (unlike where). Note that for historical ## reasons whichND needs a scalar() around it to give back a ## nice 2xn PDL index. my $lt = PDL::indexND($sym, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($sym->dims); my $e = PDL->zeroes($sym->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->xchg(0,1), $e if(wantarray); $e; #just eigenvalues } *eigens_sym = \&PDL::eigens_sym; =head2 eigens =for sig Signature: ([phys]a(m); [o,phys]ev(l,n,n); [o,phys]e(l,n)) =for ref Real eigenvalues and -vectors of a real square matrix. (See also L<"eigens_sym"|/eigens_sym>, for eigenvalues and -vectors of a real, symmetric, square matrix). The eigens function will attempt to compute the eigenvalues and eigenvectors of a square matrix with real components. If the matrix is symmetric, the same underlying code as L<"eigens_sym"|/eigens_sym> is used. If asymmetric, the eigenvalues and eigenvectors are computed with algorithms from the sslib library. If any imaginary components exist in the eigenvalues, the results are currently considered to be invalid, and such eigenvalues are returned as "NaN"s. This is true for eigenvectors also. That is if there are imaginary components to any of the values in the eigenvector, the eigenvalue and corresponding eigenvectors are all set to "NaN". Finally, if there are any repeated eigenvectors, they are replaced with all "NaN"s. Use of the eigens function on asymmetric matrices should be considered experimental! For asymmetric matrices, nearly all observed matrices with real eigenvalues produce incorrect results, due to errors of the sslib algorithm. If your assymmetric matrix returns all NaNs, do not assume that the values are complex. Also, problems with memory access is known in this library. Not all square matrices are diagonalizable. If you feed in a non-diagonalizable matrix, then one or more of the eigenvectors will be set to NaN, along with the corresponding eigenvalues. C<eigens> is threadable, so you can solve 100 eigenproblems by feeding in a 3x3x100 array. Both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context C<eigens> hands back only the eigenvalues. This is somewhat wasteful, as it calculates the eigenvectors anyway. The eigenvectors are returned in COLUMNS of the returned PDL (ie the the 0 dimension). That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens $a; # Make eigenvector matrix $vector = $ev->($n); # Select nth eigenvector as a column-vector $vector = $ev->(($n)); # Select nth eigenvector as a row-vector DEVEL NOTES: For now, there is no distinction between a complex eigenvalue and an invalid eigenvalue, although the underlying code generates complex numbers. It might be useful to be able to return complex eigenvalues. =for usage ($ev, $e) = eigens($a); # e'vects & e'vals $e = eigens($a); # just eigenvalues =for bad eigens ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::eigens { my ($a) = @_; my (@d) = $a->dims; my $n = $d[0]; barf "Need real square matrix for eigens" if $#d < 1 or $d[0] != $d[1]; my $deviation = PDL::max(abs($a - $a->mv(0,1)))/PDL::max(abs($a)); if ( $deviation <= 1e-5 ) { #taken from eigens_sym code my $lt = PDL::indexND($a, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($a->dims); my $e = PDL->zeroes($a->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->xchg(0,1), $e if wantarray; return $e; #just eigenvalues } else { if($PDL::verbose || $PDL::debug) { print "eigens: using the asymmetric case from SSL\n"; } if( !$PDL::eigens_bug_ack && !$ENV{PDL_EIGENS_ACK} ) { print STDERR "WARNING: using sketchy algorithm for PDL::eigens asymmetric case -- you might\n". " miss an eigenvector or two\nThis should be fixed in PDL v2.5 (due 2009), \n". " or you might fix it yourself (hint hint). You can shut off this warning\n". " by setting the variable $PDL::eigens_bug_ack, or the environment variable\n". " PDL_EIGENS_HACK prior to calling eigens() with a non-symmetric matrix.\n"; $PDL::eigens_bug_ack = 1; } my $ev = PDL->zeroes(2, $a->dims); my $e = PDL->zeroes(2, $a->index(0)->dims); &PDL::_eigens_int($a->clump(0,1), $ev, $e); return $ev->index(0)->xchg(0,1)->sever, $e->index(0)->sever if(wantarray); return $e->index(0)->sever; #just eigenvalues } } *eigens = \&PDL::eigens; =head2 svd =for sig Signature: (a(n,m); [o]u(n,m); [o,phys]z(n); [o]v(n,n)) =for usage ($u, $s, $v) = svd($a); =for ref Singular value decomposition of a matrix. C<svd> is threadable. Given an m x n matrix C<$a> that has m rows and n columns (m >= n), C<svd> computes matrices C<$u> and C<$v>, and a vector of the singular values C<$s>. Like most implementations, C<svd> computes what is commonly referred to as the "thin SVD" of C<$a>, such that C<$u> is m x n, C<$v> is n x n, and there are <=n singular values. As long as m >= n, the original matrix can be reconstructed as follows: ($u,$s,$v) = svd($a); $ess = zeroes($a->dim(0),$a->dim(0)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$a->dim(0)-1); #generic diagonal $a_copy = $u x $ess x $v->transpose; If m==n, C<$u> and C<$v> can be thought of as rotation matrices that convert from the original matrix's singular coordinates to final coordinates, and from original coordinates to singular coordinates, respectively, and $ess is a diagonal scaling matrix. If n>m, C<svd> will barf. This can be avoided by passing in the transpose of C<$a>, and reconstructing the original matrix like so: ($u,$s,$v) = svd($a->transpose); $ess = zeroes($a->dim(1),$a->dim(1)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$a->dim(1)-1); #generic diagonal $a_copy = $v x $ess x $u->transpose; EXAMPLE The computing literature has loads of examples of how to use SVD. Here's a trivial example (used in L<PDL::Transform::map|PDL::Transform/map>) of how to make a matrix less, er, singular, without changing the orientation of the ellipsoid of transformation: { my($r1,$s,$r2) = svd $a; $s++; # fatten all singular values $r2 *= $s; # implicit threading for cheap mult. $a .= $r2 x $r1; # a gets r2 x ess x r1 } =for bad svd ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *svd = \&PDL::svd; =head2 lu_decomp =for sig Signature: (a(m,m); [o]lu(m,m); [o]perm(m); [o]parity) =for ref LU decompose a matrix, with row permutation =for usage ($lu, $perm, $parity) = lu_decomp($a); $lu = lu_decomp($a, $perm, $par); # $perm and $par are outputs! lu_decomp($a->inplace,$perm,$par); # Everything in place. =for description C<lu_decomp> returns an LU decomposition of a square matrix, using Crout's method with partial pivoting. It's ported from I<Numerical Recipes>. The partial pivoting keeps it numerically stable but means a little more overhead from threading. C<lu_decomp> decomposes the input matrix into matrices L and U such that LU = A, L is a subdiagonal matrix, and U is a superdiagonal matrix. By convention, the diagonal of L is all 1's. The single output matrix contains all the variable elements of both the L and U matrices, stacked together. Because the method uses pivoting (rearranging the lower part of the matrix for better numerical stability), you have to permute input vectors before applying the L and U matrices. The permutation is returned either in the second argument or, in list context, as the second element of the list. You need the permutation for the output to make any sense, so be sure to get it one way or the other. LU decomposition is the answer to a lot of matrix questions, including inversion and determinant-finding, and C<lu_decomp> is used by L<inv|/inv>. If you pass in C<$perm> and C<$parity>, they either must be predeclared PDLs of the correct size ($perm is an n-vector, C<$parity> is a scalar) or scalars. If the matrix is singular, then the LU decomposition might not be defined; in those cases, C<lu_decomp> silently returns undef. Some singular matrices LU-decompose just fine, and those are handled OK but give a zero determinant (and hence can't be inverted). C<lu_decomp> uses pivoting, which rearranges the values in the matrix for more numerical stability. This makes it really good for large and even near-singular matrices. There is a non-pivoting version C<lu_decomp2> available which is from 5 to 60 percent faster for typical problems at the expense of failing to compute a result in some cases. Now that the C<lu_decomp> is threaded, it is the recommended LU decomposition routine. It no longer falls back to C<lu_decomp2>. C<lu_decomp> is ported from I<Numerical Recipes> to PDL. It should probably be implemented in C. =cut *PDL::lu_decomp = \&lu_decomp; sub lu_decomp { my($in) = shift; my($permute) = shift; my($parity) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $permute) { barf('lu_decomp: permutation vector must match the matrix') if(!UNIVERSAL::isa($permute,'PDL') || $permute->ndims != 1 || $permute->dim(0) != $out->dim(0)); $permute .= PDL->xvals($in->dim(0)); } else { $permute = $in->((0))->xvals; } if(defined $parity) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($parity,'PDL') || $parity->dim(0) != 1); $parity .= 1.0; } else { $parity = $in->((0),(0))->ones; } my($scales) = $in->abs->maximum; # elementwise by rows if(($scales==0)->sum) { return undef; } # Some holding tanks my($tmprow) = $out->((0))->double->zeroes; my($tmpval) = $tmprow->((0))->sever; my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->(($col),0:$klim) * $out->(0:$klim,($row)) )->sumover; } } # Figure a_ij, with pivoting if($col < $n1) { # Find the maximum value in the rest of the row my $sl = $out->(($col),$col:$n1); my $wh = $sl->abs->maximum_ind; my $big = $sl->index($wh)->sever; # Permute if necessary to make the diagonal the maximum # if($wh != 0) { # Permute rows to place maximum element on diagonal. my $whc = $wh+$col; # my $sl1 = $out->(:,($whc)); my $sl1 = $out->mv(1,0)->index($whc(*$n)); my $sl2 = $out->(:,($col)); $tmprow .= $sl1; $sl1 .= $sl2; $sl2 .= $tmprow; $sl1 = $permute->index($whc); $sl2 = $permute->index($col); $tmpval .= $sl1; $sl1 .= $sl2; $sl2 .= $tmpval; { my $tmp; ($tmp = $parity->where($wh>0)) *= -1.0; } } # Sidestep near-singularity (NR does this; not sure if it is helpful) my $notbig = $big->where(abs($big) < $TINY); $notbig .= $TINY * (1.0 - 2.0*($notbig < 0)); # Divide by the diagonal element (which is now the largest element) my $tout; ($tout = $out->(($col),$col+1:$n1)) /= $big->(*1); } # end of pivoting part } # end of column loop if(wantarray) { return ($out,$permute,$parity); } $out; } =head2 lu_decomp2 =for sig Signature: (a(m,m); [o]lu(m,m)) =for ref LU decompose a matrix, with no row permutation =for usage ($lu, $perm, $parity) = lu_decomp2($a); $lu = lu_decomp2($a,$perm,$parity); # or $lu = lu_decomp2($a); # $perm and $parity are optional lu_decomp($a->inplace,$perm,$parity); # or lu_decomp($a->inplace); # $perm and $parity are optional =for description C<lu_decomp2> works just like L<lu_decomp|lu_decomp>, but it does B<no> pivoting at all. For compatibility with L<lu_decomp|lu_decomp>, it will give you a permutation list and a parity scalar if you ask for them -- but they are always trivial. Because C<lu_decomp2> does not pivot, it is numerically B<unstable> -- that means it is less precise than L<lu_decomp>, particularly for large or near-singular matrices. There are also specific types of non-singular matrices that confuse it (e.g. ([0,-1,0],[1,0,0],[0,0,1]), which is a 90 degree rotation matrix but which confuses C<lu_decomp2>). On the other hand, if you want to invert rapidly a few hundred thousand small matrices and don't mind missing one or two, it could be the ticket. It can be up to 60% faster at the expense of possible failure of the decomposition for some of the input matrices. The output is a single matrix that contains the LU decomposition of C<$a>; you can even do it in-place, thereby destroying C<$a>, if you want. See L<lu_decomp> for more information about LU decomposition. C<lu_decomp2> is ported from I<Numerical Recipes> into PDL. =cut *PDL::lu_decomp2 = \&lu_decomp2; sub lu_decomp2 { my($in) = shift; my($perm) = shift; my($par) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp2 requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $perm) { barf('lu_decomp2: permutation vector must match the matrix') if(!UNIVERSAL::isa($perm,'PDL') || $perm->ndims != 1 || $perm->dim(0) != $out->dim(0)); $perm .= PDL->xvals($in->dim(0)); } else { $perm = PDL->xvals($in->dim(0)); } if(defined $par) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($par,'PDL') || $par->nelem != 1); $par .= 1.0; } else { $par = pdl(1.0); } my $diagonal = $out->diagonal(0,1); my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->(($col),0:$klim) * $out->(0:$klim,($row)) )->sumover; } } # Figure a_ij, with no pivoting if($col < $n1) { # Divide the rest of the column by the diagonal element my $tmp; # work around for perl -d "feature" ($tmp = $out->(($col),$col+1:$n1)) /= $diagonal->index($col)->dummy(0,$n1-$col); } } # end of column loop if(wantarray) { return ($out,$perm,$par); } $out; } =head2 lu_backsub =for sig Signature: (lu(m,m); perm(m); b(m)) =for ref Solve a x = b for matrix a, by back substitution into a's LU decomposition. =for usage ($lu,$perm,$par) = lu_decomp($a); $x = lu_backsub($lu,$perm,$par,$b); # or $x = lu_backsub($lu,$perm,$b); # $par is not required for lu_backsub lu_backsub($lu,$perm,$b->inplace); # modify $b in-place $x = lu_backsub(lu_decomp($a),$b); # (ignores parity value from lu_decomp) =for description Given the LU decomposition of a square matrix (from L<lu_decomp|lu_decomp>), C<lu_backsub> does back substitution into the matrix to solve C<a x = b> for given vector C<b>. It is separated from the C<lu_decomp> method so that you can call the cheap C<lu_backsub> multiple times and not have to do the expensive LU decomposition more than once. C<lu_backsub> acts on single vectors and threads in the usual way, which means that it treats C<$b> as the I<transpose> of the input. If you want to process a matrix, you must hand in the I<transpose> of the matrix, and then transpose the output when you get it back. that is because pdls are indexed by (col,row), and matrices are (row,column) by convention, so a 1-D pdl corresponds to a row vector, not a column vector. If C<$lu> is dense and you have more than a few points to solve for, it is probably cheaper to find C<a^-1> with L<inv|/inv>, and just multiply C<x = a^-1 b>.) in fact, L<inv|/inv> works by calling C<lu_backsub> with the identity matrix. C<lu_backsub> is ported from section 2.3 of I<Numerical Recipes>. It is written in PDL but should probably be implemented in C. =cut *PDL::lu_backsub = \&lu_backsub; sub lu_backsub { my ($lu, $perm, $b, $par); print STDERR "lu_backsub: entering debug version...\n" if $PDL::debug; if(@_==3) { ($lu, $perm, $b) = @_; } elsif(@_==4) { ($lu, $perm, $par, $b) = @_; } barf("lu_backsub: LU decomposition is undef -- probably from a singular matrix.\n") unless defined($lu); barf("Usage: \$x = lu_backsub(\$lu,\$perm,\$b); all must be PDLs\n") unless(UNIVERSAL::isa($lu,'PDL') && UNIVERSAL::isa($perm,'PDL') && UNIVERSAL::isa($b,'PDL')); my $n = $b->dim(0); my $n1 = $n; $n1--; # Make sure threading dimensions are compatible. # There are two possible sources of thread dims: # # (1) over multiple LU (i.e., $lu,$perm) instances # (2) over multiple B (i.e., $b) column instances # # The full dimensions of the function call looks like # # lu_backsub( lu(m,m,X), perm(m,X), b(m,Y) ) # # where X is the list of extra LU dims and Y is # the list of extra B dims. We have several possible # cases: # # (1) Check that m dims are compatible my $ludims = pdl($lu->dims); my $permdims = pdl($perm->dims); my $bdims = pdl($b->dims); print STDERR "lu_backsub: called with args: \$lu$ludims, \$perm$permdims, \$b$bdims\n" if $PDL::debug; my $m = $ludims((0)); # this is the sig dimension unless ( ($ludims(0) == $m) and ($ludims(1) == $m) and ($permdims(0) == $m) and ($bdims(0) == $m)) { barf "lu_backsub: mismatched sig dimensions"; } my $lunumthr = $ludims->dim(0)-2; my $permnumthr = $permdims->dim(0)-1; my $bnumthr = $bdims->dim(0)-1; unless ( ($lunumthr == $permnumthr) and ($ludims(1:-1) == $permdims)->all ) { barf "lu_backsub: \$lu and \$perm thread dims not equal! \n"; } # (2) If X == Y then default threading is ok if ( ($bnumthr==$permnumthr) and ($bdims==$permdims)->all) { print STDERR "lu_backsub: have explicit thread dims, goto THREAD_OK\n" if $PDL::debug; goto THREAD_OK; } # (3) If X == (x,Y) then add x dummy to lu,perm # (4) If ndims(X) > ndims(Y) then must have #3 # (5) If ndims(X) < ndims(Y) then foreach # non-trivial leading dim in X (x0,x1,..) # insert dummy (x0,x1) into lu and perm # This means that threading occurs over all # leading non-trivial (not length 1) dims of # B unless all the thread dims are explicitly # matched to the LU dims. THREAD_OK: # Permute the vector and make a copy if necessary. my $out; # my $nontrivial = ! (($perm==(PDL->xvals($perm->dims)))->all); my $nontrivial = ! (($perm==$perm->xvals)->clump(-1)->andover); if($nontrivial) { if($b->is_inplace) { $b .= $b->dummy(1,$b->dim(0))->index($perm->dummy(1,1))->sever; # TODO: check threading $out = $b; } else { $out = $b->dummy(1,$b->dim(0))->index($perm->dummy(1,1))->sever; # TODO: check threading } } else { # should check for more matrix dims to thread over # but ignore the issue for now $out = ($b->is_inplace ? $b : $b->copy); } print STDERR "lu_backsub: starting with \$out" . pdl($out->dims) . "\n" if $PDL::debug; # Make sure threading over lu happens OK... if($out->ndims < $lu->ndims-1) { print STDERR "lu_backsub: adjusting dims for \$out" . pdl($out->dims) . "\n" if $PDL::debug; do { $out = $out->dummy(-1,$lu->dim($out->ndims+1)); } while($out->ndims < $lu->ndims-1); $out = $out->sever; } ## Do forward substitution into L my $row; my $r1; for $row(1..$n1) { $r1 = $row-1; my $tmp; # work around perl -d "feature ($tmp = $out->index($row)) -= ($lu->(0:$r1,$row) * $out->(0:$r1) )->sumover; } ## Do backward substitution into U, and normalize by the diagonal my $ludiag = $lu->diagonal(0,1); { my $tmp; # work around for perl -d "feature" ($tmp = $out->index($n1)) /= $ludiag->index($n1)->dummy(0,1); # TODO: check threading } for ($row=$n1; $row>0; $row--) { $r1 = $row-1; my $tmp; # work around for perl -d "feature" ($tmp = $out->index($r1)) -= ($lu->($row:$n1,$r1) * # TODO: check thread dims $out->($row:$n1) )->sumover; ($tmp = $out->index($r1)) /= $ludiag->index($r1)->dummy(0,1); # TODO: check thread dims } $out; } =head2 simq =for sig Signature: ([phys]a(n,n); [phys]b(n); [o,phys]x(n); int [o,phys]ips(n); int flag) =for ref Solution of simultaneous linear equations, C<a x = b>. C<$a> is an C<n x n> matrix (i.e., a vector of length C<n*n>), stored row-wise: that is, C<a(i,j) = a[ij]>, where C<ij = i*n + j>. While this is the transpose of the normal column-wise storage, this corresponds to normal PDL usage. The contents of matrix a may be altered (but may be required for subsequent calls with flag = -1). C<$b>, C<$x>, C<$ips> are vectors of length C<n>. Set C<flag=0> to solve. Set C<flag=-1> to do a new back substitution for different C<$b> vector using the same a matrix previously reduced when C<flag=0> (the C<$ips> vector generated in the previous solution is also required). See also L<lu_backsub|lu_backsub>, which does the same thing with a slightly less opaque interface. =for bad simq ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *simq = \&PDL::simq; =head2 squaretotri =for sig Signature: (a(n,n); b(m)) =for ref Convert a symmetric square matrix to triangular vector storage. =for bad squaretotri does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *squaretotri = \&PDL::squaretotri; ; sub eigen_c { print STDERR "eigen_c is no longer part of PDL::MatrixOps or PDL::Math; use eigens instead.\n"; ## my($mat) = @_; ## my $s = $mat->getdim(0); ## my $z = zeroes($s * ($s+1) / 2); ## my $ev = zeroes($s); ## squaretotri($mat,$z); ## my $k = 0 * $mat; ## PDL::eigens($z, $k, $ev); ## return ($ev, $k); } =head1 AUTHOR Copyright (C) 2002 Craig DeForest (deforest@boulder.swri.edu), R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au). There is no warranty. You are allowed to redistribute and/or modify this work under the same conditions as PDL itself. If this file is separated from the PDL distribution, then the PDL copyright notice should be included in this file. =cut # Exit with OK status 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Minuit.pm�������������������������������������������������������������������0000644�0601750�0601001�00000046343�13110402063�014114� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Minuit; @EXPORT_OK = qw( mn_init mn_def_pars mn_excm mn_pout mn_stat mn_err mn_contour mn_emat PDL::PP mninit PDL::PP mn_abre PDL::PP mn_cierra PDL::PP mnparm PDL::PP mnexcm PDL::PP mnpout PDL::PP mnstat PDL::PP mnemat PDL::PP mnerrs PDL::PP mncont ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Minuit ; =head1 NAME PDL::Minuit -- a PDL interface to the Minuit library =head1 DESCRIPTION This package implements an interface to the Minuit minimization routines (part of the CERN Library) =head1 SYNOPSIS A basic fit with Minuit will call three functions in this package. First, a basic initialization is done with mn_init(). Then, the parameters are defined via the function mn_def_pars(), which allows setting upper and lower bounds. Then the function mn_excm() can be used to issue many Minuit commands, including simplex and migrad minimization algorithms (see Minuit manual for more details). See the test file minuit.t in the test (t/) directory for a basic example. =head1 FUNCTIONS =cut # Package variable my $mn_options; sub mn_init{ my $fun_ref = shift; $mn_options = { Log => undef, Title => 'Minuit Fit', N => undef, Unit => undef, Function => $fun_ref, }; if ( @_ ){ my $args = $_[0]; for my $key (qw/ Log Title Unit/){ $mn_options->{$key} = $args->{$key} if exists $args->{$key}; } } # Check if there was a valid F77 available and barf # if there was not and the user is trying to pass Log if (defined($mn_options->{Log})) { $mn_options->{Unit} = 88 unless defined $mn_options->{Unit}; } else { $mn_options->{Unit} = 6; } if (defined (my $logfile = $mn_options->{Log})){ if (-e $logfile) { unlink $logfile; } PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'new'); print STDERR "# Opening file $logfile....\n"; } PDL::Minuit::mninit(5,$mn_options->{Unit},$mn_options->{Unit}); PDL::Minuit::mnseti($mn_options->{Title}); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } } =head2 mninit =for sig Signature: (int a();int b(); int c()) =for ref info not available =for bad mninit does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mninit = \&PDL::Minuit::mninit; =head2 mn_abre =for sig Signature: (int l(); char* nombre; char* mode) =for ref info not available =for bad mn_abre does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mn_abre = \&PDL::Minuit::mn_abre; =head2 mn_cierra =for sig Signature: (int l()) =for ref info not available =for bad mn_cierra does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mn_cierra = \&PDL::Minuit::mn_cierra; sub mn_def_pars{ my $pars = shift; my $steps = shift; my $n = nelem($pars); $mn_options->{N} = $n; #print "Unit :".$mn_options->{Unit}."\n"; my @names = (); for (my $i=0; $i < $n; $i++) { $names[$i] = "Par_$i"; } my $lo_bounds = zeroes($n); my $up_bounds = zeroes($n); if ( @_ ) { my $opts = $_[0]; $lo_bounds = $opts->{Lower_bounds} if defined $opts->{Lower_bounds}; $up_bounds = $opts->{Upper_bounds} if defined $opts->{Upper_bounds}; if (defined($opts->{Names})){ $names_t = $opts->{Names}; barf " Names has to be an array reference" unless ref($names_t) eq 'ARRAY'; @names = @$names_t; barf " Names has to have as many elements as there are parameters " unless ( @names == $n); } } my $iflag = 0; if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } foreach my $i ( 0..(nelem($pars)-1) ){ my $ii = $i + 1; $iflag = PDL::Minuit::mnparm($ii,$pars->slice("($i)"), $steps->slice("($i)"), $lo_bounds->slice("($i)"), $up_bounds->slice("($i)"), $names[$i]); barf "Problem initializing parameter $i in Minuit " unless ($iflag == 0); } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } } =head2 mnparm =for sig Signature: (int a(); double b(); double c(); double d(); double e(); int [o] ia(); char* str) =for ref info not available =for bad mnparm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mnparm = \&PDL::Minuit::mnparm; sub mn_excm{ my $command = shift; my $fun_ref = $mn_options->{Function}; my ($arglis,$narg); if ( @_ ) { $arglis = shift; $narg = nelem($arglis);} else { $arglis = pdl(0); $narg = 0; } if ( @_ ) { barf "Usage : mn_excm($command, [$arglis]) \n"; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my $iflag = pdl(0); $iflag = PDL::Minuit::mnexcm($arglis, $narg, $command, $fun_ref,$mn_options->{N}); warn "Problem executing command '$command' " unless ($iflag == 0); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return $iflag; } =head2 mnexcm =for sig Signature: (double a(n); int ia(); int [o] ib(); char* str; SV* function; int numelem) =for ref info not available =for bad mnexcm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mnexcm = \&PDL::Minuit::mnexcm; sub mn_pout{ barf "Usage: mn_pout(par_number)" unless ($#_ == 0); my $par_num = shift; my $n = $mn_options->{N}; if (($par_num < 1) || ($par_num > $n)) { barf "Parameter numbers range from 1 to $n "; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my $val = pdl(0); my $err = pdl(0); my $bnd1 = pdl(0); my $bnd2 = pdl(0); my $ivarbl = pdl(0); my $par_name = " "; PDL::Minuit::mnpout($par_num,$val,$err,$bnd1,$bnd2,$ivarbl,\$par_name); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($val,$err,$bnd1,$bnd2,$ivarbl,$par_name); } =head2 mnpout =for sig Signature: (int ia(); double [o] a(); double [o] b(); double [o] c(); double [o] d();int [o] ib(); SV* str) =for ref info not available =for bad mnpout does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mnpout = \&PDL::Minuit::mnpout; sub mn_stat{ if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = PDL::Minuit::mnstat(); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($fmin,$fedm,$errdef,$npari,$nparx,$istat); } =head2 mnstat =for sig Signature: (double [o] a(); double [o] b(); double [o] c(); int [o] ia(); int [o] ib(); int [o] ic()) =for ref info not available =for bad mnstat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mnstat = \&PDL::Minuit::mnstat; sub mn_emat{ if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = PDL::Minuit::mnstat(); my $n = $npari->sum; my $mat = zeroes($n,$n); PDL::Minuit::mnemat($mat); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return $mat; } =head2 mnemat =for sig Signature: (double [o] mat(n,n)) =for ref info not available =for bad mnemat does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mnemat = \&PDL::Minuit::mnemat; sub mn_err{ barf "Usage: mn_err(par_number)" unless ($#_ == 0); my $par_num = shift; my $n = $mn_options->{N}; if (($par_num < 1) || ($par_num > $n)) { barf "Parameter numbers range from 1 to $n "; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my ($eplus,$eminus,$eparab,$globcc) = PDL::Minuit::mnerrs($par_num); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($eplus,$eminus,$eparab,$globcc); } =head2 mnerrs =for sig Signature: (int ia(); double [o] a(); double [o] b(); double [o] c(); double [o] d()) =for ref info not available =for bad mnerrs does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mnerrs = \&PDL::Minuit::mnerrs; sub mn_contour{ barf "Usage: mn_contour(par_number_1,par_number_2,npt)" unless ($#_ == 2); my $par_num_1 = shift; my $par_num_2 = shift; my $npt = shift; my $fun_ref = $mn_options->{Function}; my $n = $mn_options->{N}; if (($par_num_1 < 1) || ($par_num_1 > $n)) { barf "Parameter numbers range from 1 to $n "; } if (($par_num_2 < 1) || ($par_num_2 > $n)) { barf "Parameter numbers range from 1 to $n "; } if ($npt < 5) { barf "Have to specify at least 5 points in routine contour "; } my $xpt = zeroes($npt); my $ypt = zeroes($npt); my $nfound = pdl->new; PDL::Minuit::mncont($par_num_1,$par_num_2,$npt,$xpt,$ypt,$nfound,$fun_ref,$n); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($xpt,$ypt,$nfound); } =head2 mncont =for sig Signature: (int ia(); int ib(); int ic(); double [o] a(n); double [o] b(n); int [o] id(); SV* function; int numelem) =for ref info not available =for bad mncont does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mncont = \&PDL::Minuit::mncont; =head2 mn_init() =for ref The function mn_init() does the basic initialization of the fit. The first argument has to be a reference to the function to be minimized. The function to be minimized has to receive five arguments ($npar,$grad,$fval,$xval,$iflag). The first is the number of parameters currently variable. The second is the gradient of the function (which is not necessarily used, see the Minuit documentation). The third is the current value of the function. The fourth is a piddle with the values of the parameters. The fifth is an integer flag, which indicates what the function is supposed to calculate. The function has to return the values ($fval,$grad), the function value and the function gradient. There are three optional arguments to mn_init(). By default, the output of Minuit will come through STDOUT unless a filename $logfile is given in the Log option. Note that this will mercilessly erase $logfile if it already exists. Additionally, a title can be given to the fit by the Title option, the default is 'Minuit Fit'. If the output is written to a logfile, this is assigned Fortran unit number 88. If for whatever reason you want to have control over the unit number that Fortran associates to the logfile, you can pass the number through the Unit option. =for usage Usage: mn_init($function_ref,{Log=>$logfile,Title=>$title,Unit=>$unit}) =for example Example: mn_init(\&my_function); #same as above but outputting to a file 'log.out'. #title for fit is 'My fit' mn_init(\&my_function, {Log => 'log.out', Title => 'My fit'}); sub my_function{ # the five variables input to the function to be minimized # xval is a piddle containing the current values of the parameters my ($npar,$grad,$fval,$xval,$iflag) = @_; # Here is code computing the value of the function # and potentially also its gradient # ...... # return the two variables. If no gradient is being computed # just return the $grad that came as input return ($fval, $grad); } =head2 mn_def_pars() =for ref The function mn_def_pars() defines the initial values of the parameters of the function to be minimized and the value of the initial steps around these values that the minimizer will use for the first variations of the parameters in the search for the minimum. There are several optional arguments. One allows assigning names to these parameters which otherwise get names (Par_0, Par_1,....,Par_n) by default. Another two arguments can give lower and upper bounds for the parameters via two piddles. If the lower and upper bound for a given parameter are both equal to 0 then the parameter is unbound. By default these lower and upper bound piddles are set to zeroes(n), where n is the number of parameters, i.e. the parameters are unbound by default. The function needs two input variables: a piddle giving the initial values of the parameters and another piddle giving the initial steps. An optional reference to a perl array with the variable names can be passed, as well as piddles with upper and lower bounds for the parameters (see example below). It returns an integer variable which is 0 upon success. =for usage Usage: $iflag = mn_def_pars($pars, $steps,{Names => \@names, Lower_bounds => $lbounds, Upper_bounds => $ubounds}) =for example Example: #initial parameter values my $pars = pdl(2.5,3.0); #steps my $steps = pdl(0.3,0.5); #parameter names my @names = ('intercept','slope'); #use mn_def_pars with default parameter names (Par_0,Par_1,...) my $iflag = mn_def_pars($pars,$steps); #use of mn_def_pars explicitly specify parameter names $iflag = mn_def_pars($pars,$steps,{Names => \@names}); # specify lower and upper bounds for the parameters. # The example below leaves parameter 1 (intercept) unconstrained # and constrains parameter 2 (slope) to be between 0 and 100 my $lbounds = pdl(0, 0); my $ubounds = pdl(0, 100); $iflag = mn_def_pars($pars,$steps,{Names => \@names, Lower_bounds => $lbounds, Upper_bounds => $ubounds}}); #same as above because $lbounds is by default zeroes(n) $iflag = mn_def_pars($pars,$steps,{Names => \@names, Upper_bounds => $ubounds}}); =head2 mn_excm() The function mn_excm() executes a Minuit command passed as a string. The first argument is the command string and an optional second argument is a piddle with arguments to the command. The available commands are listed in Chapter 4 of the Minuit manual (see url below). It returns an integer variable which is 0 upon success. =for usage Usage: $iflag = mn_excm($command_string, {$arglis}) =for example Example: #start a simplex minimization my $iflag = mn_excm('simplex'); #same as above but specify the maximum allowed numbers of #function calls in the minimization my $arglist = pdl(1000); $iflag = mn_excm('simplex',$arglist); #start a migrad minimization $iflag = mn_excm('migrad') #set Minuit strategy in order to get the most reliable results $arglist = pdl(2) $iflag = mn_excm('set strategy',$arglist); # each command can be specified by a minimal string that uniquely # identifies it (see Chapter 4 of Minuit manual). The comannd above # is equivalent to: $iflag = mn_excm('set stra',$arglis); =head2 mn_pout() The function mn_pout() gets the current value of a parameter. It takes as input the parameter number and returns an array with the parameter value, the current estimate of its uncertainty (0 if parameter is constant), lower bound on the parameter, if any (otherwise 0), upper bound on the parameter, if any (otherwise 0), integer flag (which is equal to the parameter number if variable, zero if the parameter is constant and negative if parameter is not defined) and the parameter name. =for usage Usage: ($val,$err,$bnd1,$bnd2,$ivarbl,$par_name) = mn_pout($par_number); =head2 mn_stat() The function mn_stat() gets the current status of the minimization. It returns an array with the best function value found so far, the estimated vertical distance remaining to minimum, the value of UP defining parameter uncertainties (default is 1), the number of currently variable parameters, the highest parameter defined and an integer flag indicating how good the covariance matrix is (0=not calculated at all; 1=diagonal approximation, not accurate; 2=full matrix, but forced positive definite; 3=full accurate matrix) =for usage Usage: ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = mn_stat(); =head2 mn_emat() The function mn_emat returns the covariance matrix as a piddle. =for usage Usage: $emat = mn_emat(); =head2 mn_err() The function mn_err() returns the current existing values for the error in the fitted parameters. It returns an array with the positive error, the negative error, the "parabolic" parameter error from the error matrix and the global correlation coefficient, which is a number between 0 and 1 which gives the correlation between the requested parameter and that linear combination of all other parameters which is most strongly correlated with it. Unless the command 'MINOS' has been issued via the function mn_excm(), the first three values will be equal. =for usage Usage: ($eplus,$eminus,$eparab,$globcc) = mn_err($par_number); =head2 mn_contour() The function mn_contour() finds contours of the function being minimized with respect to two chosen parameters. The contour level is given by F_min + UP, where F_min is the minimum of the function and UP is the ERRordef specified by the user, or 1.0 by default (see Minuit manual). The contour calculated by this function is dynamic, in the sense that it represents the minimum of the function being minimized with respect to all the other NPAR-2 parameters (if any). The function takes as input the parameter numbers with respect to which the contour is to be determined (two) and the number of points $npt required on the contour (>4). It returns an array with piddles $xpt,$ypt containing the coordinates of the contour and a variable $nfound indicating the number of points actually found in the contour. If all goes well $nfound will be equal to $npt, but it can be negative if the input arguments are not valid, zero if less than four points have been found or <$npt if the program could not find $npt points. =for usage Usage: ($xpt,$ypt,$nfound) = mn_contour($par_number_1,$par_number_2,$npt) =head1 SEE ALSO L<PDL> The Minuit documentation is online at http://wwwasdoc.web.cern.ch/wwwasdoc/minuit/minmain.html =head1 AUTHOR This file copyright (C) 2007 Andres Jordan <ajordan@eso.org>. All rights reserved. There is no warranty. You are allowed to redistribute this software/documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ; # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Ops.pm����������������������������������������������������������������������0000644�0601750�0601001�00000051246�13110402065�013410� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Ops; @EXPORT_OK = qw( PDL::PP log10 PDL::PP assgn PDL::PP ipow ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Ops ; =head1 NAME PDL::Ops - Fundamental mathematical operators =head1 DESCRIPTION This module provides the functions used by PDL to overload the basic mathematical operators (C<+ - / *> etc.) and functions (C<sin sqrt> etc.) It also includes the function C<log10>, which should be a perl function so that we can overload it! Matrix multiplication (the operator C<x>) is handled by the module L<PDL::Primitive|PDL::Primitive>. =head1 SYNOPSIS none =cut =head1 FUNCTIONS =cut =head2 plus =for sig Signature: (a(); b(); [o]c(); int swap) =for ref add two piddles =for example $c = plus $a, $b, 0; # explicit call with trailing 0 $c = $a + $b; # overloaded call $a->inplace->plus($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<+> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad plus processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *plus = \&PDL::plus; =head2 mult =for sig Signature: (a(); b(); [o]c(); int swap) =for ref multiply two piddles =for example $c = mult $a, $b, 0; # explicit call with trailing 0 $c = $a * $b; # overloaded call $a->inplace->mult($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<*> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad mult processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *mult = \&PDL::mult; =head2 minus =for sig Signature: (a(); b(); [o]c(); int swap) =for ref subtract two piddles =for example $c = minus $a, $b, 0; # explicit call with trailing 0 $c = $a - $b; # overloaded call $a->inplace->minus($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<-> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad minus processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *minus = \&PDL::minus; =head2 divide =for sig Signature: (a(); b(); [o]c(); int swap) =for ref divide two piddles =for example $c = divide $a, $b, 0; # explicit call with trailing 0 $c = $a / $b; # overloaded call $a->inplace->divide($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C</> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad divide processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *divide = \&PDL::divide; =head2 gt =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E<gt> (greater than) operation =for example $c = gt $a, $b, 0; # explicit call with trailing 0 $c = $a > $b; # overloaded call $a->inplace->gt($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<E<gt>> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad gt processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *gt = \&PDL::gt; =head2 lt =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E<lt> (less than) operation =for example $c = lt $a, $b, 0; # explicit call with trailing 0 $c = $a < $b; # overloaded call $a->inplace->lt($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<E<lt>> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad lt processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *lt = \&PDL::lt; =head2 le =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E<lt>= (less equal) operation =for example $c = le $a, $b, 0; # explicit call with trailing 0 $c = $a <= $b; # overloaded call $a->inplace->le($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<E<lt>=> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad le processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *le = \&PDL::le; =head2 ge =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E<gt>= (greater equal) operation =for example $c = ge $a, $b, 0; # explicit call with trailing 0 $c = $a >= $b; # overloaded call $a->inplace->ge($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<E<gt>=> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad ge processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *ge = \&PDL::ge; =head2 eq =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I<equal to> operation (C<==>) =for example $c = eq $a, $b, 0; # explicit call with trailing 0 $c = $a == $b; # overloaded call $a->inplace->eq($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<==> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad eq processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *eq = \&PDL::eq; =head2 ne =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I<not equal to> operation (C<!=>) =for example $c = ne $a, $b, 0; # explicit call with trailing 0 $c = $a != $b; # overloaded call $a->inplace->ne($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<!=> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad ne processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *ne = \&PDL::ne; =head2 shiftleft =for sig Signature: (a(); b(); [o]c(); int swap) =for ref leftshift C<$a> by C<$b> =for example $c = shiftleft $a, $b, 0; # explicit call with trailing 0 $c = $a << $b; # overloaded call $a->inplace->shiftleft($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<E<lt>E<lt>> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad shiftleft processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *shiftleft = \&PDL::shiftleft; =head2 shiftright =for sig Signature: (a(); b(); [o]c(); int swap) =for ref rightshift C<$a> by C<$b> =for example $c = shiftright $a, $b, 0; # explicit call with trailing 0 $c = $a >> $b; # overloaded call $a->inplace->shiftright($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<E<gt>E<gt>> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad shiftright processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *shiftright = \&PDL::shiftright; =head2 or2 =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I<or> of two piddles =for example $c = or2 $a, $b, 0; # explicit call with trailing 0 $c = $a | $b; # overloaded call $a->inplace->or2($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<|> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad or2 processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *or2 = \&PDL::or2; =head2 and2 =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I<and> of two piddles =for example $c = and2 $a, $b, 0; # explicit call with trailing 0 $c = $a & $b; # overloaded call $a->inplace->and2($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<&> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad and2 processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *and2 = \&PDL::and2; =head2 xor =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I<exclusive or> of two piddles =for example $c = xor $a, $b, 0; # explicit call with trailing 0 $c = $a ^ $b; # overloaded call $a->inplace->xor($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<^> operator. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad xor processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *xor = \&PDL::xor; =head2 bitnot =for sig Signature: (a(); [o]b()) =for ref unary bit negation =for example $b = ~ $a; $a->inplace->bitnot; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<~> operator/function. =for bad bitnot processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *bitnot = \&PDL::bitnot; =head2 power =for sig Signature: (a(); b(); [o]c(); int swap) =for ref raise piddle C<$a> to the power C<$b> =for example $c = $a->power($b,0); # explicit function call $c = $a ** $b; # overloaded use $a->inplace->power($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<**> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad power processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *power = \&PDL::power; =head2 atan2 =for sig Signature: (a(); b(); [o]c(); int swap) =for ref elementwise C<atan2> of two piddles =for example $c = $a->atan2($b,0); # explicit function call $c = atan2 $a, $b; # overloaded use $a->inplace->atan2($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<atan2> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad atan2 processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *atan2 = \&PDL::atan2; =head2 modulo =for sig Signature: (a(); b(); [o]c(); int swap) =for ref elementwise C<modulo> operation =for example $c = $a->modulo($b,0); # explicit function call $c = $a % $b; # overloaded use $a->inplace->modulo($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<%> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad modulo processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *modulo = \&PDL::modulo; =head2 spaceship =for sig Signature: (a(); b(); [o]c(); int swap) =for ref elementwise "<=>" operation =for example $c = $a->spaceship($b,0); # explicit function call $c = $a <=> $b; # overloaded use $a->inplace->spaceship($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the binary C<E<lt>=E<gt>> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad spaceship processes bad values. The state of the bad-value flag of the output piddles is unknown. =cut *spaceship = \&PDL::spaceship; =head2 sqrt =for sig Signature: (a(); [o]b()) =for ref elementwise square root =for example $b = sqrt $a; $a->inplace->sqrt; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<sqrt> operator/function. =for bad sqrt processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sqrt = \&PDL::sqrt; =head2 abs =for sig Signature: (a(); [o]b()) =for ref elementwise absolute value =for example $b = abs $a; $a->inplace->abs; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<abs> operator/function. =for bad abs processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *abs = \&PDL::abs; =head2 sin =for sig Signature: (a(); [o]b()) =for ref the sin function =for example $b = sin $a; $a->inplace->sin; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<sin> operator/function. =for bad sin processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sin = \&PDL::sin; =head2 cos =for sig Signature: (a(); [o]b()) =for ref the cos function =for example $b = cos $a; $a->inplace->cos; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<cos> operator/function. =for bad cos processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cos = \&PDL::cos; =head2 not =for sig Signature: (a(); [o]b()) =for ref the elementwise I<not> operation =for example $b = ! $a; $a->inplace->not; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<!> operator/function. =for bad not processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *not = \&PDL::not; =head2 exp =for sig Signature: (a(); [o]b()) =for ref the exponential function =for example $b = exp $a; $a->inplace->exp; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<exp> operator/function. =for bad exp processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *exp = \&PDL::exp; =head2 log =for sig Signature: (a(); [o]b()) =for ref the natural logarithm =for example $b = log $a; $a->inplace->log; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<log> operator/function. =for bad log processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *log = \&PDL::log; =head2 log10 =for sig Signature: (a(); [o]b()) =for ref the base 10 logarithm =for example $b = log10 $a; $a->inplace->log10; # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. This function is used to overload the unary C<log10> operator/function. =for bad log10 processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::log10 { my $x = shift; if ( ! UNIVERSAL::isa($x,"PDL") ) { return log($x) / log(10); } my $y; if ( $x->is_inplace ) { $x->set_inplace(0); $y = $x; } elsif( ref($x) eq "PDL"){ #PDL Objects, use nullcreate: $y = PDL->nullcreate($x); }else{ #PDL-Derived Object, use copy: (Consistent with # Auto-creation docs in Objects.pod) $y = $x->copy; } &PDL::_log10_int( $x, $y ); return $y; }; *log10 = \&PDL::log10; =head2 assgn =for sig Signature: (a(); [o]b()) =for ref Plain numerical assignment. This is used to implement the ".=" operator =for bad assgn does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *assgn = \&PDL::assgn; =head2 ipow =for sig Signature: (a(); b(); [o] ans()) =for ref raise piddle C<$a> to integer power C<$b> =for example $c = $a->ipow($b,0); # explicit function call $c = ipow $a, $b; $a->inplace->ipow($b,0); # modify $a inplace It can be made to work inplace with the C<$a-E<gt>inplace> syntax. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. Algorithm from L<Wikipedia|http://en.wikipedia.org/wiki/Exponentiation_by_squaring> =for bad ipow does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ipow = \&PDL::ipow; ; =head1 AUTHOR Tuomas J. Lukka (lukka@fas.harvard.edu), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Doug Hunt (dhunt@ucar.edu), Christian Soeller (c.soeller@auckland.ac.nz), Doug Burke (burke@ifa.hawaii.edu), and Craig DeForest (deforest@boulder.swri.edu). =cut # Exit with OK status 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Primitive.pm����������������������������������������������������������������0000644�0601750�0601001�00000216125�13110402064�014615� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Primitive; @EXPORT_OK = qw( PDL::PP inner PDL::PP outer matmult PDL::PP matmult PDL::PP innerwt PDL::PP inner2 PDL::PP inner2d PDL::PP inner2t PDL::PP crossp PDL::PP norm PDL::PP indadd PDL::PP conv1d PDL::PP in uniq uniqind uniqvec PDL::PP hclip PDL::PP lclip clip PDL::PP clip PDL::PP wtstat PDL::PP statsover stats PDL::PP histogram PDL::PP whistogram PDL::PP histogram2d PDL::PP whistogram2d PDL::PP fibonacci PDL::PP append PDL::PP axisvalues PDL::PP random PDL::PP randsym grandom vsearch PDL::PP vsearch_sample PDL::PP vsearch_insert_leftmost PDL::PP vsearch_insert_rightmost PDL::PP vsearch_match PDL::PP vsearch_bin_inclusive PDL::PP vsearch_bin_exclusive PDL::PP interpolate interpol interpND one2nd PDL::PP which PDL::PP which_both where whereND whichND setops intersect ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Primitive ; use PDL::Slices; use Carp; =head1 NAME PDL::Primitive - primitive operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP and able to use the new indexing tricks. See L<PDL::Indexing|PDL::Indexing> for how to use indices creatively. For explanation of the signature format, see L<PDL::PP|PDL::PP>. =head1 SYNOPSIS # Pulls in PDL::Primitive, among other modules. use PDL; # Only pull in PDL::Primitive: use PDL::Primitive; =cut =head1 FUNCTIONS =cut =head2 inner =for sig Signature: (a(n); b(n); [o]c()) =for ref Inner product over one dimension c = sum_i a_i * b_i =for bad =for bad If C<a() * b()> contains only bad data, C<c()> is set bad. Otherwise C<c()> will have its bad flag cleared, as it will not contain any bad values. =cut *inner = \&PDL::inner; =head2 outer =for sig Signature: (a(n); b(m); [o]c(n,m)) =for ref outer product over one dimension Naturally, it is possible to achieve the effects of outer product simply by threading over the "C<*>" operator but this function is provided for convenience. =for bad outer processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *outer = \&PDL::outer; =head2 x =for sig Signature: (a(i,z), b(x,i),[o]c(x,z)) =for ref Matrix multiplication PDL overloads the C<x> operator (normally the repeat operator) for matrix multiplication. The number of columns (size of the 0 dimension) in the left-hand argument must normally equal the number of rows (size of the 1 dimension) in the right-hand argument. Row vectors are represented as (N x 1) two-dimensional PDLs, or you may be sloppy and use a one-dimensional PDL. Column vectors are represented as (1 x N) two-dimensional PDLs. Threading occurs in the usual way, but as both the 0 and 1 dimension (if present) are included in the operation, you must be sure that you don't try to thread over either of those dims. EXAMPLES Here are some simple ways to define vectors and matrices: pdl> $r = pdl(1,2); # A row vector pdl> $c = pdl([[3],[4]]); # A column vector pdl> $c = pdl(3,4)->(*1); # A column vector, using NiceSlice pdl> $m = pdl([[1,2],[3,4]]); # A 2x2 matrix Now that we have a few objects prepared, here is how to matrix-multiply them: pdl> print $r x $m # row x matrix = row [ [ 7 10] ] pdl> print $m x $r # matrix x row = ERROR PDL: Dim mismatch in matmult of [2x2] x [2x1]: 2 != 1 pdl> print $m x $c # matrix x column = column [ [ 5] [11] ] pdl> print $m x 2 # Trivial case: scalar mult. [ [2 4] [6 8] ] pdl> print $r x $c # row x column = scalar [ [11] ] pdl> print $c x $r # column x row = matrix [ [3 6] [4 8] ] INTERNALS The mechanics of the multiplication are carried out by the L<matmult|/matmult> method. =cut =head2 matmult =for sig Signature: (a(t,h); b(w,t); [o]c(w,h)) =for ref Matrix multiplication Notionally, matrix multiplication $a x $b is equivalent to the threading expression $a->dummy(1)->inner($b->xchg(0,1)->dummy(2),$c); but for large matrices that breaks CPU cache and is slow. Instead, matmult calculates its result in 32x32x32 tiles, to keep the memory footprint within cache as long as possible on most modern CPUs. For usage, see L<x|/x>, a description of the overloaded 'x' operator =for bad matmult ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::matmult { my ($a,$b,$c) = @_; $b = pdl($b) unless eval { $b->isa('PDL') }; $c = PDL->null unless eval { $c->isa('PDL') }; while($a->getndims < 2) {$a = $a->dummy(-1)} while($b->getndims < 2) {$b = $b->dummy(-1)} return ($c .= $a * $b) if( ($a->dim(0)==1 && $a->dim(1)==1) || ($b->dim(0)==1 && $b->dim(1)==1) ); if($b->dim(1) != $a->dim(0)) { barf(sprintf("Dim mismatch in matmult of [%dx%d] x [%dx%d]: %d != %d",$a->dim(0),$a->dim(1),$b->dim(0),$b->dim(1),$a->dim(0),$b->dim(1))); } PDL::_matmult_int($a,$b,$c); $c; } *matmult = \&PDL::matmult; =head2 innerwt =for sig Signature: (a(n); b(n); c(n); [o]d()) =for ref Weighted (i.e. triple) inner product d = sum_i a(i) b(i) c(i) =for bad innerwt processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *innerwt = \&PDL::innerwt; =head2 inner2 =for sig Signature: (a(n); b(n,m); c(m); [o]d()) =for ref Inner product of two vectors and a matrix d = sum_ij a(i) b(i,j) c(j) Note that you should probably not thread over C<a> and C<c> since that would be very wasteful. Instead, you should use a temporary for C<b*c>. =for bad inner2 processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *inner2 = \&PDL::inner2; =head2 inner2d =for sig Signature: (a(n,m); b(n,m); [o]c()) =for ref Inner product over 2 dimensions. Equivalent to $c = inner($a->clump(2), $b->clump(2)) =for bad inner2d processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *inner2d = \&PDL::inner2d; =head2 inner2t =for sig Signature: (a(j,n); b(n,m); c(m,k); [t]tmp(n,k); [o]d(j,k))) =for ref Efficient Triple matrix product C<a*b*c> Efficiency comes from by using the temporary C<tmp>. This operation only scales as C<N**3> whereas threading using L<inner2|/inner2> would scale as C<N**4>. The reason for having this routine is that you do not need to have the same thread-dimensions for C<tmp> as for the other arguments, which in case of large numbers of matrices makes this much more memory-efficient. It is hoped that things like this could be taken care of as a kind of closures at some point. =for bad inner2t processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *inner2t = \&PDL::inner2t; =head2 crossp =for sig Signature: (a(tri=3); b(tri); [o] c(tri)) =for ref Cross product of two 3D vectors After =for example $c = crossp $a, $b the inner product C<$c*$a> and C<$c*$b> will be zero, i.e. C<$c> is orthogonal to C<$a> and C<$b> =for bad crossp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *crossp = \&PDL::crossp; =head2 norm =for sig Signature: (vec(n); [o] norm(n)) =for ref Normalises a vector to unit Euclidean length =for bad norm processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *norm = \&PDL::norm; =head2 indadd =for sig Signature: (a(); indx ind(); [o] sum(m)) =for ref Threaded Index Add: Add C<a> to the C<ind> element of C<sum>, i.e: sum(ind) += a =for example Simple Example: $a = 2; $ind = 3; $sum = zeroes(10); indadd($a,$ind, $sum); print $sum #Result: ( 2 added to element 3 of $sum) # [0 0 0 2 0 0 0 0 0 0] Threaded Example: $a = pdl( 1,2,3); $ind = pdl( 1,4,6); $sum = zeroes(10); indadd($a,$ind, $sum); print $sum."\n"; #Result: ( 1, 2, and 3 added to elements 1,4,6 $sum) # [0 1 0 0 2 0 3 0 0 0] =for bad =for bad The routine barfs if any of the indices are bad. =cut *indadd = \&PDL::indadd; =head2 conv1d =for sig Signature: (a(m); kern(p); [o]b(m); int reflect) =for ref 1D convolution along first dimension The m-th element of the discrete convolution of an input piddle C<$a> of size C<$M>, and a kernel piddle C<$kern> of size C<$P>, is calculated as n = ($P-1)/2 ==== \ ($a conv1d $kern)[m] = > $a_ext[m - n] * $kern[n] / ==== n = -($P-1)/2 where C<$a_ext> is either the periodic (or reflected) extension of C<$a> so it is equal to C<$a> on C< 0..$M-1 > and equal to the corresponding periodic/reflected image of C<$a> outside that range. =for example $con = conv1d sequence(10), pdl(-1,0,1); $con = conv1d sequence(10), pdl(-1,0,1), {Boundary => 'reflect'}; By default, periodic boundary conditions are assumed (i.e. wrap around). Alternatively, you can request reflective boundary conditions using the C<Boundary> option: {Boundary => 'reflect'} # case in 'reflect' doesn't matter The convolution is performed along the first dimension. To apply it across another dimension use the slicing routines, e.g. $b = $a->mv(2,0)->conv1d($kernel)->mv(0,2); # along third dim This function is useful for threaded filtering of 1D signals. Compare also L<conv2d|PDL::Image2D/conv2d>, L<convolve|PDL::ImageND/convolve>, L<fftconvolve|PDL::FFT/fftconvolve()>, L<fftwconv|PDL::FFTW/fftwconv>, L<rfftwconv|PDL::FFTW/rfftwconv> =for bad WARNING: C<conv1d> processes bad values in its inputs as the numeric value of C<< $pdl->badvalue >> so it is not recommended for processing pdls with bad values in them unless special care is taken. =for bad conv1d ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::conv1d { my $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )' if $#_<1 || $#_>2; my($a,$kern) = @_; my $c = $#_ == 2 ? $_[2] : PDL->null; &PDL::_conv1d_int($a,$kern,$c, !(defined $opt && exists $$opt{Boundary}) ? 0 : lc $$opt{Boundary} eq "reflect"); return $c; } *conv1d = \&PDL::conv1d; =head2 in =for sig Signature: (a(); b(n); [o] c()) =for ref test if a is in the set of values b =for example $goodmsk = $labels->in($goodlabels); print pdl(3,1,4,6,2)->in(pdl(2,3,3)); [1 0 0 0 1] C<in> is akin to the I<is an element of> of set theory. In principle, PDL threading could be used to achieve its functionality by using a construct like $msk = ($labels->dummy(0) == $goodlabels)->orover; However, C<in> doesn't create a (potentially large) intermediate and is generally faster. =for bad in does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *in = \&PDL::in; =head2 uniq =for ref return all unique elements of a piddle The unique elements are returned in ascending order. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniq [-1 0 2 4 6] # 0 is returned 2nd (sorted order) PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniq [-1 2 4 6 nan] # NaN value is returned at end Note: The returned pdl is 1D; any structure of the input piddle is lost. C<NaN> values are never compare equal to any other values, even themselves. As a result, they are always unique. C<uniq> returns the NaN values at the end of the result piddle. This follows the Matlab usage. See L<uniqind|uniqind> if you need the indices of the unique elements rather than the values. =cut =for bad Bad values are not considered unique by uniq and are ignored. $a=sequence(10); $a=$a->setbadif($a%3); print $a->uniq; [0 3 6 9] =cut *uniq = \&PDL::uniq; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniq { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) my $srt = $arr->clump(-1)->where($arr==$arr)->qsort; # no NaNs or BADs for qsort my $nans = $arr->clump(-1)->where($arr!=$arr); my $uniq = ($srt->nelem > 0) ? $srt->where($srt != $srt->rotate(-1)) : $srt; # make sure we return something if there is only one value my $answ = $nans; # NaN values always uniq if ( $uniq->nelem > 0 ) { $answ = $uniq->append($answ); } else { $answ = ( ($srt->nelem == 0) ? $srt : PDL::pdl( ref($srt), [$srt->index(0)] ) )->append($answ); } return $answ; } =head2 uniqind =for ref Return the indices of all unique elements of a piddle The order is in the order of the values to be consistent with uniq. C<NaN> values never compare equal with any other value and so are always unique. This follows the Matlab usage. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniqind [5 4 1 3 6] # the 0 at index 4 is returned 2nd, but... PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniqind [5 1 3 6 4] # ...the NaN at index 4 is returned at end Note: The returned pdl is 1D; any structure of the input piddle is lost. See L<uniq|uniq> if you want the unique values instead of the indices. =cut =for bad Bad values are not considered unique by uniqind and are ignored. =cut *uniqind = \&PDL::uniqind; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniqind { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) # Different from uniq we sort and store the result in an intermediary my $aflat = $arr->flat; my $nanind = which($aflat!=$aflat); # NaN indexes my $good = $aflat->sequence->long->where($aflat==$aflat); # good indexes my $i_srt = $aflat->where($aflat==$aflat)->qsorti; # no BAD or NaN values for qsorti my $srt = $aflat->where($aflat==$aflat)->index($i_srt); my $uniqind; if ($srt->nelem > 0) { $uniqind = which($srt != $srt->rotate(-1)); $uniqind = $i_srt->slice('0') if $uniqind->isempty; } else { $uniqind = which($srt); } # Now map back to the original space my $ansind = $nanind; if ( $uniqind->nelem > 0 ) { $ansind = ($good->index($i_srt->index($uniqind)))->append($ansind); } else { $ansind = $uniqind->append($ansind); } return $ansind; } =head2 uniqvec =for ref Return all unique vectors out of a collection NOTE: If any vectors in the input piddle have NaN values they are returned at the end of the non-NaN ones. This is because, by definition, NaN values never compare equal with any other value. NOTE: The current implementation does not sort the vectors containing NaN values. The unique vectors are returned in lexicographically sorted ascending order. The 0th dimension of the input PDL is treated as a dimensional index within each vector, and the 1st and any higher dimensions are taken to run across vectors. The return value is always 2D; any structure of the input PDL (beyond using the 0th dimension for vector index) is lost. See also L<uniq|uniq> for a unique list of scalars; and L<qsortvec|PDL::Ufunc/qsortvec> for sorting a list of vectors lexicographcally. =cut =for bad If a vector contains all bad values, it is ignored as in L<uniq|uniq>. If some of the values are good, it is treated as a normal vector. For example, [1 2 BAD] and [BAD 2 3] could be returned, but [BAD BAD BAD] could not. Vectors containing BAD values will be returned after any non-NaN and non-BAD containing vectors, followed by the NaN vectors. =cut sub PDL::uniqvec { my($pdl) = shift; return $pdl if ( $pdl->nelem == 0 || $pdl->ndims < 2 ); return $pdl if ( $pdl->slice("(0)")->nelem < 2 ); # slice isn't cheap but uniqvec isn't either my $pdl2d = null; $pdl2d = $pdl->mv(0,-1)->clump($pdl->ndims-1)->mv(-1,0); # clump all but dim(0) my $ngood = null; $ngood = $pdl2d->ones->sumover; $ngood = $pdl2d->ngoodover if ($PDL::Bad::Status && $pdl->badflag); # number of good values each vector my $ngood2 = null; $ngood2 = $ngood->where($ngood); # number of good values with no all-BADs $pdl2d = $pdl2d->mv(0,-1)->dice($ngood->which)->mv(-1,0); # remove all-BAD vectors my $numnan = null; $numnan = ($pdl2d!=$pdl2d)->sumover; # works since no all-BADs to confuse my $presrt = null; $presrt = $pdl2d->mv(0,-1)->dice($numnan->not->which)->mv(0,-1); # remove vectors with any NaN values my $nanvec = null; $nanvec = $pdl2d->mv(0,-1)->dice($numnan->which)->mv(0,-1); # the vectors with any NaN values # use dice instead of nslice since qsortvec might be packing # the badvals to the front of the array instead of the end like # the docs say. If that is the case and it gets fixed, it won't # bust uniqvec. DAL 14-March 2006 my $srt = null; $srt = $presrt->qsortvec->mv(0,-1); # BADs are sorted by qsortvec my $srtdice = $srt; my $somebad = null; if ($PDL::Bad::Status && $srt->badflag) { $srtdice = $srt->dice($srt->mv(0,-1)->nbadover->not->which); $somebad = $srt->dice($srt->mv(0,-1)->nbadover->which); } my $uniq = null; if ($srtdice->nelem > 0) { $uniq = ($srtdice != $srtdice->rotate(-1))->mv(0,-1)->orover->which; } else { $uniq = $srtdice->orover->which; } my $ans = null; if ( $uniq->nelem > 0 ) { $ans = $srtdice->dice($uniq); } else { $ans = ($srtdice->nelem > 0) ? $srtdice->slice("0,:") : $srtdice; } return $ans->append($somebad)->append($nanvec->mv(0,-1))->mv(0,-1); } =head2 hclip =for sig Signature: (a(); b(); [o] c()) =for ref clip (threshold) C<$a> by C<$b> (C<$b> is upper bound) =for bad hclip processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::hclip { my ($a,$b) = @_; my $c; if ($a->is_inplace) { $a->set_inplace(0); $c = $a; } elsif ($#_ > 1) {$c=$_[2]} else {$c=PDL->nullcreate($a)} &PDL::_hclip_int($a,$b,$c); return $c; } *hclip = \&PDL::hclip; =head2 lclip =for sig Signature: (a(); b(); [o] c()) =for ref clip (threshold) C<$a> by C<$b> (C<$b> is lower bound) =for bad lclip processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::lclip { my ($a,$b) = @_; my $c; if ($a->is_inplace) { $a->set_inplace(0); $c = $a; } elsif ($#_ > 1) {$c=$_[2]} else {$c=PDL->nullcreate($a)} &PDL::_lclip_int($a,$b,$c); return $c; } *lclip = \&PDL::lclip; =head2 clip =for ref Clip (threshold) a piddle by (optional) upper or lower bounds. =for usage $b = $a->clip(0,3); $c = $a->clip(undef, $x); =cut =for bad clip handles bad values since it is just a wrapper around L<hclip|/hclip> and L<lclip|/lclip>. =cut =head2 clip =for sig Signature: (a(); l(); h(); [o] c()) =for ref info not available =for bad clip processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *clip = \&PDL::clip; sub PDL::clip { my($a, $l, $h) = @_; my $d; unless(defined($l) || defined($h)) { # Deal with pathological case if($a->is_inplace) { $a->set_inplace(0); return $a; } else { return $a->copy; } } if($a->is_inplace) { $a->set_inplace(0); $d = $a } elsif ($#_ > 2) { $d=$_[3] } else { $d = PDL->nullcreate($a); } if(defined($l) && defined($h)) { &PDL::_clip_int($a,$l,$h,$d); } elsif( defined($l) ) { &PDL::_lclip_int($a,$l,$d); } elsif( defined($h) ) { &PDL::_hclip_int($a,$h,$d); } else { die "This can't happen (clip contingency) - file a bug"; } return $d; } *clip = \&PDL::clip; =head2 wtstat =for sig Signature: (a(n); wt(n); avg(); [o]b(); int deg) =for ref Weighted statistical moment of given degree This calculates a weighted statistic over the vector C<a>. The formula is b() = (sum_i wt_i * (a_i ** degree - avg)) / (sum_i wt_i) =for bad =for bad Bad values are ignored in any calculation; C<$b> will only have its bad flag set if the output contains any bad data. =cut *wtstat = \&PDL::wtstat; =head2 statsover =for sig Signature: (a(n); w(n); float+ [o]avg(); float+ [o]prms(); int+ [o]median(); int+ [o]min(); int+ [o]max(); float+ [o]adev(); float+ [o]rms()) =for ref Calculate useful statistics over a dimension of a piddle =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = statsover($piddle, $weights); This utility function calculates various useful quantities of a piddle. These are: =over 3 =item * the mean: MEAN = sum (x)/ N with C<N> being the number of elements in x =item * the population RMS deviation from the mean: PRMS = sqrt( sum( (x-mean(x))^2 )/(N-1) The population deviation is the best-estimate of the deviation of the population from which a sample is drawn. =item * the median The median is the 50th percentile data value. Median is found by L<medover|PDL::Ufunc/medover>, so WEIGHTING IS IGNORED FOR THE MEDIAN CALCULATION. =item * the minimum =item * the maximum =item * the average absolute deviation: AADEV = sum( abs(x-mean(x)) )/N =item * RMS deviation from the mean: RMS = sqrt(sum( (x-mean(x))^2 )/N) (also known as the root-mean-square deviation, or the square root of the variance) =back This operator is a projection operator so the calculation will take place over the final dimension. Thus if the input is N-dimensional each returned value will be N-1 dimensional, to calculate the statistics for the entire piddle either use C<clump(-1)> directly on the piddle or call C<stats>. =for bad =for bad Bad values are simply ignored in the calculation, effectively reducing the sample size. If all data are bad then the output data are marked bad. =cut sub PDL::statsover { barf('Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($data,[$weights])') if $#_>1; my ($data, $weights) = @_; $weights = $data->ones() if !defined($weights); my $median = $data->medover(); my $mean = PDL->nullcreate($data); my $rms = PDL->nullcreate($data); my $min = PDL->nullcreate($data); my $max = PDL->nullcreate($data); my $adev = PDL->nullcreate($data); my $prms = PDL->nullcreate($data); &PDL::_statsover_int($data, $weights, $mean, $prms, $median, $min, $max, $adev, $rms); return $mean unless wantarray; return ($mean, $prms, $median, $min, $max, $adev, $rms); } *statsover = \&PDL::statsover; =head2 stats =for ref Calculates useful statistics on a piddle =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = stats($piddle,[$weights]); This utility calculates all the most useful quantities in one call. It works the same way as L</statsover>, except that the quantities are calculated considering the entire input PDL as a single sample, rather than as a collection of rows. See L</statsover> for definitions of the returned quantities. =cut =for bad Bad values are handled; if all input values are bad, then all of the output values are flagged bad. =cut *stats = \&PDL::stats; sub PDL::stats { barf('Usage: ($mean,[$rms]) = stats($data,[$weights])') if $#_>1; my ($data,$weights) = @_; # Ensure that $weights is properly threaded over; this could be # done rather more efficiently... if(defined $weights) { $weights = pdl($weights) unless UNIVERSAL::isa($weights,'PDL'); if( ($weights->ndims != $data->ndims) or (pdl($weights->dims) != pdl($data->dims))->or ) { $weights = $weights + zeroes($data) } $weights = $weights->flat; } return PDL::statsover($data->flat,$weights); } =head2 histogram =for sig Signature: (in(n); int+[o] hist(m); double step; double min; int msize => m) =for ref Calculates a histogram for given stepsize and minimum. =for usage $h = histogram($data, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing piddle. histogram($data, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the number of values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. For a higher-level interface, see L<hist|PDL::Basic/hist>. =for example pdl> p histogram(pdl(1,1,2),1,0,3) [0 2 1] =for bad histogram processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *histogram = \&PDL::histogram; =head2 whistogram =for sig Signature: (in(n); float+ wt(n);float+[o] hist(m); double step; double min; int msize => m) =for ref Calculates a histogram from weighted data for given stepsize and minimum. =for usage $h = whistogram($data, $weights, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing piddle. whistogram($data, $weights, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. =for example pdl> p whistogram(pdl(1,1,2), pdl(0.1,0.1,0.5), 1, 0, 4) [0 0.2 0.5 0] =for bad whistogram processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *whistogram = \&PDL::whistogram; =head2 histogram2d =for sig Signature: (ina(n); inb(n); int+[o] hist(ma,mb); double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;) =for ref Calculates a 2d histogram. =for usage $h = histogram2d($datax, $datay, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing piddle. histogram2d($datax, $datay, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the number of values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p histogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),1,0,3,1,0,3) [ [0 0 0] [0 2 2] [0 1 0] ] =for bad histogram2d processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *histogram2d = \&PDL::histogram2d; =head2 whistogram2d =for sig Signature: (ina(n); inb(n); float+ wt(n);float+[o] hist(ma,mb); double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;) =for ref Calculates a 2d histogram from weighted data. =for usage $h = whistogram2d($datax, $datay, $weights, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing piddle. whistogram2d($datax, $datay, $weights, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p whistogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),pdl(0.1,0.2,0.3,0.4,0.5),1,0,3,1,0,3) [ [ 0 0 0] [ 0 0.5 0.9] [ 0 0.1 0] ] =for bad whistogram2d processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *whistogram2d = \&PDL::whistogram2d; =head2 fibonacci =for sig Signature: ([o]x(n)) =for ref Constructor - a vector with Fibonacci's sequence =for bad fibonacci does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub fibonacci { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->fibonacci : PDL->fibonacci(@_) } sub PDL::fibonacci{ my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; &PDL::_fibonacci_int($x->clump(-1)); return $x; } =head2 append =for sig Signature: (a(n); b(m); [o] c(mn)) =for ref append two or more piddles by concatenating along their first dimensions =for example $a = ones(2,4,7); $b = sequence 5; $c = $a->append($b); # size of $c is now (7,4,7) (a jumbo-piddle ;) C<append> appends two piddles along their first dims. Rest of the dimensions must be compatible in the threading sense. Resulting size of first dim is the sum of the sizes of the first dims of the two argument piddles - ie C<n + m>. Similar functions include L<glue|/glue> (below) and L<cat|PDL::Core/cat>. =for bad append does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *append = \&PDL::append; =head2 glue =for usage $c = $a->glue(<dim>,$b,...) =for ref Glue two or more PDLs together along an arbitrary dimension (N-D L<append|append>). Sticks $a, $b, and all following arguments together along the specified dimension. All other dimensions must be compatible in the threading sense. Glue is permissive, in the sense that every PDL is treated as having an infinite number of trivial dimensions of order 1 -- so C<< $a->glue(3,$b) >> works, even if $a and $b are only one dimensional. If one of the PDLs has no elements, it is ignored. Likewise, if one of them is actually the undefined value, it is treated as if it had no elements. If the first parameter is a defined perl scalar rather than a pdl, then it is taken as a dimension along which to glue everything else, so you can say C<$cube = PDL::glue(3,@image_list);> if you like. C<glue> is implemented in pdl, using a combination of L<xchg|PDL::Slices/xchg> and L<append|append>. It should probably be updated (one day) to a pure PP function. Similar functions include L<append|/append> (above) and L<cat|PDL::Core/cat>. =cut sub PDL::glue{ my($a) = shift; my($dim) = shift; if(defined $a && !(ref $a)) { my $b = $dim; $dim = $a; $a = $b; } if(!defined $a || $a->nelem==0) { return $a unless(@_); return shift() if(@_<=1); $a=shift; return PDL::glue($a,$dim,@_); } if($dim - $a->dim(0) > 100) { print STDERR "warning:: PDL::glue allocating >100 dimensions!\n"; } while($dim >= $a->ndims) { $a = $a->dummy(-1,1); } $a = $a->xchg(0,$dim); while(scalar(@_)){ my $b = shift; next unless(defined $b && $b->nelem); while($dim >= $b->ndims) { $b = $b->dummy(-1,1); } $b = $b->xchg(0,$dim); $a = $a->append($b); } $a->xchg(0,$dim); } =head2 axisvalues =for sig Signature: ([o,nc]a(n)) =for ref Internal routine C<axisvalues> is the internal primitive that implements L<axisvals|PDL::Basic/axisvals> and alters its argument. =for bad axisvalues does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *axisvalues = \&PDL::axisvalues; =head2 random =for ref Constructor which returns piddle of random numbers =for usage $a = random([type], $nx, $ny, $nz,...); $a = random $b; etc (see L<zeroes|PDL::Core/zeroes>). This is the uniform distribution between 0 and 1 (assumedly excluding 1 itself). The arguments are the same as C<zeroes> (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the perl function L<srand|perlfunc/srand> to seed the random generator. For further details consult Perl's L<srand|perlfunc/srand> documentation. =head2 randsym =for ref Constructor which returns piddle of random numbers =for usage $a = randsym([type], $nx, $ny, $nz,...); $a = randsym $b; etc (see L<zeroes|PDL::Core/zeroes>). This is the uniform distribution between 0 and 1 (excluding both 0 and 1, cf L<random|/random>). The arguments are the same as C<zeroes> (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the perl function L<srand|perlfunc/srand> to seed the random generator. For further details consult Perl's L<srand|perlfunc/srand> documentation. =cut sub random { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->random : PDL->random(@_) } sub PDL::random { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; &PDL::_random_int($x); return $x; } sub randsym { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->randsym : PDL->randsym(@_) } sub PDL::randsym { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; &PDL::_randsym_int($x); return $x; } =head2 grandom =for ref Constructor which returns piddle of Gaussian random numbers =for usage $a = grandom([type], $nx, $ny, $nz,...); $a = grandom $b; etc (see L<zeroes|PDL::Core/zeroes>). This is generated using the math library routine C<ndtri>. Mean = 0, Stddev = 1 You can use the perl function L<srand|perlfunc/srand> to seed the random generator. For further details consult Perl's L<srand|perlfunc/srand> documentation. =cut sub grandom { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->grandom : PDL->grandom(@_) } sub PDL::grandom { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; use PDL::Math 'ndtri'; $x .= ndtri(randsym($x)); return $x; } =head2 vsearch =for sig Signature: ( vals(); xs(n); [o] indx(); [\%options] ) =for ref Efficiently search for values in a sorted piddle, returning indices. =for usage $idx = vsearch( $vals, $x, [\%options] ); vsearch( $vals, $x, $idx, [\%options ] ); B<vsearch> performs a binary search in the ordered piddle C<$x>, for the values from C<$vals> piddle, returning indices into C<$x>. What is a "match", and the meaning of the returned indices, are determined by the options. The C<mode> option indicates which method of searching to use, and may be one of: =over =item C<sample> invoke B<vsearch_sample>, returning indices appropriate for sampling within a distribution. =item C<insert_leftmost> invoke B<vsearch_insert_leftmost>, returning the left-most possible insertion point which still leaves the piddle sorted. =item C<insert_rightmost> invoke B<vsearch_insert_rightmost>, returning the right-most possible insertion point which still leaves the piddle sorted. =item C<insert_match> invoke B<vsearch_match>, returning the index of a matching element, else -(insertion point + 1) =item C<insert_bin_inclusive> invoke B<vsearch_bin_inclusive>, returning an index appropriate for binning on a grid where the left bin edges are I<inclusive> of the bin. See below for further explanation of the bin. =item C<insert_bin_exclusive> invoke B<vsearch_bin_exclusive>, returning an index appropriate for binning on a grid where the left bin edges are I<exclusive> of the bin. See below for further explanation of the bin. =back The default value of C<mode> is C<sample>. =cut sub vsearch { my $opt = 'HASH' eq ref $_[-1] ? pop : { mode => 'sample' }; croak( "unknown options to vsearch\n" ) if ( ! defined $opt->{mode} && keys %$opt ) || keys %$opt > 1; my $mode = $opt->{mode}; goto $mode eq 'sample' ? \&vsearch_sample : $mode eq 'insert_leftmost' ? \&vsearch_insert_leftmost : $mode eq 'insert_rightmost' ? \&vsearch_insert_rightmost : $mode eq 'match' ? \&vsearch_match : $mode eq 'bin_inclusive' ? \&vsearch_bin_inclusive : $mode eq 'bin_exclusive' ? \&vsearch_bin_exclusive : croak( "unknown vsearch mode: $mode\n" ); } *PDL::vsearch = \&vsearch; =head2 vsearch_sample =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Search for values in a sorted array, return index appropriate for sampling from a distribution =for usage $idx = vsearch_sample($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B<vsearch_sample> returns an index I<I> for each value I<V> of C<$vals> appropriate for sampling C<$vals> I<I> has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem -1 =item * if C<$x> is sorted in decreasing order V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem - 1 =back If all elements of C<$x> are equal, I<< I = $x->nelem - 1 >>. If C<$x> contains duplicated elements, I<I> is the index of the leftmost (by position in array) duplicate if I<V> matches. =for example This function is useful e.g. when you have a list of probabilities for events and want to generate indices to events: $a = pdl(.01,.86,.93,1); # Barnsley IFS probabilities cumulatively $b = random 20; $c = vsearch_sample($b, $a); # Now, $c will have the appropriate distr. It is possible to use the L<cumusumover|PDL::Ufunc/cumusumover> function to obtain cumulative probabilities from absolute probabilities. =for bad needs major (?) work to handles bad values =cut *vsearch_sample = \&PDL::vsearch_sample; =head2 vsearch_insert_leftmost =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the insertion point for values in a sorted array, inserting before duplicates. =for usage $idx = vsearch_insert_leftmost($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B<vsearch_insert_leftmost> returns an index I<I> for each value I<V> of C<$vals> equal to the leftmost position (by index in array) within C<$x> that I<V> may be inserted and still maintain the order in C<$x>. Insertion at index I<I> involves shifting elements I<I> and higher of C<$x> to the right by one and setting the now empty element at index I<I> to I<V>. I<I> has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem =item * if C<$x> is sorted in decreasing order V > x[0] : I = -1 x[0] >= V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem -1 =back If all elements of C<$x> are equal, i = 0 If C<$x> contains duplicated elements, I<I> is the index of the leftmost (by index in array) duplicate if I<V> matches. =for bad needs major (?) work to handles bad values =cut *vsearch_insert_leftmost = \&PDL::vsearch_insert_leftmost; =head2 vsearch_insert_rightmost =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the insertion point for values in a sorted array, inserting after duplicates. =for usage $idx = vsearch_insert_rightmost($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B<vsearch_insert_rightmost> returns an index I<I> for each value I<V> of C<$vals> equal to the rightmost position (by index in array) within C<$x> that I<V> may be inserted and still maintain the order in C<$x>. Insertion at index I<I> involves shifting elements I<I> and higher of C<$x> to the right by one and setting the now empty element at index I<I> to I<V>. I<I> has the following properties: =over =item * if C<$x> is sorted in increasing order V < x[0] : I = 0 x[0] <= V < x[-1] : I s.t. x[I-1] <= V < x[I] x[-1] <= V : I = $x->nelem =item * if C<$x> is sorted in decreasing order V >= x[0] : I = -1 x[0] > V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] > V : I = $x->nelem -1 =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I<I> is the index of the leftmost (by index in array) duplicate if I<V> matches. =for bad needs major (?) work to handles bad values =cut *vsearch_insert_rightmost = \&PDL::vsearch_insert_rightmost; =head2 vsearch_match =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Match values against a sorted array. =for usage $idx = vsearch_match($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B<vsearch_match> returns an index I<I> for each value I<V> of C<$vals>. If I<V> matches an element in C<$x>, I<I> is the index of that element, otherwise it is I<-( insertion_point + 1 )>, where I<insertion_point> is an index in C<$x> where I<V> may be inserted while maintaining the order in C<$x>. If C<$x> has duplicated values, I<I> may refer to any of them. =for bad needs major (?) work to handles bad values =cut *vsearch_match = \&PDL::vsearch_match; =head2 vsearch_bin_inclusive =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the index for values in a sorted array of bins, lower bound inclusive. =for usage $idx = vsearch_bin_inclusive($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is inclusive to the bin, its outer bound is exclusive to it. B<vsearch_bin_inclusive> returns an index I<I> for each value I<V> of C<$vals> I<I> has the following properties: =over =item * if C<$x> is sorted in increasing order V < x[0] : I = -1 x[0] <= V < x[-1] : I s.t. x[I] <= V < x[I+1] x[-1] <= V : I = $x->nelem - 1 =item * if C<$x> is sorted in decreasing order V >= x[0] : I = 0 x[0] > V >= x[-1] : I s.t. x[I+1] > V >= x[I] x[-1] > V : I = $x->nelem =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I<I> is the index of the righmost (by index in array) duplicate if I<V> matches. =for bad needs major (?) work to handles bad values =cut *vsearch_bin_inclusive = \&PDL::vsearch_bin_inclusive; =head2 vsearch_bin_exclusive =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the index for values in a sorted array of bins, lower bound exclusive. =for usage $idx = vsearch_bin_exclusive($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is exclusive to the bin, its upper bound is inclusive to it. B<vsearch_bin_exclusive> returns an index I<I> for each value I<V> of C<$vals>. I<I> has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = -1 x[0] < V <= x[-1] : I s.t. x[I] < V <= x[I+1] x[-1] < V : I = $x->nelem - 1 =item * if C<$x> is sorted in decreasing order V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I-1] >= V > x[I] x[-1] >= V : I = $x->nelem =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I<I> is the index of the righmost (by index in array) duplicate if I<V> matches. =for bad needs major (?) work to handles bad values =cut *vsearch_bin_exclusive = \&PDL::vsearch_bin_exclusive; =head2 interpolate =for sig Signature: (xi(); x(n); y(n); [o] yi(); int [o] err()) =for ref routine for 1D linear interpolation =for usage ( $yi, $err ) = interpolate($xi, $x, $y) Given a set of points C<($x,$y)>, use linear interpolation to find the values C<$yi> at a set of points C<$xi>. C<interpolate> uses a binary search to find the suspects, er..., interpolation indices and therefore abscissas (ie C<$x>) have to be I<strictly> ordered (increasing or decreasing). For interpolation at lots of closely spaced abscissas an approach that uses the last index found as a start for the next search can be faster (compare Numerical Recipes C<hunt> routine). Feel free to implement that on top of the binary search if you like. For out of bounds values it just does a linear extrapolation and sets the corresponding element of C<$err> to 1, which is otherwise 0. See also L<interpol|/interpol>, which uses the same routine, differing only in the handling of extrapolation - an error message is printed rather than returning an error piddle. =for bad needs major (?) work to handles bad values =cut *interpolate = \&PDL::interpolate; =head2 interpol =for sig Signature: (xi(); x(n); y(n); [o] yi()) =for ref routine for 1D linear interpolation =for usage $yi = interpol($xi, $x, $y) C<interpol> uses the same search method as L<interpolate|/interpolate>, hence C<$x> must be I<strictly> ordered (either increasing or decreasing). The difference occurs in the handling of out-of-bounds values; here an error message is printed. =cut # kept in for backwards compatability sub interpol ($$$;$) { my $xi = shift; my $x = shift; my $y = shift; my $yi; if ( $#_ == 0 ) { $yi = $_[0]; } else { $yi = PDL->null; } interpolate( $xi, $x, $y, $yi, my $err = PDL->null ); print "some values had to be extrapolated\n" if any $err; return $yi if $#_ == -1; } # sub: interpol() *PDL::interpol = \&interpol; =head2 interpND =for ref Interpolate values from an N-D piddle, with switchable method =for example $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2.2,3.5],[4.1,5.0]],[[6.0,7.4],[8,9]]); print $source->interpND( $index ); InterpND acts like L<indexND|PDL::Slices/indexND>, collapsing C<$index> by lookup into C<$source>; but it does interpolation rather than direct sampling. The interpolation method and boundary condition are switchable via an options hash. By default, linear or sample interpolation is used, with constant value outside the boundaries of the source pdl. No dataflow occurs, because in general the output is computed rather than indexed. All the interpolation methods treat the pixels as value-centered, so the C<sample> method will return C<< $a->(0) >> for coordinate values on the set [-0.5,0.5), and all methods will return C<< $a->(1) >> for a coordinate value of exactly 1. Recognized options: =over 3 =item method Values can be: =over 3 =item * 0, s, sample, Sample (default for integer source types) The nearest value is taken. Pixels are regarded as centered on their respective integer coordinates (no offset from the linear case). =item * 1, l, linear, Linear (default for floating point source types) The values are N-linearly interpolated from an N-dimensional cube of size 2. =item * 3, c, cube, cubic, Cubic The values are interpolated using a local cubic fit to the data. The fit is constrained to match the original data and its derivative at the data points. The second derivative of the fit is not continuous at the data points. Multidimensional datasets are interpolated by the successive-collapse method. (Note that the constraint on the first derivative causes a small amount of ringing around sudden features such as step functions). =item * f, fft, fourier, Fourier The source is Fourier transformed, and the interpolated values are explicitly calculated from the coefficients. The boundary condition option is ignored -- periodic boundaries are imposed. If you pass in the option "fft", and it is a list (ARRAY) ref, then it is a stash for the magnitude and phase of the source FFT. If the list has two elements then they are taken as already computed; otherwise they are calculated and put in the stash. =back =item b, bound, boundary, Boundary This option is passed unmodified into L<indexND|PDL::Slices/indexND>, which is used as the indexing engine for the interpolation. Some current allowed values are 'extend', 'periodic', 'truncate', and 'mirror' (default is 'truncate'). =item bad contains the fill value used for 'truncate' boundary. (default 0) =item fft An array ref whose associated list is used to stash the FFT of the source data, for the FFT method. =back =cut *interpND = *PDL::interpND; sub PDL::interpND { my $source = shift; my $index = shift; my $options = shift; barf 'Usage: interp_nd($source,$index,[{%options}])\n' if(defined $options and ref $options ne 'HASH'); my($opt) = (defined $options) ? $options : {}; my($method) = $opt->{m} || $opt->{meth} || $opt->{method} || $opt->{Method}; if(!defined $method) { $method = ($source->type <= zeroes(long,1)->type) ? 'sample' : 'linear'; } my($boundary) = $opt->{b} || $opt->{boundary} || $opt->{Boundary} || $opt->{bound} || $opt->{Bound} || 'extend'; my($bad) = $opt->{bad} || $opt->{Bad} || 0.0; if($method =~ m/^s(am(p(le)?)?)?/i) { return $source->range(PDL::Math::floor($index+0.5),0,$boundary); } elsif (($method eq 1) || $method =~ m/^l(in(ear)?)?/i) { ## key: (ith = index thread; cth = cube thread; sth = source thread) my $d = $index->dim(0); my $di = $index->ndims - 1; # Grab a 2-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor,2,$boundary); # (ith, cth, sth) # Reorder to put the cube dimensions in front and convert to a list $samp = $samp->reorder( $di .. $di+$d-1, 0 .. $di-1, $di+$d .. $samp->ndims-1) # (cth, ith, sth) ->clump($d); # (clst, ith, sth) # Enumerate the corners of an n-cube and convert to a list # (the 'x' is the normal perl repeat operator) my $crnr = PDL::Basic::ndcoords( (2) x $index->dim(0) ) # (index,cth) ->mv(0,-1)->clump($index->dim(0))->mv(-1,0); # (index, clst) # a & b are the weighting coefficients. my($a,$b); my($indexwhere); ($indexwhere = $index->where( 0 * $index )) .= -10; # Change NaN to invalid { my $bb = PDL::Math::floor($index); $a = ($index - $bb) -> dummy(1,$crnr->dim(1)); # index, clst, ith $b = ($bb + 1 - $index) -> dummy(1,$crnr->dim(1)); # index, clst, ith } # Use 1/0 corners to select which multiplier happens, multiply # 'em all together to get sample weights, and sum to get the answer. my $out0 = ( ($a * ($crnr==1) + $b * ($crnr==0)) #index, clst, ith -> prodover #clst, ith ); my $out = ($out0 * $samp)->sumover; # ith, sth # Work around BAD-not-being-contagious bug in PDL <= 2.6 bad handling code --CED 3-April-2013 if($PDL::Bad::Status and $source->badflag) { my $baddies = $samp->isbad->orover; $out = $out->setbadif($baddies); } return $out; } elsif(($method eq 3) || $method =~ m/^c(u(b(e|ic)?)?)?/i) { my ($d,@di) = $index->dims; my $di = $index->ndims - 1; # Grab a 4-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor - 1,4,$boundary) #ith, cth, sth ->reorder( $di .. $di+$d-1, 0..$di-1, $di+$d .. $source->ndims-1 ); # (cth, ith, sth) # Make a cube of the subpixel offsets, and expand its dims to # a 4-on-a-side N-1 cube, to match the slices of $samp (used below). my $b = $index - $index->floor; for my $i(1..$d-1) { $b = $b->dummy($i,4); } # Collapse by interpolation, one dimension at a time... for my $i(0..$d-1) { my $a0 = $samp->slice("(1)"); # Just-under-sample my $a1 = $samp->slice("(2)"); # Just-over-sample my $a1a0 = $a1 - $a0; my $gradient = 0.5 * ($samp->slice("2:3")-$samp->slice("0:1")); my $s0 = $gradient->slice("(0)"); # Just-under-gradient my $s1 = $gradient->slice("(1)"); # Just-over-gradient $bb = $b->slice("($i)"); # Collapse the sample... $samp = ( $a0 + $bb * ( $s0 + $bb * ( (3 * $a1a0 - 2*$s0 - $s1) + $bb * ( $s1 + $s0 - 2*$a1a0 ) ) ) ); # "Collapse" the subpixel offset... $b = $b->slice(":,($i)"); } return $samp; } elsif($method =~ m/^f(ft|ourier)?/i) { eval "use PDL::FFT;"; my $fftref = $opt->{fft}; $fftref = [] unless(ref $fftref eq 'ARRAY'); if(@$fftref != 2) { my $a = $source->copy; my $b = zeroes($source); fftnd($a,$b); $fftref->[0] = sqrt($a*$a+$b*$b) / $a->nelem; $fftref->[1] = - atan2($b,$a); } my $i; my $c = PDL::Basic::ndcoords($source); # (dim, source-dims) for $i(1..$index->ndims-1) { $c = $c->dummy($i,$index->dim($i)) } my $id = $index->ndims-1; my $phase = (($c * $index * 3.14159 * 2 / pdl($source->dims)) ->sumover) # (index-dims, source-dims) ->reorder($id..$id+$source->ndims-1,0..$id-1); # (src, index) my $phref = $fftref->[1]->copy; # (source-dims) my $mag = $fftref->[0]->copy; # (source-dims) for $i(1..$index->ndims-1) { $phref = $phref->dummy(-1,$index->dim($i)); $mag = $mag->dummy(-1,$index->dim($i)); } my $out = cos($phase + $phref ) * $mag; $out = $out->clump($source->ndims)->sumover; return $out; } else { barf("interpND: unknown method '$method'; valid ones are 'linear' and 'sample'.\n"); } } =head2 one2nd =for ref Converts a one dimensional index piddle to a set of ND coordinates =for usage @coords=one2nd($a, $indices) returns an array of piddles containing the ND indexes corresponding to the one dimensional list indices. The indices are assumed to correspond to array C<$a> clumped using C<clump(-1)>. This routine is used in the old vector form of L<whichND|/whichND>, but is useful on its own occasionally. Returned piddles have the L<indx|PDL::Core/indx> datatype. C<$indices> can have values larger than C<< $a->nelem >> but negative values in C<$indices> will not give the answer you expect. =for example pdl> $a=pdl [[[1,2],[-1,1]], [[0,-3],[3,2]]]; $c=$a->clump(-1) pdl> $maxind=maximum_ind($c); p $maxind; 6 pdl> print one2nd($a, maximum_ind($c)) 0 1 1 pdl> p $a->at(0,1,1) 3 =cut *one2nd = \&PDL::one2nd; sub PDL::one2nd { barf "Usage: one2nd \$array \$indices\n" if $#_ != 1; my ($a, $ind)=@_; my @dimension=$a->dims; $ind = indx($ind); my(@index); my $count=0; foreach (@dimension) { $index[$count++]=$ind % $_; $ind /= $_; } return @index; } =head2 which =for sig Signature: (mask(n); indx [o] inds(m)) =for ref Returns indices of non-zero values from a 1-D PDL =for usage $i = which($mask); returns a pdl with indices for all those elements that are nonzero in the mask. Note that the returned indices will be 1D. If you feed in a multidimensional mask, it will be flattened before the indices are calculated. See also L<whichND|/whichND> for multidimensional masks. If you want to index into the original mask or a similar piddle with output from C<which>, remember to flatten it before calling index: $data = random 5, 5; $idx = which $data > 0.5; # $idx is now 1D $bigsum = $data->flat->index($idx)->sum; # flatten before indexing Compare also L<where|/where> for similar functionality. SEE ALSO: L<which_both|/which_both> returns separately the indices of both zero and nonzero values in the mask. L<where|/where> returns associated values from a data PDL, rather than indices into the mask PDL. L<whichND|/whichND> returns N-D indices into a multidimensional PDL. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> $indx = which($x>6); p $indx [7 8 9] =for bad which processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub which { my ($this,$out) = @_; $this = $this->flat; $out = $this->nullcreate unless defined $out; PDL::_which_int($this,$out); return $out; } *PDL::which = \&which; *which = \&PDL::which; =head2 which_both =for sig Signature: (mask(n); indx [o] inds(m); indx [o]notinds(q)) =for ref Returns indices of zero and nonzero values in a mask PDL =for usage ($i, $c_i) = which_both($mask); This works just as L<which|/which>, but the complement of C<$i> will be in C<$c_i>. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> ($small, $big) = which_both ($x >= 5); p "$small\n $big" [5 6 7 8 9] [0 1 2 3 4] =for bad which_both processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub which_both { my ($this,$outi,$outni) = @_; $this = $this->flat; $outi = $this->nullcreate unless defined $outi; $outni = $this->nullcreate unless defined $outni; PDL::_which_both_int($this,$outi,$outni); return wantarray ? ($outi,$outni) : $outi; } *PDL::which_both = \&which_both; *which_both = \&PDL::which_both; =head2 where =for ref Use a mask to select values from one or more data PDLs C<where> accepts one or more data piddles and a mask piddle. It returns a list of output piddles, corresponding to the input data piddles. Each output piddle is a 1-dimensional list of values in its corresponding data piddle. The values are drawn from locations where the mask is nonzero. The output PDLs are still connected to the original data PDLs, for the purpose of dataflow. C<where> combines the functionality of L<which|/which> and L<index|PDL::Slices/index> into a single operation. BUGS: While C<where> works OK for most N-dimensional cases, it does not thread properly over (for example) the (N+1)th dimension in data that is compared to an N-dimensional mask. Use C<whereND> for that. =for usage $i = $x->where($x+5 > 0); # $i contains those elements of $x # where mask ($x+5 > 0) is 1 $i .= -5; # Set those elements (of $x) to -5. Together, these # commands clamp $x to a maximum of -5. It is also possible to use the same mask for several piddles with the same call: ($i,$j,$k) = where($x,$y,$z, $x+5>0); Note: C<$i> is always 1-D, even if C<$x> is E<gt>1-D. WARNING: The first argument (the values) and the second argument (the mask) currently have to have the exact same dimensions (or horrible things happen). You *cannot* thread over a smaller mask, for example. =cut sub PDL::where { barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; if($#_ == 1) { my($data,$mask) = @_; $data = $_[0]->clump(-1) if $_[0]->getndims>1; $mask = $_[1]->clump(-1) if $_[0]->getndims>1; return $data->index($mask->which()); } else { if($_[-1]->getndims > 1) { my $mask = $_[-1]->clump(-1)->which; return map {$_->clump(-1)->index($mask)} @_[0..$#_-1]; } else { my $mask = $_[-1]->which; return map {$_->index($mask)} @_[0..$#_-1]; } } } *where = \&PDL::where; =head2 whereND =for ref C<where> with support for ND masks and threading C<whereND> accepts one or more data piddles and a mask piddle. It returns a list of output piddles, corresponding to the input data piddles. The values are drawn from locations where the mask is nonzero. C<whereND> differs from C<where> in that the mask dimensionality is preserved which allows for proper threading of the selection operation over higher dimensions. As with C<where> the output PDLs are still connected to the original data PDLs, for the purpose of dataflow. =for usage $sdata = whereND $data, $mask ($s1, $s2, ..., $sn) = whereND $d1, $d2, ..., $dn, $mask where $data is M dimensional $mask is N < M dimensional dims($data) 1..N == dims($mask) 1..N with threading over N+1 to M dimensions =for example $data = sequence(4,3,2); # example data array $mask4 = (random(4)>0.5); # example 1-D mask array, has $n4 true values $mask43 = (random(4,3)>0.5); # example 2-D mask array, has $n43 true values $sdat4 = whereND $data, $mask4; # $sdat4 is a [$n4,3,2] pdl $sdat43 = whereND $data, $mask43; # $sdat43 is a [$n43,2] pdl Just as with C<where>, you can use the returned value in an assignment. That means that both of these examples are valid: # Used to create a new slice stored in $sdat4: $sdat4 = $data->whereND($mask4); $sdat4 .= 0; # Used in lvalue context: $data->whereND($mask4) .= 0; =cut sub PDL::whereND :lvalue { barf "Usage: whereND( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; my $mask = pop @_; # $mask has 0==false, 1==true my @to_return; my $n = PDL::sum($mask); foreach my $arr (@_) { my $sub_i = $mask * ones($arr); my $where_sub_i = PDL::where($arr, $sub_i); # count the number of dims in $mask and $arr # $mask = a b c d e f..... my @idims = dims($arr); # ...and pop off the number of dims in $mask foreach ( dims($mask) ) { shift(@idims) }; my $ndim = 0; foreach my $id ($n, @idims[0..($#idims-1)]) { $where_sub_i = $where_sub_i->splitdim($ndim++,$id) if $n>0; } push @to_return, $where_sub_i; } return (@to_return == 1) ? $to_return[0] : @to_return; } *whereND = \&PDL::whereND; =head2 whichND =for ref Return the coordinates of non-zero values in a mask. =for usage WhichND returns the N-dimensional coordinates of each nonzero value in a mask PDL with any number of dimensions. The returned values arrive as an array-of-vectors suitable for use in L<indexND|PDL::Slices/indexND> or L<range|PDL::Slices/range>. $coords = whichND($mask); returns a PDL containing the coordinates of the elements that are non-zero in C<$mask>, suitable for use in indexND. The 0th dimension contains the full coordinate listing of each point; the 1st dimension lists all the points. For example, if $mask has rank 4 and 100 matching elements, then $coords has dimension 4x100. If no such elements exist, then whichND returns a structured empty PDL: an Nx0 PDL that contains no values (but matches, threading-wise, with the vectors that would be produced if such elements existed). DEPRECATED BEHAVIOR IN LIST CONTEXT: whichND once delivered different values in list context than in scalar context, for historical reasons. In list context, it returned the coordinates transposed, as a collection of 1-PDLs (one per dimension) in a list. This usage is deprecated in PDL 2.4.10, and will cause a warning to be issued every time it is encountered. To avoid the warning, you can set the global variable "$PDL::whichND" to 's' to get scalar behavior in all contexts, or to 'l' to get list behavior in list context. In later versions of PDL, the deprecated behavior will disappear. Deprecated list context whichND expressions can be replaced with: @list = $a->whichND->mv(0,-1)->dog; SEE ALSO: L<which|/which> finds coordinates of nonzero values in a 1-D mask. L<where|/where> extracts values from a data PDL that are associated with nonzero values in a mask PDL. =for example pdl> $a=sequence(10,10,3,4) pdl> ($x, $y, $z, $w)=whichND($a == 203); p $x, $y, $z, $w [3] [0] [2] [0] pdl> print $a->at(list(cat($x,$y,$z,$w))) 203 =cut *whichND = \&PDL::whichND; sub PDL::whichND { my $mask = shift; $mask = PDL::pdl('PDL',$mask) unless(UNIVERSAL::isa($mask,'PDL')); # List context: generate a perl list by dimension if(wantarray) { if(!defined($PDL::whichND)) { printf STDERR "whichND: WARNING - list context deprecated. Set \$PDL::whichND. Details in pod."; } elsif($PDL::whichND =~ m/l/i) { # old list context enabled by setting $PDL::whichND to 'l' my $ind=($mask->clump(-1))->which; return $mask->one2nd($ind); } # if $PDL::whichND does not contain 'l' or 'L', fall through to scalar context } # Scalar context: generate an N-D index piddle unless($mask->nelem) { return PDL::new_from_specification('PDL',indx,$mask->ndims,0); } unless($mask->getndims) { return $mask ? pdl(indx,0) : PDL::new_from_specification('PDL',indx,0); } $ind = $mask->flat->which->dummy(0,$mask->getndims)->make_physical; if($ind->nelem==0) { # In the empty case, explicitly return the correct type of structured empty return PDL::new_from_specification('PDL',indx,$mask->ndims, 0); } my $mult = ones($mask->getndims)->long; my @mdims = $mask->dims; my $i; for $i(0..$#mdims-1) { # use $tmp for 5.005_03 compatibility (my $tmp = $mult->index($i+1)) .= $mult->index($i)*$mdims[$i]; } for $i(0..$#mdims) { my($s) = $ind->index($i); $s /= $mult->index($i); $s %= $mdims[$i]; } return $ind; } =head2 setops =for ref Implements simple set operations like union and intersection =for usage Usage: $set = setops($a, <OPERATOR>, $b); The operator can be C<OR>, C<XOR> or C<AND>. This is then applied to C<$a> viewed as a set and C<$b> viewed as a set. Set theory says that a set may not have two or more identical elements, but setops takes care of this for you, so C<$a=pdl(1,1,2)> is OK. The functioning is as follows: =over =item C<OR> The resulting vector will contain the elements that are either in C<$a> I<or> in C<$b> or both. This is the union in set operation terms =item C<XOR> The resulting vector will contain the elements that are either in C<$a> or C<$b>, but not in both. This is Union($a, $b) - Intersection($a, $b) in set operation terms. =item C<AND> The resulting vector will contain the intersection of C<$a> and C<$b>, so the elements that are in both C<$a> and C<$b>. Note that for convenience this operation is also aliased to L<intersect|intersect>. =back It should be emphasized that these routines are used when one or both of the sets C<$a>, C<$b> are hard to calculate or that you get from a separate subroutine. Finally IDL users might be familiar with Craig Markwardt's C<cmset_op.pro> routine which has inspired this routine although it was written independently However the present routine has a few less options (but see the examples) =for example You will very often use these functions on an index vector, so that is what we will show here. We will in fact something slightly silly. First we will find all squares that are also cubes below 10000. Create a sequence vector: pdl> $x = sequence(10000) Find all odd and even elements: pdl> ($even, $odd) = which_both( ($x % 2) == 0) Find all squares pdl> $squares= which(ceil(sqrt($x)) == floor(sqrt($x))) Find all cubes (being careful with roundoff error!) pdl> $cubes= which(ceil($x**(1.0/3.0)) == floor($x**(1.0/3.0)+1e-6)) Then find all squares that are cubes: pdl> $both = setops($squares, 'AND', $cubes) And print these (assumes that C<PDL::NiceSlice> is loaded!) pdl> p $x($both) [0 1 64 729 4096] Then find all numbers that are either cubes or squares, but not both: pdl> $cube_xor_square = setops($squares, 'XOR', $cubes) pdl> p $cube_xor_square->nelem() 112 So there are a total of 112 of these! Finally find all odd squares: pdl> $odd_squares = setops($squares, 'AND', $odd) Another common occurrence is to want to get all objects that are in C<$a> and in the complement of C<$b>. But it is almost always best to create the complement explicitly since the universe that both are taken from is not known. Thus use L<which_both|which_both> if possible to keep track of complements. If this is impossible the best approach is to make a temporary: This creates an index vector the size of the universe of the sets and set all elements in C<$b> to 0 pdl> $tmp = ones($n_universe); $tmp($b) .= 0; This then finds the complement of C<$b> pdl> $C_b = which($tmp == 1); and this does the final selection: pdl> $set = setops($a, 'AND', $C_b) =cut *setops = \&PDL::setops; sub PDL::setops { my ($a, $op, $b)=@_; # Check that $a and $b are 1D. if ($a->ndims() > 1 || $b->ndims() > 1) { warn 'setops: $a and $b must be 1D - flattening them!'."\n"; $a = $a->flat; $b = $b->flat; } #Make sure there are no duplicate elements. $a=$a->uniq; $b=$b->uniq; my $result; if ($op eq 'OR') { # Easy... $result = uniq(append($a, $b)); } elsif ($op eq 'XOR') { # Make ordered list of set union. my $union = append($a, $b)->qsort; # Index lists. my $s1=zeroes(byte, $union->nelem()); my $s2=zeroes(byte, $union->nelem()); # Find indices which are duplicated - these are to be excluded # # We do this by comparing x with x shifted each way. my $i1 = which($union != rotate($union, 1)); my $i2 = which($union != rotate($union, -1)); # # We then mark/mask these in the s1 and s2 arrays to indicate which ones # are not equal to their neighbours. # my $ts; ($ts = $s1->index($i1)) .= 1 if $i1->nelem() > 0; ($ts = $s2->index($i2)) .= 1 if $i2->nelem() > 0; my $inds=which($s1 == $s2); if ($inds->nelem() > 0) { return $union->index($inds); } else { return $inds; } } elsif ($op eq 'AND') { # The intersection of the arrays. # Make ordered list of set union. my $union = append($a, $b)->qsort; return $union->where($union == rotate($union, -1)); } else { print "The operation $op is not known!"; return -1; } } =head2 intersect =for ref Calculate the intersection of two piddles =for usage Usage: $set = intersect($a, $b); This routine is merely a simple interface to L<setops|setops>. See that for more information =for example Find all numbers less that 100 that are of the form 2*y and 3*x pdl> $x=sequence(100) pdl> $factor2 = which( ($x % 2) == 0) pdl> $factor3 = which( ($x % 3) == 0) pdl> $ii=intersect($factor2, $factor3) pdl> p $x($ii) [0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96] =cut *intersect = \&PDL::intersect; sub PDL::intersect { return setops($_[0], 'AND', $_[1]); } ; =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Craig DeForest (deforest@boulder.swri.edu) and Jarle Brinchmann (jarle@astro.up.pt) All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. Updated for CPAN viewing compatibility by David Mertens. =cut # Exit with OK status 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Slatec.pm�������������������������������������������������������������������0000644�0601750�0601001�00000074707�13110402055�014070� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Slatec; @EXPORT_OK = qw( eigsys matinv polyfit polycoef polyvalue PDL::PP svdc PDL::PP poco PDL::PP geco PDL::PP gefa PDL::PP podi PDL::PP gedi PDL::PP gesl PDL::PP rs PDL::PP ezffti PDL::PP ezfftf PDL::PP ezfftb PDL::PP pcoef PDL::PP pvalue PDL::PP chim PDL::PP chic PDL::PP chsp PDL::PP chfd PDL::PP chfe PDL::PP chia PDL::PP chid PDL::PP chcm PDL::PP chbs PDL::PP polfit ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Slatec ; =head1 NAME PDL::Slatec - PDL interface to the slatec numerical programming library =head1 SYNOPSIS use PDL::Slatec; ($ndeg, $r, $ierr, $a) = polyfit($x, $y, $w, $maxdeg, $eps); =head1 DESCRIPTION This module serves the dual purpose of providing an interface to parts of the slatec library and showing how to interface PDL to an external library. Using this library requires a fortran compiler; the source for the routines is provided for convenience. Currently available are routines to: manipulate matrices; calculate FFT's; fit data using polynomials; and interpolate/integrate data using piecewise cubic Hermite interpolation. =head2 Piecewise cubic Hermite interpolation (PCHIP) PCHIP is the slatec package of routines to perform piecewise cubic Hermite interpolation of data. It features software to produce a monotone and "visually pleasing" interpolant to monotone data. According to Fritsch & Carlson ("Monotone piecewise cubic interpolation", SIAM Journal on Numerical Analysis 17, 2 (April 1980), pp. 238-246), such an interpolant may be more reasonable than a cubic spline if the data contains both "steep" and "flat" sections. Interpolation of cumulative probability distribution functions is another application. These routines are cryptically named (blame FORTRAN), beginning with 'ch', and accept either float or double piddles. Most of the routines require an integer parameter called C<check>; if set to 0, then no checks on the validity of the input data are made, otherwise these checks are made. The value of C<check> can be set to 0 if a routine such as L<chim|/chim> has already been successfully called. =over 4 =item * If not known, estimate derivative values for the points using the L<chim|/chim>, L<chic|/chic>, or L<chsp|/chsp> routines (the following routines require both the function (C<f>) and derivative (C<d>) values at a set of points (C<x>)). =item * Evaluate, integrate, or differentiate the resulting PCH function using the routines: L<chfd|/chfd>; L<chfe|/chfe>; L<chia|/chia>; L<chid|/chid>. =item * If desired, you can check the monotonicity of your data using L<chcm|/chcm>. =back =cut =head1 FUNCTIONS =cut =head2 eigsys =for ref Eigenvalues and eigenvectors of a real positive definite symmetric matrix. =for usage ($eigvals,$eigvecs) = eigsys($mat) Note: this function should be extended to calculate only eigenvalues if called in scalar context! =head2 matinv =for ref Inverse of a square matrix =for usage ($inv) = matinv($mat) =head2 polyfit Convenience wrapper routine about the C<polfit> C<slatec> function. Separates supplied arguments and return values. =for ref Fit discrete data in a least squares sense by polynomials in one variable. Handles threading correctly--one can pass in a 2D PDL (as C<$y>) and it will pass back a 2D PDL, the rows of which are the polynomial regression results (in C<$r> corresponding to the rows of $y. =for usage ($ndeg, $r, $ierr, $a, $coeffs, $rms) = polyfit($x, $y, $w, $maxdeg, [$eps]); $coeffs = polyfit($x,$y,$w,$maxdeg,[$eps]); where on input: C<$x> and C<$y> are the values to fit to a polynomial. C<$w> are weighting factors C<$maxdeg> is the maximum degree of polynomial to use and C<$eps> is the required degree of fit. and the output switches on list/scalar context. In list context: C<$ndeg> is the degree of polynomial actually used C<$r> is the values of the fitted polynomial C<$ierr> is a return status code, and C<$a> is some working array or other (preserved for historical purposes) C<$coeffs> is the polynomial coefficients of the best fit polynomial. C<$rms> is the rms error of the fit. In scalar context, only $coeffs is returned. Historically, C<$eps> was modified in-place to be a return value of the rms error. This usage is deprecated, and C<$eps> is an optional parameter now. It is still modified if present. C<$a> is a working array accessible to Slatec - you can feed it to several other Slatec routines to get nice things out. It does not thread correctly and should probably be fixed by someone. If you are reading this, that someone might be you. =for bad This version of polyfit handles bad values correctly. Bad values in $y are ignored for the fit and give computed values on the fitted curve in the return. Bad values in $x or $w are ignored for the fit and result in bad elements in the output. =head2 polycoef Convenience wrapper routine around the C<pcoef> C<slatec> function. Separates supplied arguments and return values. =for ref Convert the C<polyfit>/C<polfit> coefficients to Taylor series form. =for usage $tc = polycoef($l, $c, $a); =head2 polyvalue Convenience wrapper routine around the C<pvalue> C<slatec> function. Separates supplied arguments and return values. For multiple input x positions, a corresponding y position is calculated. The derivatives PDL is one dimensional (of size C<nder>) if a single x position is supplied, two dimensional if more than one x position is supplied. =for ref Use the coefficients generated by C<polyfit> (or C<polfit>) to evaluate the polynomial fit of degree C<l>, along with the first C<nder> of its derivatives, at a specified point. =for usage ($yfit, $yp) = polyvalue($l, $nder, $x, $a); =head2 detslatec =for ref compute the determinant of an invertible matrix =for example $mat = zeroes(5,5); $mat->diagonal(0,1) .= 1; # unity matrix $det = detslatec $mat; Usage: =for usage $determinant = detslatec $matrix; =for sig Signature: detslatec(mat(n,m); [o] det()) C<detslatec> computes the determinant of an invertible matrix and barfs if the matrix argument provided is non-invertible. The matrix threads as usual. This routine was previously known as C<det> which clashes now with L<det|PDL::MatrixOps/det> which is provided by L<PDL::MatrixOps>. =head2 fft =for ref Fast Fourier Transform =for example $v_in = pdl(1,0,1,0); ($azero,$a,$b) = PDL::Slatec::fft($v_in); C<PDL::Slatec::fft> is a convenience wrapper for L<ezfftf|ezfftf>, and performs a Fast Fourier Transform on an input vector C<$v_in>. The return values are the same as for L<ezfftf|ezfftf>. =head2 rfft =for ref reverse Fast Fourier Transform =for example $v_out = PDL::Slatec::rfft($azero,$a,$b); print $v_in, $vout [1 0 1 0] [1 0 1 0] C<PDL::Slatec::rfft> is a convenience wrapper for L<ezfftb|ezfftb>, and performs a reverse Fast Fourier Transform. The input is the same as the output of L<PDL::Slatec::fft|/PDL::Slatec::fft>, and the output of C<rfft> is a data vector, similar to what is input into L<PDL::Slatec::fft|/PDL::Slatec::fft>. =cut use PDL::Core; use PDL::Basic; use PDL::Primitive; use PDL::Ufunc; use strict; # Note: handles only real symmetric positive-definite. *eigsys = \&PDL::eigsys; sub PDL::eigsys { my($h) = @_; $h = float($h); rs($h, (my $eigval=PDL->null), (long (pdl (1))),(my $eigmat=PDL->null), (my $fvone = PDL->null),(my $fvtwo = PDL->null), (my $errflag=PDL->null) ); # print $covar,$eigval,$eigmat,$fvone,$fvtwo,$errflag; if(sum($errflag) > 0) { barf("Non-positive-definite matrix given to eigsys: $h\n"); } return ($eigval,$eigmat); } *matinv = \&PDL::matinv; sub PDL::matinv { my($m) = @_; my(@dims) = $m->dims; # Keep from dumping core (FORTRAN does no error checking) barf("matinv requires a 2-D square matrix") unless( @dims >= 2 && $dims[0] == $dims[1] ); $m = $m->copy(); # Make sure we don't overwrite :( gefa($m,(my $ipvt=null),(my $info=null)); if(sum($info) > 0) { barf("Uninvertible matrix given to inv: $m\n"); } gedi($m,$ipvt,(pdl 0,0),(null),(long( pdl (1)))); $m; } *detslatec = \&PDL::detslatec; sub PDL::detslatec { my($m) = @_; $m = $m->copy(); # Make sure we don't overwrite :( gefa($m,(my $ipvt=null),(my $info=null)); if(sum($info) > 0) { barf("Uninvertible matrix given to inv: $m\n"); } gedi($m,$ipvt,(my $det=null),(null),(long( pdl (10)))); return $det->slice('(0)')*10**$det->slice('(1)'); } sub prepfft { my($n) = @_; my $tmp = PDL->zeroes(float(),$n*3+15); $n = pdl $n; ezffti($n,$tmp); return $tmp; } sub fft (;@) { my($v) = @_; my $ws = prepfft($v->getdim(0)); ezfftf($v,(my $az = PDL->null), (my $a = PDL->null), (my $b = PDL->null), $ws); return ($az,$a,$b); } sub rfft { my($az,$a,$b) = @_; my $ws = prepfft($a->getdim(0)); my $v = $a->copy(); ezfftb($v,$az,$a,$b,$ws); return $v; } # polynomial fitting routines # simple wrappers around the SLATEC implementations *polyfit = \&PDL::polyfit; sub PDL::polyfit { barf 'Usage: polyfit($x, $y, $w, $maxdeg, [$eps]);' unless (@_ == 5 || @_==4 ); my ($x_in, $y_in, $w_in, $maxdeg_in, $eps_in) = @_; # if $w_in does not match the data vectors ($x_in, $y_in), then we can resize # it to match the size of $y_in : $w_in = $w_in + $y_in->zeros; # Create the output arrays my $r = PDL->null; # A array needs some work space my $sz = ((3 * $x_in->getdim(0)) + (3*$maxdeg_in) + 3); # Buffer size called for by Slatec my @otherdims = $_[0]->dims; shift @otherdims; # Thread dims my $a = PDL::new_from_specification('PDL',$x_in->type,$sz,@otherdims); my $coeffs = PDL::new_from_specification('PDL',$x_in->type, $maxdeg_in + 1, @otherdims); my $ierr = PDL->null; my $ndeg = PDL->null; # Now call polfit my $rms = pdl($eps_in); polfit($x_in, $y_in, $w_in, $maxdeg_in, $ndeg, $rms, $r, $ierr, $a, $coeffs); # Preserve historic compatibility by flowing rms error back into the argument if( UNIVERSAL::isa($eps_in,'PDL') ){ $eps_in .= $rms; } # Return the arrays if(wantarray) { return ($ndeg, $r, $ierr, $a, $coeffs, $rms ); } else { return $coeffs; } } *polycoef = \&PDL::polycoef; sub PDL::polycoef { barf 'Usage: polycoef($l, $c, $a);' unless @_ == 3; # Allocate memory for return PDL # Simply l + 1 but cant see how to get PP to do this - TJ # Not sure the return type since I do not know # where PP will get the information from my $tc = PDL->zeroes( abs($_[0]) + 1 ); # Run the slatec routine pcoef($_[0], $_[1], $tc, $_[2]); # Return results return $tc; } *polyvalue = \&PDL::polyvalue; sub PDL::polyvalue { barf 'Usage: polyvalue($l, $nder, $x, $a);' unless @_ == 4; # Two output arrays my $yfit = PDL->null; # This one must be preallocated and must take into account # the size of $x if greater than 1 my $yp; if ($_[2]->getdim(0) == 1) { $yp = $_[2]->zeroes($_[1]); } else { $yp = $_[2]->zeroes($_[1], $_[2]->getdim(0)); } # Run the slatec function pvalue($_[0], $_[2], $yfit, $yp, $_[3]); # Returns return ($yfit, $yp); } =head2 svdc =for sig Signature: (x(n,p);[o]s(p);[o]e(p);[o]u(n,p);[o]v(p,p);[o]work(n);int job();int [o]info()) =for ref singular value decomposition of a matrix =for bad svdc does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *svdc = \&PDL::svdc; =head2 poco =for sig Signature: (a(n,n);rcond();[o]z(n);int [o]info()) Factor a real symmetric positive definite matrix and estimate the condition number of the matrix. =for bad poco does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *poco = \&PDL::poco; =head2 geco =for sig Signature: (a(n,n);int [o]ipvt(n);[o]rcond();[o]z(n)) Factor a matrix using Gaussian elimination and estimate the condition number of the matrix. =for bad geco does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *geco = \&PDL::geco; =head2 gefa =for sig Signature: (a(n,n);int [o]ipvt(n);int [o]info()) =for ref Factor a matrix using Gaussian elimination. =for bad gefa does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gefa = \&PDL::gefa; =head2 podi =for sig Signature: (a(n,n);[o]det(two=2);int job()) Compute the determinant and inverse of a certain real symmetric positive definite matrix using the factors computed by L<poco|/poco>. =for bad podi does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *podi = \&PDL::podi; =head2 gedi =for sig Signature: (a(n,n);int [o]ipvt(n);[o]det(two=2);[o]work(n);int job()) Compute the determinant and inverse of a matrix using the factors computed by L<geco|/geco> or L<gefa|/gefa>. =for bad gedi does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gedi = \&PDL::gedi; =head2 gesl =for sig Signature: (a(lda,n);int ipvt(n);b(n);int job()) Solve the real system C<A*X=B> or C<TRANS(A)*X=B> using the factors computed by L<geco|/geco> or L<gefa|/gefa>. =for bad gesl does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *gesl = \&PDL::gesl; =head2 rs =for sig Signature: (a(n,n);[o]w(n);int matz();[o]z(n,n);[t]fvone(n);[t]fvtwo(n);int [o]ierr()) This subroutine calls the recommended sequence of subroutines from the eigensystem subroutine package (EISPACK) to find the eigenvalues and eigenvectors (if desired) of a REAL SYMMETRIC matrix. =for bad rs does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rs = \&PDL::rs; =head2 ezffti =for sig Signature: (int n();[o]wsave(foo)) Subroutine ezffti initializes the work array C<wsave()> which is used in both L<ezfftf|/ezfftf> and L<ezfftb|/ezfftb>. The prime factorization of C<n> together with a tabulation of the trigonometric functions are computed and stored in C<wsave()>. =for bad ezffti does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ezffti = \&PDL::ezffti; =head2 ezfftf =for sig Signature: (r(n);[o]azero();[o]a(n);[o]b(n);wsave(foo)) =for ref =for bad ezfftf does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ezfftf = \&PDL::ezfftf; =head2 ezfftb =for sig Signature: ([o]r(n);azero();a(n);b(n);wsave(foo)) =for ref =for bad ezfftb does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *ezfftb = \&PDL::ezfftb; =head2 pcoef =for sig Signature: (int l();c();[o]tc(bar);a(foo)) Convert the C<polfit> coefficients to Taylor series form. C<c> and C<a()> must be of the same type. =for bad pcoef does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pcoef = \&PDL::pcoef; =head2 pvalue =for sig Signature: (int l();x();[o]yfit();[o]yp(nder);a(foo)) Use the coefficients generated by C<polfit> to evaluate the polynomial fit of degree C<l>, along with the first C<nder> of its derivatives, at a specified point. C<x> and C<a> must be of the same type. =for bad pvalue does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pvalue = \&PDL::pvalue; =head2 chim =for sig Signature: (x(n);f(n);[o]d(n);int [o]ierr()) =for ref Calculate the derivatives of (x,f(x)) using cubic Hermite interpolation. Calculate the derivatives at the given set of points (C<$x,$f>, where C<$x> is strictly increasing). The resulting set of points - C<$x,$f,$d>, referred to as the cubic Hermite representation - can then be used in other functions, such as L<chfe|/chfe>, L<chfd|/chfd>, and L<chia|/chia>. The boundary conditions are compatible with monotonicity, and if the data are only piecewise monotonic, the interpolant will have an extremum at the switch points; for more control over these issues use L<chic|/chic>. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E<gt> 0 if there were C<ierr> switches in the direction of monotonicity (data still valid). =item * -1 if C<nelem($x) E<lt> 2>. =item * -3 if C<$x> is not strictly increasing. =back =for bad chim does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chim = \&PDL::chim; =head2 chic =for sig Signature: (int ic(two=2);vc(two=2);mflag();x(n);f(n);[o]d(n);wk(nwk);int [o]ierr()) =for ref Calculate the derivatives of (x,f(x)) using cubic Hermite interpolation. Calculate the derivatives at the given points (C<$x,$f>, where C<$x> is strictly increasing). Control over the boundary conditions is given by the C<$ic> and C<$vc> piddles, and the value of C<$mflag> determines the treatment of points where monotoncity switches direction. A simpler, more restricted, interface is available using L<chim|/chim>. The first and second elements of C<$ic> determine the boundary conditions at the start and end of the data respectively. If the value is 0, then the default condition, as used by L<chim|/chim>, is adopted. If greater than zero, no adjustment for monotonicity is made, otherwise if less than zero the derivative will be adjusted. The allowed magnitudes for C<ic(0)> are: =over 4 =item * 1 if first derivative at C<x(0)> is given in C<vc(0)>. =item * 2 if second derivative at C<x(0)> is given in C<vc(0)>. =item * 3 to use the 3-point difference formula for C<d(0)>. (Reverts to the default b.c. if C<n E<lt> 3>) =item * 4 to use the 4-point difference formula for C<d(0)>. (Reverts to the default b.c. if C<n E<lt> 4>) =item * 5 to set C<d(0)> so that the second derivative is continuous at C<x(1)>. (Reverts to the default b.c. if C<n E<lt> 4>) =back The values for C<ic(1)> are the same as above, except that the first-derivative value is stored in C<vc(1)> for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. Set C<$mflag = 0> if interpolant is required to be monotonic in each interval, regardless of the data. This causes C<$d> to be set to 0 at all switch points. Set C<$mflag> to be non-zero to use a formula based on the 3-point difference formula at switch points. If C<$mflag E<gt> 0>, then the interpolant at swich points is forced to not deviate from the data by more than C<$mflag*dfloc>, where C<dfloc> is the maximum of the change of C<$f> on this interval and its two immediate neighbours. If C<$mflag E<lt> 0>, no such control is to be imposed. The piddle C<$wk> is only needed for work space. However, I could not get it to work as a temporary variable, so you must supply it; it is a 1D piddle with C<2*n> elements. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * 1 if C<ic(0) E<lt> 0> and C<d(0)> had to be adjusted for monotonicity. =item * 2 if C<ic(1) E<lt> 0> and C<d(n-1)> had to be adjusted for monotonicity. =item * 3 if both 1 and 2 are true. =item * -1 if C<n E<lt> 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<abs(ic(0)) E<gt> 5>. =item * -5 if C<abs(ic(1)) E<gt> 5>. =item * -6 if both -4 and -5 are true. =item * -7 if C<nwk E<lt> 2*(n-1)>. =back =for bad chic does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chic = \&PDL::chic; =head2 chsp =for sig Signature: (int ic(two=2);vc(two=2);x(n);f(n);[o]d(n);wk(nwk);int [o]ierr()) =for ref Calculate the derivatives of (x,f(x)) using cubic spline interpolation. Calculate the derivatives, using cubic spline interpolation, at the given points (C<$x,$f>), with the specified boundary conditions. Control over the boundary conditions is given by the C<$ic> and C<$vc> piddles. The resulting values - C<$x,$f,$d> - can be used in all the functions which expect a cubic Hermite function. The first and second elements of C<$ic> determine the boundary conditions at the start and end of the data respectively. The allowed values for C<ic(0)> are: =over 4 =item * 0 to set C<d(0)> so that the third derivative is continuous at C<x(1)>. =item * 1 if first derivative at C<x(0)> is given in C<vc(0>). =item * 2 if second derivative at C<x(0>) is given in C<vc(0)>. =item * 3 to use the 3-point difference formula for C<d(0)>. (Reverts to the default b.c. if C<n E<lt> 3>.) =item * 4 to use the 4-point difference formula for C<d(0)>. (Reverts to the default b.c. if C<n E<lt> 4>.) =back The values for C<ic(1)> are the same as above, except that the first-derivative value is stored in C<vc(1)> for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. The piddle C<$wk> is only needed for work space. However, I could not get it to work as a temporary variable, so you must supply it; it is a 1D piddle with C<2*n> elements. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C<nelem($x) E<lt> 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<ic(0) E<lt> 0> or C<ic(0) E<gt> 4>. =item * -5 if C<ic(1) E<lt> 0> or C<ic(1) E<gt> 4>. =item * -6 if both of the above are true. =item * -7 if C<nwk E<lt> 2*n>. =item * -8 in case of trouble solving the linear system for the interior derivative values. =back =for bad chsp does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chsp = \&PDL::chsp; =head2 chfd =for sig Signature: (x(n);f(n);d(n);int check();xe(ne);[o]fe(ne);[o]de(ne);int [o]ierr()) =for ref Interpolate function and derivative values. Given a piecewise cubic Hermite function - such as from L<chim|/chim> - evaluate the function (C<$fe>) and derivative (C<$de>) at a set of points (C<$xe>). If function values alone are required, use L<chfe|/chfe>. Set C<check> to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E<gt>0 if extrapolation was performed at C<ierr> points (data still valid). =item * -1 if C<nelem($x) E<lt> 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<nelem($xe) E<lt> 1>. =item * -5 if an error has occurred in a lower-level routine, which should never happen. =back =for bad chfd does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chfd = \&PDL::chfd; =head2 chfe =for sig Signature: (x(n);f(n);d(n);int check();xe(ne);[o]fe(ne);int [o]ierr()) =for ref Interpolate function values. Given a piecewise cubic Hermite function - such as from L<chim|/chim> - evaluate the function (C<$fe>) at a set of points (C<$xe>). If derivative values are also required, use L<chfd|/chfd>. Set C<check> to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E<gt>0 if extrapolation was performed at C<ierr> points (data still valid). =item * -1 if C<nelem($x) E<lt> 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<nelem($xe) E<lt> 1>. =back =for bad chfe does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chfe = \&PDL::chfe; =head2 chia =for sig Signature: (x(n);f(n);d(n);int check();a();b();[o]ans();int [o]ierr()) =for ref Integrate (x,f(x)) over arbitrary limits. Evaluate the definite integral of a a piecewise cubic Hermite function over an arbitrary interval, given by C<[$a,$b]>. See L<chid|/chid> if the integration limits are data points. Set C<check> to 0 to skip checks on the input data. The values of C<$a> and C<$b> do not have to lie within C<$x>, although the resulting integral value will be highly suspect if they are not. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * 1 if C<$a> lies outside C<$x>. =item * 2 if C<$b> lies outside C<$x>. =item * 3 if both 1 and 2 are true. =item * -1 if C<nelem($x) E<lt> 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if an error has occurred in a lower-level routine, which should never happen. =back =for bad chia does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chia = \&PDL::chia; =head2 chid =for sig Signature: (x(n);f(n);d(n);int check();int ia();int ib();[o]ans();int [o]ierr()) =for ref Integrate (x,f(x)) between data points. Evaluate the definite integral of a a piecewise cubic Hermite function between C<x($ia)> and C<x($ib)>. See L<chia|/chia> for integration between arbitrary limits. Although using a fortran routine, the values of C<$ia> and C<$ib> are zero offset. Set C<check> to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C<nelem($x) E<lt> 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<$ia> or C<$ib> is out of range. =back =for bad chid does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chid = \&PDL::chid; =head2 chcm =for sig Signature: (x(n);f(n);d(n);int check();int [o]ismon(n);int [o]ierr()) =for ref Check the given piecewise cubic Hermite function for monotonicity. The outout piddle C<$ismon> indicates over which intervals the function is monotonic. Set C<check> to 0 to skip checks on the input data. For the data interval C<[x(i),x(i+1)]>, the values of C<ismon(i)> can be: =over 4 =item * -3 if function is probably decreasing =item * -1 if function is strictly decreasing =item * 0 if function is constant =item * 1 if function is strictly increasing =item * 2 if function is non-monotonic =item * 3 if function is probably increasing =back If C<abs(ismon(i)) == 3>, the derivative values are near the boundary of the monotonicity region. A small increase produces non-monotonicity, whereas a decrease produces strict monotonicity. The above applies to C<i = 0 .. nelem($x)-1>. The last element of C<$ismon> indicates whether the entire function is monotonic over $x. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C<n E<lt> 2>. =item * -3 if C<$x> is not strictly increasing. =back =for bad chcm does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chcm = \&PDL::chcm; =head2 chbs =for sig Signature: (x(n);f(n);d(n);int knotyp();int nknots();t(tsize);[o]bcoef(bsize);int [o]ndim();int [o]kord();int [o]ierr()) =for ref Piecewise Cubic Hermite function to B-Spline converter. The resulting B-spline representation of the data (i.e. C<nknots>, C<t>, C<bcoeff>, C<ndim>, and C<kord>) can be evaluated by C<bvalu> (which is currently not available). Array sizes: C<tsize = 2*n + 4>, C<bsize = 2*n>, and C<ndim = 2*n>. C<knotyp> is a flag which controls the knot sequence. The knot sequence C<t> is normally computed from C<$x> by putting a double knot at each C<x> and setting the end knot pairs according to the value of C<knotyp> (where C<m = ndim = 2*n>): =over =item * 0 - Quadruple knots at the first and last points. =item * 1 - Replicate lengths of extreme subintervals: C<t( 0 ) = t( 1 ) = x(0) - (x(1)-x(0))> and C<t(m+3) = t(m+2) = x(n-1) + (x(n-1)-x(n-2))> =item * 2 - Periodic placement of boundary knots: C<t( 0 ) = t( 1 ) = x(0) - (x(n-1)-x(n-2))> and C<t(m+3) = t(m+2) = x(n) + (x(1)-x(0))> =item * E<lt>0 - Assume the C<nknots> and C<t> were set in a previous call. =back C<nknots> is the number of knots and may be changed by the routine. If C<knotyp E<gt>= 0>, C<nknots> will be set to C<ndim+4>, otherwise it is an input variable, and an error will occur if its value is not equal to C<ndim+4>. C<t> is the array of C<2*n+4> knots for the B-representation and may be changed by the routine. If C<knotyp E<gt>= 0>, C<t> will be changed so that the interior double knots are equal to the x-values and the boundary knots set as indicated above, otherwise it is assumed that C<t> was set by a previous call (no check is made to verify that the data forms a legitimate knot sequence). Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -4 if C<knotyp E<gt> 2>. =item * -5 if C<knotyp E<lt> 0> and C<nknots != 2*n + 4>. =back =for bad chbs does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *chbs = \&PDL::chbs; =head2 polfit =for sig Signature: (x(n); y(n); w(n); int maxdeg(); int [o]ndeg(); [o]eps(); [o]r(n); int [o]ierr(); [o]a(foo); [o]coeffs(bar);[t]xtmp(n);[t]ytmp(n);[t]wtmp(n);[t]rtmp(n)) Fit discrete data in a least squares sense by polynomials in one variable. C<x()>, C<y()> and C<w()> must be of the same type. This version handles bad values appropriately =for bad polfit processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *polfit = \&PDL::polfit; =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Copyright (C) 2000 Tim Jenness, Doug Burke. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ; # Exit with OK status 1; ���������������������������������������������������������PDL-2.018/GENERATED/PDL/Slices.pm�������������������������������������������������������������������0000644�0601750�0601001�00000135374�13110402056�014076� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Slices; @EXPORT_OK = qw( PDL::PP affineinternal PDL::PP s_identity PDL::PP index PDL::PP index1d PDL::PP index2d indexND indexNDb PDL::PP rangeb PDL::PP rld PDL::PP rle PDL::PP flowconvert PDL::PP converttypei PDL::PP _clump_int PDL::PP xchg PDL::PP mv PDL::PP oslice using PDL::PP affine PDL::PP diagonalI PDL::PP lags PDL::PP splitdim PDL::PP rotate PDL::PP threadI PDL::PP identvaff PDL::PP unthread dice dice_axis slice PDL::PP sliceb ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Slices ; =head1 NAME PDL::Slices -- Indexing, slicing, and dicing =head1 SYNOPSIS use PDL; $a = ones(3,3); $b = $a->slice('-1:0,(1)'); $c = $a->dummy(2); =head1 DESCRIPTION This package provides many of the powerful PerlDL core index manipulation routines. These routines mostly allow two-way data flow, so you can modify your data in the most convenient representation. For example, you can make a 1000x1000 unit matrix with $a = zeroes(1000,1000); $a->diagonal(0,1) ++; which is quite efficient. See L<PDL::Indexing> and L<PDL::Tips> for more examples. Slicing is so central to the PDL language that a special compile-time syntax has been introduced to handle it compactly; see L<PDL::NiceSlice> for details. PDL indexing and slicing functions usually include two-way data flow, so that you can separate the actions of reshaping your data structures and modifying the data themselves. Two special methods, L<copy|copy> and L<sever|sever>, help you control the data flow connection between related variables. $b = $a->slice("1:3"); # Slice maintains a link between $a and $b. $b += 5; # $a is changed! If you want to force a physical copy and no data flow, you can copy or sever the slice expression: $b = $a->slice("1:3")->copy; $b += 5; # $a is not changed. $b = $a->slice("1:3")->sever; $b += 5; # $a is not changed. The difference between C<sever> and C<copy> is that sever acts on (and returns) its argument, while copy produces a disconnected copy. If you say $b = $a->slice("1:3"); $c = $b->sever; then the variables C<$b> and C<$c> point to the same object but with C<-E<gt>copy> they would not. =cut use PDL::Core ':Internal'; use Scalar::Util 'blessed'; =head1 FUNCTIONS =cut *affineinternal = \&PDL::affineinternal; =head2 s_identity =for sig Signature: (P(); C()) =for ref Internal vaffine identity function. =for bad s_identity processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *s_identity = \&PDL::s_identity; =head2 index =for sig Signature: (a(n); indx ind(); [oca] c()) =for ref C<index>, C<index1d>, and C<index2d> provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C<index> uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C<index1d> uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C<index2d> works like C<index> but uses separate piddles for X and Y coordinates. For more general N-dimensional indexing, see the L<PDL::NiceSlice|PDL::NiceSlice> syntax or L<PDL::Slices|PDL::Slices> (in particular C<slice>, C<indexND>, and C<range>). =back These functions are two-way, i.e. after $c = $a->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$a>. C<index> provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $a = xvals(10,10)+10*yvals(10,10); $b = $a->index(3); $c = $a->index(9-xvals(10)); puts a single column from C<$a> into C<$b>, and puts a single element from each column of C<$a> into C<$c>. If you want to extract multiple columns from an array in one operation, see L<dice|/dice> or L<indexND|/indexND>. =for bad index barfs if any of the index values are bad. =cut *index = \&PDL::index; =head2 index1d =for sig Signature: (a(n); indx ind(m); [oca] c(m)) =for ref C<index>, C<index1d>, and C<index2d> provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C<index> uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C<index1d> uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C<index2d> works like C<index> but uses separate piddles for X and Y coordinates. For more general N-dimensional indexing, see the L<PDL::NiceSlice|PDL::NiceSlice> syntax or L<PDL::Slices|PDL::Slices> (in particular C<slice>, C<indexND>, and C<range>). =back These functions are two-way, i.e. after $c = $a->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$a>. C<index> provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $a = xvals(10,10)+10*yvals(10,10); $b = $a->index(3); $c = $a->index(9-xvals(10)); puts a single column from C<$a> into C<$b>, and puts a single element from each column of C<$a> into C<$c>. If you want to extract multiple columns from an array in one operation, see L<dice|/dice> or L<indexND|/indexND>. =for bad index1d propagates BAD index elements to the output variable. =cut *index1d = \&PDL::index1d; =head2 index2d =for sig Signature: (a(na,nb); indx inda(); indx indb(); [oca] c()) =for ref C<index>, C<index1d>, and C<index2d> provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C<index> uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C<index1d> uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C<index2d> works like C<index> but uses separate piddles for X and Y coordinates. For more general N-dimensional indexing, see the L<PDL::NiceSlice|PDL::NiceSlice> syntax or L<PDL::Slices|PDL::Slices> (in particular C<slice>, C<indexND>, and C<range>). =back These functions are two-way, i.e. after $c = $a->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$a>. C<index> provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $a = xvals(10,10)+10*yvals(10,10); $b = $a->index(3); $c = $a->index(9-xvals(10)); puts a single column from C<$a> into C<$b>, and puts a single element from each column of C<$a> into C<$c>. If you want to extract multiple columns from an array in one operation, see L<dice|/dice> or L<indexND|/indexND>. =for bad index2d barfs if either of the index values are bad. =cut *index2d = \&PDL::index2d; =head2 indexNDb =for ref Backwards-compatibility alias for indexND =head2 indexND =for ref Find selected elements in an N-D piddle, with optional boundary handling =for example $out = $source->indexND( $index, [$method] ) $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); print $source->indexND( $index ); [ [23 45] [67 89] ] IndexND collapses C<$index> by lookup into C<$source>. The 0th dimension of C<$index> is treated as coordinates in C<$source>, and the return value has the same dimensions as the rest of C<$index>. The returned elements are looked up from C<$source>. Dataflow works -- propagated assignment flows back into C<$source>. IndexND and IndexNDb were originally separate routines but they are both now implemented as a call to L<range|/range>, and have identical syntax to one another. =cut sub PDL::indexND { my($source,$index, $boundary) = @_; return PDL::range($source,$index,undef,$boundary); } *PDL::indexNDb = \&PDL::indexND; sub PDL::range { my($source,$ind,$sz,$bound) = @_; my $index = PDL->pdl($ind); my $size = defined($sz) ? PDL->pdl($sz) : undef; # Handle empty PDL case: return a properly constructed Empty. if($index->isempty) { my @sdims= $source->dims; splice(@sdims, 0, $index->dim(0) + ($index->dim(0)==0)); # added term is to treat Empty[0] like a single empty coordinate unshift(@sdims, $size->list) if(defined($size)); return PDL->new_from_specification(0 x ($index->ndims-1), @sdims); } $index = $index->dummy(0,1) unless $index->ndims; # Pack boundary string if necessary if(defined $bound) { if(ref $bound eq 'ARRAY') { my ($s,$el); foreach $el(@$bound) { barf "Illegal boundary value '$el' in range" unless( $el =~ m/^([0123fFtTeEpPmM])/ ); $s .= $1; } $bound = $s; } elsif($bound !~ m/^[0123ftepx]+$/ && $bound =~ m/^([0123ftepx])/i ) { $bound = $1; } } no warnings; # shut up about passing undef into rangeb $source->rangeb($index,$size,$bound); } =head2 rangeb =for sig Signature: (P(); C(); SV *index; SV *size; SV *boundary) =for ref Engine for L<range|/range> =for example Same calling convention as L<range|/range>, but you must supply all parameters. C<rangeb> is marginally faster as it makes a direct PP call, avoiding the perl argument-parsing step. =head2 range =for ref Extract selected chunks from a source piddle, with boundary conditions =for example $out = $source->range($index,[$size,[$boundary]]) Returns elements or rectangular slices of the original piddle, indexed by the C<$index> piddle. C<$source> is an N-dimensional piddle, and C<$index> is a piddle whose first dimension has size up to N. Each row of C<$index> is treated as coordinates of a single value or chunk from C<$source>, specifying the location(s) to extract. If you specify a single index location, then range is essentially an expensive slice, with controllable boundary conditions. B<INPUTS> C<$index> and C<$size> can be piddles or array refs such as you would feed to L<zeroes|PDL::Core/zeroes> and its ilk. If C<$index>'s 0th dimension has size higher than the number of dimensions in C<$source>, then C<$source> is treated as though it had trivial dummy dimensions of size 1, up to the required size to be indexed by C<$index> -- so if your source array is 1-D and your index array is a list of 3-vectors, you get two dummy dimensions of size 1 on the end of your source array. You can extract single elements or N-D rectangular ranges from C<$source>, by setting C<$size>. If C<$size> is undef or zero, then you get a single sample for each row of C<$index>. This behavior is similar to L<indexNDb|/indexNDb>, which is in fact implemented as a call to L<range|/range>. If C<$size> is positive then you get a range of values from C<$source> at each location, and the output has extra dimensions allocated for them. C<$size> can be a scalar, in which case it applies to all dimensions, or an N-vector, in which case each element is applied independently to the corresponding dimension in C<$source>. See below for details. C<$boundary> is a number, string, or list ref indicating the type of boundary conditions to use when ranges reach the edge of C<$source>. If you specify no boundary conditions the default is to forbid boundary violations on all axes. If you specify exactly one boundary condition, it applies to all axes. If you specify more (as elements of a list ref, or as a packed string, see below), then they apply to dimensions in the order in which they appear, and the last one applies to all subsequent dimensions. (This is less difficult than it sounds; see the examples below). =over 3 =item 0 (synonyms: 'f','forbid') B<(default)> Ranges are not allowed to cross the boundary of the original PDL. Disallowed ranges throw an error. The errors are thrown at evaluation time, not at the time of the range call (this is the same behavior as L<slice|/slice>). =item 1 (synonyms: 't','truncate') Values outside the original piddle get BAD if you've got bad value support compiled into your PDL and set the badflag for the source PDL; or 0 if you haven't (you must set the badflag if you want BADs for out of bound values, otherwise you get 0). Reverse dataflow works OK for the portion of the child that is in-bounds. The out-of-bounds part of the child is reset to (BAD|0) during each dataflow operation, but execution continues. =item 2 (synonyms: 'e','x','extend') Values that would be outside the original piddle point instead to the nearest allowed value within the piddle. See the CAVEAT below on mappings that are not single valued. =item 3 (synonyms: 'p','periodic') Periodic boundary conditions apply: the numbers in $index are applied, strict-modulo the corresponding dimensions of $source. This is equivalent to duplicating the $source piddle throughout N-D space. See the CAVEAT below about mappings that are not single valued. =item 4 (synonyms: 'm','mirror') Mirror-reflection periodic boundary conditions apply. See the CAVEAT below about mappings that are not single valued. =back The boundary condition identifiers all begin with unique characters, so you can feed in multiple boundary conditions as either a list ref or a packed string. (The packed string is marginally faster to run). For example, the four expressions [0,1], ['forbid','truncate'], ['f','t'], and 'ft' all specify that violating the boundary in the 0th dimension throws an error, and all other dimensions get truncated. If you feed in a single string, it is interpreted as a packed boundary array if all of its characters are valid boundary specifiers (e.g. 'pet'), but as a single word-style specifier if they are not (e.g. 'forbid'). B<OUTPUT> The output threads over both C<$index> and C<$source>. Because implicit threading can happen in a couple of ways, a little thought is needed. The returned dimension list is stacked up like this: (index thread dims), (index dims (size)), (source thread dims) The first few dims of the output correspond to the extra dims of C<$index> (beyond the 0 dim). They allow you to pick out individual ranges from a large, threaded collection. The middle few dims of the output correspond to the size dims specified in C<$size>, and contain the range of values that is extracted at each location in C<$source>. Every nonzero element of C<$size> is copied to the dimension list here, so that if you feed in (for example) C<$size = [2,0,1]> you get an index dim list of C<(2,1)>. The last few dims of the output correspond to extra dims of C<$source> beyond the number of dims indexed by C<$index>. These dims act like ordinary thread dims, because adding more dims to C<$source> just tacks extra dims on the end of the output. Each source thread dim ranges over the entire corresponding dim of C<$source>. B<Dataflow>: Dataflow is bidirectional. B<Examples>: Here are basic examples of C<range> operation, showing how to get ranges out of a small matrix. The first few examples show extraction and selection of individual chunks. The last example shows how to mark loci in the original matrix (using dataflow). pdl> $src = 10*xvals(10,5)+yvals(10,5) pdl> print $src->range([2,3]) # Cut out a single element 23 pdl> print $src->range([2,3],1) # Cut out a single 1x1 block [ [23] ] pdl> print $src->range([2,3], [2,1]) # Cut a 2x1 chunk [ [23 33] ] pdl> print $src->range([[2,3]],[2,1]) # Trivial list of 1 chunk [ [ [23] [33] ] ] pdl> print $src->range([[2,3],[0,1]], [2,1]) # two 2x1 chunks [ [ [23 1] [33 11] ] ] pdl> # A 2x2 collection of 2x1 chunks pdl> print $src->range([[[1,1],[2,2]],[[2,3],[0,1]]],[2,1]) [ [ [ [11 22] [23 1] ] [ [21 32] [33 11] ] ] ] pdl> $src = xvals(5,3)*10+yvals(5,3) pdl> print $src->range(3,1) # Thread over y dimension in $src [ [30] [31] [32] ] pdl> $src = zeroes(5,4); pdl> $src->range(pdl([2,3],[0,1]),pdl(2,1)) .= xvals(2,2,1) + 1 pdl> print $src [ [0 0 0 0 0] [2 2 0 0 0] [0 0 0 0 0] [0 0 1 1 0] ] B<CAVEAT>: It's quite possible to select multiple ranges that intersect. In that case, modifying the ranges doesn't have a guaranteed result in the original PDL -- the result is an arbitrary choice among the valid values. For some things that's OK; but for others it's not. In particular, this doesn't work: pdl> $photon_list = new PDL::RandVar->sample(500)->reshape(2,250)*10 pdl> histogram = zeroes(10,10) pdl> histogram->range($photon_list,1)++; #not what you wanted The reason is that if two photons land in the same bin, then that bin doesn't get incremented twice. (That may get fixed in a later version...) B<PERMISSIVE RANGING>: If C<$index> has too many dimensions compared to C<$source>, then $source is treated as though it had dummy dimensions of size 1, up to the required number of dimensions. These virtual dummy dimensions have the usual boundary conditions applied to them. If the 0 dimension of C<$index> is ludicrously large (if its size is more than 5 greater than the number of dims in the source PDL) then range will insist that you specify a size in every dimension, to make sure that you know what you're doing. That catches a common error with range usage: confusing the initial dim (which is usually small) with another index dim (perhaps of size 1000). If the index variable is Empty, then range() always returns the Empty PDL. If the index variable is not Empty, indexing it always yields a boundary violation. All non-barfing conditions are treated as truncation, since there are no actual data to return. B<EFFICIENCY>: Because C<range> isn't an affine transformation (it involves lookup into a list of N-D indices), it is somewhat memory-inefficient for long lists of ranges, and keeping dataflow open is much slower than for affine transformations (which don't have to copy data around). Doing operations on small subfields of a large range is inefficient because the engine must flow the entire range back into the original PDL with every atomic perl operation, even if you only touch a single element. One way to speed up such code is to sever your range, so that PDL doesn't have to copy the data with each operation, then copy the elements explicitly at the end of your loop. Here's an example that labels each region in a range sequentially, using many small operations rather than a single xvals assignment: ### How to make a collection of small ops run fast with range... $a = $data->range($index, $sizes, $bound)->sever; $aa = $data->range($index, $sizes, $bound); map { $a($_ - 1) .= $_; } (1..$a->nelem); # Lots of little ops $aa .= $a; C<range> is a perl front-end to a PP function, C<rangeb>. Calling C<rangeb> is marginally faster but requires that you include all arguments. DEVEL NOTES * index thread dimensions are effectively clumped internally. This makes it easier to loop over the index array but a little more brain-bending to tease out the algorithm. =cut =for bad rangeb processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rangeb = \&PDL::rangeb; =head2 rld =for sig Signature: (indx a(n); b(n); [o]c(m)) =for ref Run-length decode a vector Given a vector C<$a> of the numbers of instances of values C<$b>, run-length decode to C<$c>. =for example rld($a,$b,$c=null); =for bad rld does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::rld { my ($a,$b) = @_; my ($c); if ($#_ == 2) { $c = $_[2]; } else { # XXX Need to improve emulation of threading in auto-generating c my ($size) = $a->sumover->max; my (@dims) = $a->dims; shift @dims; $c = $b->zeroes($size,@dims); } &PDL::_rld_int($a,$b,$c); $c; } *rld = \&PDL::rld; =head2 rle =for sig Signature: (c(n); indx [o]a(m); [o]b(m)) =for ref Run-length encode a vector Given vector C<$c>, generate a vector C<$a> with the number of each element, and a vector C<$b> of the unique values. New in PDL 2.017, only the elements up to the first instance of C<0> in C<$a> are returned, which makes the common use case of a 1-dimensional C<$c> simpler. For threaded operation, C<$a> and C<$b> will be large enough to hold the largest row of C<$a>, and only the elements up to the first instance of C<0> in each row of C<$a> should be considered. =for example $c = floor(4*random(10)); rle($c,$a=null,$b=null); #or ($a,$b) = rle($c); #for $c of shape [10, 4]: $c = floor(4*random(10,4)); ($a,$b) = rle($c); #to see the results of each row one at a time: foreach (0..$c->dim(1)-1){ my ($as,$bs) = ($a(:,($_)),$b(:,($_))); my ($ta,$tb) = where($as,$bs,$as!=0); #only the non-zero elements of $a print $c(:,($_)) . " rle==> " , ($ta,$tb) , "\trld==> " . rld($ta,$tb) . "\n"; } =for bad rle does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::rle { my $c = shift; my ($a,$b) = @_==2 ? @_ : (null,null); &PDL::_rle_int($c,$a,$b); my $max_ind = ($c->ndims<2) ? ($a!=0)->sumover-1 : ($a!=0)->clump(1..$a->ndims-1)->sumover->max-1; return ($a->slice("0:$max_ind"),$b->slice("0:$max_ind")); } *rle = \&PDL::rle; *flowconvert = \&PDL::flowconvert; *converttypei = \&PDL::converttypei; *_clump_int = \&PDL::_clump_int; =head2 xchg =for sig Signature: (P(); C(); int n1; int n2) =for ref exchange two dimensions Negative dimension indices count from the end. The command =for example $b = $a->xchg(2,3); creates C<$b> to be like C<$a> except that the dimensions 2 and 3 are exchanged with each other i.e. $b->at(5,3,2,8) == $a->at(5,3,8,2) =for bad xchg does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *xchg = \&PDL::xchg; =head2 reorder =for ref Re-orders the dimensions of a PDL based on the supplied list. Similar to the L<xchg|/xchg> method, this method re-orders the dimensions of a PDL. While the L<xchg|/xchg> method swaps the position of two dimensions, the reorder method can change the positions of many dimensions at once. =for usage # Completely reverse the dimension order of a 6-Dim array. $reOrderedPDL = $pdl->reorder(5,4,3,2,1,0); The argument to reorder is an array representing where the current dimensions should go in the new array. In the above usage, the argument to reorder C<(5,4,3,2,1,0)> indicates that the old dimensions (C<$pdl>'s dims) should be re-arranged to make the new pdl (C<$reOrderPDL>) according to the following: Old Position New Position ------------ ------------ 5 0 4 1 3 2 2 3 1 4 0 5 You do not need to specify all dimensions, only a complete set starting at position 0. (Extra dimensions are left where they are). This means, for example, that you can reorder() the X and Y dimensions of an image, and not care whether it is an RGB image with a third dimension running across color plane. =for example Example: pdl> $a = sequence(5,3,2); # Create a 3-d Array pdl> p $a [ [ [ 0 1 2 3 4] [ 5 6 7 8 9] [10 11 12 13 14] ] [ [15 16 17 18 19] [20 21 22 23 24] [25 26 27 28 29] ] ] pdl> p $a->reorder(2,1,0); # Reverse the order of the 3-D PDL [ [ [ 0 15] [ 5 20] [10 25] ] [ [ 1 16] [ 6 21] [11 26] ] [ [ 2 17] [ 7 22] [12 27] ] [ [ 3 18] [ 8 23] [13 28] ] [ [ 4 19] [ 9 24] [14 29] ] ] The above is a simple example that could be duplicated by calling C<$a-E<gt>xchg(0,2)>, but it demonstrates the basic functionality of reorder. As this is an index function, any modifications to the result PDL will change the parent. =cut sub PDL::reorder { my ($pdl,@newDimOrder) = @_; my $arrayMax = $#newDimOrder; #Error Checking: if( $pdl->getndims < scalar(@newDimOrder) ){ my $errString = "PDL::reorder: Number of elements (".scalar(@newDimOrder).") in newDimOrder array exceeds\n"; $errString .= "the number of dims in the supplied PDL (".$pdl->getndims.")"; barf($errString); } # Check to make sure all the dims are within bounds for my $i(0..$#newDimOrder) { my $dim = $newDimOrder[$i]; if($dim < 0 || $dim > $#newDimOrder) { my $errString = "PDL::reorder: Dim index $newDimOrder[$i] out of range in position $i\n(range is 0-$#newDimOrder)"; barf($errString); } } # Checking that they are all present and also not duplicated is done by thread() [I think] # a quicker way to do the reorder return $pdl->thread(@newDimOrder)->unthread(0); } =head2 mv =for sig Signature: (P(); C(); int n1; int n2) =for ref move a dimension to another position The command =for example $b = $a->mv(4,1); creates C<$b> to be like C<$a> except that the dimension 4 is moved to the place 1, so: $b->at(1,2,3,4,5,6) == $a->at(1,5,2,3,4,6); The other dimensions are moved accordingly. Negative dimension indices count from the end. =for bad mv does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *mv = \&PDL::mv; =head2 oslice =for sig Signature: (P(); C(); char* str) =for ref DEPRECATED: 'oslice' is the original 'slice' routine in pre-2.006_006 versions of PDL. It is left here for reference but will disappear in PDL 3.000 Extract a rectangular slice of a piddle, from a string specifier. C<slice> was the original Swiss-army-knife PDL indexing routine, but is largely superseded by the L<NiceSlice|PDL::NiceSlice> source prefilter and its associated L<nslice|PDL::Core/nslice> method. It is still used as the basic underlying slicing engine for L<nslice|PDL::Core/nslice>, and is especially useful in particular niche applications. =for example $a->slice('1:3'); # return the second to fourth elements of $a $a->slice('3:1'); # reverse the above $a->slice('-2:1'); # return last-but-one to second elements of $a The argument string is a comma-separated list of what to do for each dimension. The current formats include the following, where I<a>, I<b> and I<c> are integers and can take legal array index values (including -1 etc): =over 8 =item : takes the whole dimension intact. =item '' (nothing) is a synonym for ":" (This means that C<$a-E<gt>slice(':,3')> is equal to C<$a-E<gt>slice(',3')>). =item a slices only this value out of the corresponding dimension. =item (a) means the same as "a" by itself except that the resulting dimension of length one is deleted (so if C<$a> has dims C<(3,4,5)> then C<$a-E<gt>slice(':,(2),:')> has dimensions C<(3,5)> whereas C<$a-E<gt>slice(':,2,:')> has dimensions C<(3,1,5))>. =item a:b slices the range I<a> to I<b> inclusive out of the dimension. =item a:b:c slices the range I<a> to I<b>, with step I<c> (i.e. C<3:7:2> gives the indices C<(3,5,7)>). This may be confusing to Matlab users but several other packages already use this syntax. =item '*' inserts an extra dimension of width 1 and =item '*a' inserts an extra (dummy) dimension of width I<a>. =back An extension is planned for a later stage allowing C<$a-E<gt>slice('(=1),(=1|5:8),3:6(=1),4:6')> to express a multidimensional diagonal of C<$a>. Trivial out-of-bounds slicing is allowed: if you slice a source dimension that doesn't exist, but only index the 0th element, then C<slice> treats the source as if there were a dummy dimension there. The following are all equivalent: xvals(5)->dummy(1,1)->slice('(2),0') # Add dummy dim, then slice xvals(5)->slice('(2),0') # Out-of-bounds slice adds dim. xvals(5)->slice((2),0) # NiceSlice syntax xvals(5)->((2))->dummy(0,1) # NiceSlice syntax This is an error: xvals(5)->slice('(2),1') # nontrivial out-of-bounds slice dies Because slicing doesn't directly manipulate the source and destination pdl -- it just sets up a transformation between them -- indexing errors often aren't reported until later. This is either a bug or a feature, depending on whether you prefer error-reporting clarity or speed of execution. =for bad oslice does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *oslice = \&PDL::oslice; =head2 using =for ref Returns array of column numbers requested =for usage line $pdl->using(1,2); Plot, as a line, column 1 of C<$pdl> vs. column 2 =for example pdl> $pdl = rcols("file"); pdl> line $pdl->using(1,2); =cut *using = \&PDL::using; sub PDL::using { my ($x,@ind)=@_; @ind = list $ind[0] if (blessed($ind[0]) && $ind[0]->isa('PDL')); foreach (@ind) { $_ = $x->slice("($_)"); } @ind; } *affine = \&PDL::affine; =head2 diagonalI =for sig Signature: (P(); C(); SV *list) =for ref Returns the multidimensional diagonal over the specified dimensions. The diagonal is placed at the first (by number) dimension that is diagonalized. The other diagonalized dimensions are removed. So if C<$a> has dimensions C<(5,3,5,4,6,5)> then after =for example $b = $a->diagonal(0,2,5); the piddle C<$b> has dimensions C<(5,3,4,6)> and C<$b-E<gt>at(2,1,0,1)> refers to C<$a-E<gt>at(2,1,2,0,1,2)>. NOTE: diagonal doesn't handle threadids correctly. XXX FIX =for bad diagonalI does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *diagonalI = \&PDL::diagonalI; =head2 lags =for sig Signature: (P(); C(); int nthdim; int step; int n) =for ref Returns a piddle of lags to parent. Usage: =for usage $lags = $a->lags($nthdim,$step,$nlags); I.e. if C<$a> contains [0,1,2,3,4,5,6,7] then =for example $b = $a->lags(0,2,2); is a (5,2) matrix [2,3,4,5,6,7] [0,1,2,3,4,5] This order of returned indices is kept because the function is called "lags" i.e. the nth lag is n steps behind the original. C<$step> and C<$nlags> must be positive. C<$nthdim> can be negative and will then be counted from the last dim backwards in the usual way (-1 = last dim). =for bad lags does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *lags = \&PDL::lags; =head2 splitdim =for sig Signature: (P(); C(); int nthdim; int nsp) =for ref Splits a dimension in the parent piddle (opposite of L<clump|PDL::Core/clump>) After =for example $b = $a->splitdim(2,3); the expression $b->at(6,4,x,y,3,6) == $a->at(6,4,x+3*y) is always true (C<x> has to be less than 3). =for bad splitdim does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *splitdim = \&PDL::splitdim; =head2 rotate =for sig Signature: (x(n); indx shift(); [oca]y(n)) =for ref Shift vector elements along with wrap. Flows data back&forth. =for bad rotate does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *rotate = \&PDL::rotate; =head2 threadI =for sig Signature: (P(); C(); int id; SV *list) =for ref internal Put some dimensions to a threadid. =for example $b = $a->threadI(0,1,5); # thread over dims 1,5 in id 1 =for bad threadI does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *threadI = \&PDL::threadI; =head2 identvaff =for sig Signature: (P(); C()) =for ref A vaffine identity transformation (includes thread_id copying). Mainly for internal use. =for bad identvaff does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *identvaff = \&PDL::identvaff; =head2 unthread =for sig Signature: (P(); C(); int atind) =for ref All threaded dimensions are made real again. See [TBD Doc] for details and examples. =for bad unthread does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *unthread = \&PDL::unthread; =head2 dice =for ref Dice rows/columns/planes out of a PDL using indexes for each dimension. This function can be used to extract irregular subsets along many dimension of a PDL, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! This method is similar in functionality to the L<slice|/slice> method, but L<slice|/slice> requires that contiguous ranges or ranges with constant offset be extracted. ( i.e. L<slice|/slice> requires ranges of the form C<1,2,3,4,5> or C<2,4,6,8,10>). Because of this restriction, L<slice|/slice> is more memory efficient and slightly faster than dice =for usage $slice = $data->dice([0,2,6],[2,1,6]); # Dicing a 2-D array The arguments to dice are arrays (or 1D PDLs) for each dimension in the PDL. These arrays are used as indexes to which rows/columns/cubes,etc to dice-out (or extract) from the C<$data> PDL. Use C<X> to select all indices along a given dimension (compare also L<mslice|PDL::Core/mslice>). As usual (in slicing methods) trailing dimensions can be omitted implying C<X>'es for those. =for example pdl> $a = sequence(10,4) pdl> p $a [ [ 0 1 2 3 4 5 6 7 8 9] [10 11 12 13 14 15 16 17 18 19] [20 21 22 23 24 25 26 27 28 29] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $a->dice([1,2],[0,3]) # Select columns 1,2 and rows 0,3 [ [ 1 2] [31 32] ] pdl> p $a->dice(X,[0,3]) [ [ 0 1 2 3 4 5 6 7 8 9] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $a->dice([0,2,5]) [ [ 0 2 5] [10 12 15] [20 22 25] [30 32 35] ] As this is an index function, any modifications to the slice change the parent (use the C<.=> operator). =cut sub PDL::dice { my $self = shift; my @dim_indexes = @_; # array of dimension indexes # Check that the number of dim indexes <= # number of dimensions in the PDL my $no_indexes = scalar(@dim_indexes); my $noDims = $self->getndims; barf("PDL::dice: Number of index arrays ($no_indexes) not equal to the dimensions of the PDL ($noDims") if $no_indexes > $noDims; my $index; my $pdlIndex; my $outputPDL=$self; my $indexNo = 0; # Go thru each index array and dice the input PDL: foreach $index(@dim_indexes){ $outputPDL = $outputPDL->dice_axis($indexNo,$index) unless !ref $index && $index eq 'X'; $indexNo++; } return $outputPDL; } *dice = \&PDL::dice; =head2 dice_axis =for ref Dice rows/columns/planes from a single PDL axis (dimension) using index along a specified axis This function can be used to extract irregular subsets along any dimension, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! =for usage $slice = $data->dice_axis($axis,$index); =for example pdl> $a = sequence(10,4) pdl> $idx = pdl(1,2) pdl> p $a->dice_axis(0,$idx) # Select columns [ [ 1 2] [11 12] [21 22] [31 32] ] pdl> $t = $a->dice_axis(1,$idx) # Select rows pdl> $t.=0 pdl> p $a [ [ 0 1 2 3 4 5 6 7 8 9] [ 0 0 0 0 0 0 0 0 0 0] [ 0 0 0 0 0 0 0 0 0 0] [30 31 32 33 34 35 36 37 38 39] ] The trick to using this is that the index selects elements along the dimensions specified, so if you have a 2D image C<axis=0> will select certain C<X> values - i.e. extract columns As this is an index function, any modifications to the slice change the parent. =cut sub PDL::dice_axis { my($self,$axis,$idx) = @_; # Convert to PDLs: array refs using new, otherwise use topdl: my $ix = (ref($idx) eq 'ARRAY') ? ref($self)->new($idx) : ref($self)->topdl($idx); my $n = $self->getndims; my $a = $ix->getndims; barf("index_axis: index must be <=1D") if $a>1; return $self->mv($axis,0)->index1d($ix)->mv(0,$axis); } *dice_axis = \&PDL::dice_axis; =head2 slice =for usage $slice = $data->slice([2,3],'x',[2,2,0],"-1:1:-1", "*3"); =for ref Extract rectangular slices of a piddle, from a string specifier, an array ref specifier, or a combination. C<slice> is the main method for extracting regions of PDLs and manipulating their dimensionality. You can call it directly or via he L<NiceSlice|PDL::NiceSlice> source prefilter that extends Perl syntax o include array slicing. C<slice> can extract regions along each dimension of a source PDL, subsample or reverse those regions, dice each dimension by selecting a list of locations along it, or basic PDL indexing routine. The selected subfield remains connected to the original PDL via dataflow. In most cases this neither allocates more memory nor slows down subsequent operations on either of the two connected PDLs. You pass in a list of arguments. Each term in the list controls the disposition of one axis of the source PDL and/or returned PDL. Each term can be a string-format cut specifier, a list ref that gives the same information without recourse to string manipulation, or a PDL with up to 1 dimension giving indices along that axis that should be selected. If you want to pass in a single string specifier for the entire operation, you can pass in a comma-delimited list as the first argument. C<slice> detects this condition and splits the string into a regular argument list. This calling style is fully backwards compatible with C<slice> calls from before PDL 2.006. B<STRING SYNTAX> If a particular argument to C<slice> is a string, it is parsed as a selection, an affine slice, or a dummy dimension depending on the form. Leading or trailing whitespace in any part of each specifier is ignored (though it is not ignored within numbers). =over 3 =item C<< '' >>, C<< : >>, or C<< X >> -- keep The empty string, C<:>, or C<X> cause the entire corresponding dimension to be kept unchanged. =item C<< <n> >> -- selection A single number alone causes a single index to be selected from the corresponding dimension. The dimension is kept (and reduced to size 1) in the output. =item C<< (<n>) >> -- selection and collapse A single number in parenthesis causes a single index to be selected from the corresponding dimension. The dimension is discarded (completely eliminated) in the output. =item C<< <n>:<m> >> -- select an inclusive range Two numbers separated by a colon selects a range of values from the corresponding axis, e.g. C<< 3:4 >> selects elements 3 and 4 along the corresponding axis, and reduces that axis to size 2 in the output. Both numbers are regularized so that you can address the last element of the axis with an index of C< -1 >. If, after regularization, the two numbers are the same, then exactly one element gets selected (just like the C<< <n> >> case). If, after regulariation, the second number is lower than the first, then the resulting slice counts down rather than up -- e.g. C<-1:0> will return the entire axis, in reversed order. =item C<< <n>:<m>:<s> >> -- select a range with explicit step If you include a third parameter, it is the stride of the extracted range. For example, C<< 0:-1:2 >> will sample every other element across the complete dimension. Specifying a stride of 1 prevents autoreversal -- so to ensure that your slice is *always* forward you can specify, e.g., C<< 2:$n:1 >>. In that case, an "impossible" slice gets an Empty PDL (with 0 elements along the corresponding dimension), so you can generate an Empty PDL with a slice of the form C<< 2:1:1 >>. =item C<< *<n> >> -- insert a dummy dimension Dummy dimensions aren't present in the original source and are "mocked up" to match dimensional slots, by repeating the data in the original PDL some number of times. An asterisk followed by a number produces a dummy dimension in the output, for example C<< *2 >> will generate a dimension of size 2 at the corresponding location in the output dim list. Omitting the numeber (and using just an asterisk) inserts a dummy dimension of size 1. =back B<ARRAY REF SYNTAX> If you feed in an ARRAY ref as a slice term, then it can have 0-3 elements. The first element is the start of the slice along the corresponding dim; the second is the end; and the third is the stepsize. Different combinations of inputs give the same flexibility as the string syntax. =over 3 =item C<< [] >> - keep dim intact An empty ARRAY ref keeps the entire corresponding dim =item C<< [ 'X' ] >> - keep dim intact =item C<< [ '*',$n ] >> - generate a dummy dim of size $n If $n is missing, you get a dummy dim of size 1. =item C<< [ $dex, , 0 ] >> - collapse and discard dim C<$dex> must be a single value. It is used to index the source, and the corresponding dimension is discarded. =item C<< [ $start, $end ] >> - collect inclusive slice In the simple two-number case, you get a slice that runs up or down (as appropriate) to connect $start and $end. =item C<< [ $start, $end, $inc ] >> - collect inclusive slice The three-number case works exactly like the three-number string case above. =back B<PDL args for dicing> If you pass in a 0- or 1-D PDL as a slicing argument, the corresponding dimension is "diced" -- you get one position along the corresponding dim, per element of the indexing PDL, e.g. C<< $a->slice( pdl(3,4,9)) >> gives you elements 3, 4, and 9 along the 0 dim of C<< $a >>. Because dicing is not an affine transformation, it is slower than direct slicing even though the syntax is convenient. =for example $a->slice('1:3'); # return the second to fourth elements of $a $a->slice('3:1'); # reverse the above $a->slice('-2:1'); # return last-but-one to second elements of $a $a->slice([1,3]); # Same as above three calls, but using array ref syntax $a->slice([3,1]); $a->slice([-2,1]); =cut ############################## # 'slice' is now implemented as a small Perl wrapper around # a PP call. This permits unification of the former slice, # dice, and nslice into a single call. At the moment, dicing # is implemented a bit kludgily (it is detected in the Perl # front-end), but it is serviceable. # --CED 12-Sep-2013 *slice = \&PDL::slice; sub PDL::slice (;@) { my ($source, @others) = @_; # Deal with dicing. This is lame and slow compared to the # faster slicing, but works okay. We loop over each argument, # and if it's a PDL we dispatch it in the most straightforward # way. Single-element and zero-element PDLs are trivial and get # converted into slices for faster handling later. for my $i(0..$#others) { if( blessed($others[$i]) && $others[$i]->isa('PDL') ) { my $idx = $others[$i]; if($idx->ndims > 1) { barf("slice: dicing parameters must be at most 1D (arg $i)\n"); } my $nlm = $idx->nelem; if($nlm > 1) { #### More than one element - we have to dice (darn it). my $n = $source->getndims; $source = $source->mv($i,0)->index1d($idx)->mv(0,$i); $others[$i] = ''; } elsif($nlm) { #### One element - convert to a regular slice. $others[$i] = $idx->flat->at(0); } else { #### Zero elements -- force an extended empty. $others[$i] = "1:0:1"; } } } PDL::sliceb($source,\@others); } =head2 sliceb =for sig Signature: (P(); C(); SV *args) =for ref info not available =for bad sliceb does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sliceb = \&PDL::sliceb; ; =head1 BUGS For the moment, you can't slice one of the zero-length dims of an empty piddle. It is not clear how to implement this in a way that makes sense. Many types of index errors are reported far from the indexing operation that caused them. This is caused by the underlying architecture: slice() sets up a mapping between variables, but that mapping isn't tested for correctness until it is used (potentially much later). =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Contributions by Craig DeForest, deforest@boulder.swri.edu. Documentation contributions by David Mertens. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Transform/������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402066�014255� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Transform/Proj4.pm����������������������������������������������������������0000644�0601750�0601001�00000743606�13110402066�015631� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Transform::Proj4; @EXPORT_OK = qw( t_proj t_proj_aea t_proj_aeqd t_proj_airy t_proj_aitoff t_proj_alsk t_proj_apian t_proj_august t_proj_bacon t_proj_bipc t_proj_boggs t_proj_bonne t_proj_calcofi t_proj_cass t_proj_cc t_proj_cea t_proj_chamb t_proj_collg t_proj_comill t_proj_crast t_proj_denoy t_proj_eck1 t_proj_eck2 t_proj_eck3 t_proj_eck4 t_proj_eck5 t_proj_eck6 t_proj_eqc t_proj_eqdc t_proj_etmerc t_proj_euler t_proj_fahey t_proj_fouc t_proj_fouc_s t_proj_gall t_proj_geocent t_proj_geos t_proj_gins8 t_proj_gn_sinu t_proj_gnom t_proj_goode t_proj_gs48 t_proj_gs50 t_proj_gstmerc t_proj_hammer t_proj_hatano t_proj_healpix t_proj_igh t_proj_imw_p t_proj_isea t_proj_kav5 t_proj_kav7 t_proj_krovak t_proj_labrd t_proj_laea t_proj_lagrng t_proj_larr t_proj_lask t_proj_latlon t_proj_latlong t_proj_lcc t_proj_lcca t_proj_leac t_proj_lee_os t_proj_longlat t_proj_lonlat t_proj_loxim t_proj_lsat t_proj_mbt_fps t_proj_mbt_s t_proj_mbtfpp t_proj_mbtfpq t_proj_mbtfps t_proj_merc t_proj_mil_os t_proj_mill t_proj_misrsom t_proj_moll t_proj_murd1 t_proj_murd2 t_proj_murd3 t_proj_natearth t_proj_natearth2 t_proj_nell t_proj_nell_h t_proj_nicol t_proj_nsper t_proj_nzmg t_proj_ob_tran t_proj_ocea t_proj_oea t_proj_omerc t_proj_ortel t_proj_ortho t_proj_patterson t_proj_pconic t_proj_poly t_proj_putp1 t_proj_putp2 t_proj_putp3 t_proj_putp3p t_proj_putp4p t_proj_putp5 t_proj_putp5p t_proj_putp6 t_proj_putp6p t_proj_qsc t_proj_qua_aut t_proj_rhealpix t_proj_robin t_proj_rouss t_proj_rpoly t_proj_sch t_proj_sinu t_proj_somerc t_proj_stere t_proj_sterea t_proj_tcc t_proj_tcea t_proj_times t_proj_tissot t_proj_tmerc t_proj_tpeqd t_proj_tpers t_proj_ups t_proj_urm5 t_proj_urmfps t_proj_utm t_proj_vandg t_proj_vandg2 t_proj_vandg3 t_proj_vandg4 t_proj_vitk1 t_proj_wag1 t_proj_wag2 t_proj_wag3 t_proj_wag4 t_proj_wag5 t_proj_wag6 t_proj_wag7 t_proj_weren t_proj_wink1 t_proj_wink2 t_proj_wintri PDL::PP _proj4_dummy ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader','PDL::Transform' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Transform::Proj4 ; BEGIN { use PDL; use PDL::NiceSlice; use PDL::Transform; use PDL::GIS::Proj; } # # PDL::Transform::Proj4 # # Judd Taylor, USF IMaRS # 4 Apr 2006 # =head1 NAME PDL::Transform::Proj4 - PDL::Transform interface to the Proj4 projection library =head1 SYNOPSIS # Using the generalized proj interface: # Make an orthographic map of Earth use PDL::Transform::Cartography; use PDL::Transform::Proj4; $a = earth_coast(); $a = graticule(10,2)->glue(1,$a); $t = t_proj( proj_params => "+proj=ortho +ellps=WGS84 +lon_0=-90 +lat_0=40" ); $w = pgwin(xs); $w->lines($t->apply($a)->clean_lines()); # Using the aliased functions: # Make an orthographic map of Earth use PDL::Transform::Cartography; use PDL::Transform::Proj4; $a = earth_coast(); $a = graticule(10,2)->glue(1,$a); $t = t_proj_ortho( ellps => 'WGS84', lon_0 => -90, lat_0 => 40 ) $w = pgwin(xs); $w->lines($t->apply($a)->clean_lines()); =head1 DESCRIPTION Works like PDL::Transform::Cartography, but using the proj library in the background. Please see the proj library docs at L<http://www.remotesensing.org/proj> for more information on proj, and how to use the library. =head1 GENERALIZED INTERFACE The main object here is the PDL::Transform::Proj4 object, aliased to the t_proj() function. This object accepts all of the standard options described below, but mainly is there to be called with just the B<proj_params> option defined. When options are used, they must be used with a '+' before them when placed in the proj_params string, but that is not required otherwise. See the SYNOPSIS above. =head2 ALIASED INTERFACE Other than t_proj(), all of the other transforms below have been autogenerated, and may not work properly. The main problem is determining the parameters a projection requires from the proj library itself. Due to the difficulties in doing this, there may be times when the proj docs specify a parameter for a projection that won't work using the anon-hash type specification. In that case, just throw that parameter in the proj_params string, and everything should work fine. =head1 PARAMETERS AVAILABLE IN ALL PROJECTIONS =head2 General Parameters =head3 proj_params This is a string containing the proj "plus style" parameters. This would be similar to what you would put on the command line for the 'proj' tool. Like "+proj=ortho +ellps=WGS84 +lon_0=-90 +lat_0=40". This parameter overrides the others below when it contains parameters that are also specified explicitly. =head3 proj The proj projection code to use (like ortho...) =head3 x_0 Cartesian X offset for the output of the transformation =head3 y_0 Cartesian Y offset for the output of the transformation =head3 lat_0 Central latitude for the projection. NOTE: This may mean other things depending on the projection selected, read the proj docs! =head3 lon_0 Central longitude for the projection. NOTE: This may mean other things depending on the projection selected, read the proj docs! =head3 units Cartesian units used for the output of the projection. NOTE: Like most of the options here, this is likely useless in the current implementation of this library. =head3 init Specify a file:unit for proj to use for its runtime defaults. See the proj docs. =head3 no_defs Don't load any defaults. See the proj docs. =head3 over Normally, the transformation limits the output to between -180 and 180 degrees (or the cartesian equivalent), but with this option that behavior is turned off. =head3 geoc Input values are geocentric coordinates. =head2 Earth Figure Parameters =head3 ellps Ellipsoid datum to use. Ex: WGS72, WGS74. See the proj docs and command line tool for list of possibilities ('proj -le'). =head3 R Radius of the Earth. =head3 R_A Radius of a sphere with equivalent surface area of specified ellipse. =head3 R_V Radius of a sphere with equivalent volume of specified ellipse. =head3 R_a Arithmetic mean of the major and minor axis, Ra = (a + b)/2. =head3 R_g Geometric mean of the major and minor axis, Rg = (ab)1/2. =head3 R_h Harmonic mean of the major and minor axis, Rh = 2ab/(a + b). =head3 R_lat_a=phi Arithmetic mean of the principle radii at latitude phi. =head3 R_lat_g=phi Geometric mean of the principle radii at latitude phi. =head3 b Semiminor axis or polar radius =head3 f Flattening =head3 rf Reciprocal flattening, +rf=1/f =head3 e Eccentricity +e=e =head3 es Eccentricity squared +es=e2 =cut sub new { my $proto = shift; my $sub = "PDL::Transform::Proj4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $class = ref($proto) || $proto; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Proj4"; # Grab our options: # Used in the general sense: $self->{params}->{proj_params} = PDL::Transform::_opt( $o, ['proj_params','params'] ); # Projection options available to all projections: $self->{general_params} = [ qw( proj x_0 y_0 lat_0 lon_0 units init ) ]; foreach my $param ( @{ $self->{general_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } # Options that have no value (like "+over"): $self->{bool_params} = [ qw( no_defs over geoc ) ]; foreach my $param ( @{ $self->{bool_params} } ) { $self->{params}->{$param} = ( PDL::Transform::_opt( $o, [ $param ] ) ) ? 'ON' : undef; } # Options for the Earth figure: (ellipsoid, etc): $self->{earth_params} = [ qw( ellps R R_A R_V R_a R_g R_h R_lat_a R_lat_g b f rf e es ) ]; foreach my $param ( @{ $self->{earth_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } # First process the old params that may already be in the string: # These override the specific params set above: if( defined( $self->{params}->{proj_params} ) ) { $self->{orig_proj_params} = $self->{params}->{proj_params}; my @params = split( /\s+/, $self->{orig_proj_params} ); foreach my $param ( @params ) { if( $param =~ /^\+(\S+)=(\S+)/ ) { my ($name, $val) = ($1, $2); $self->{params}->{$name} = $val; #print STDERR "$sub: $name => $val\n"; } elsif( $param =~ /^\+(\S+)/ ) { # Boolean option $self->{params}->{$1} = 'ON'; } } } # Update the proj_string to current options: # $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); ############################## # The meat -- just copy and paste from Transform.pm :) # (and do some proj stuff here as well) # Forward transformation: $self->{func} = sub { my $in = shift; my $opt = shift; my $sub = "PDL::Transform::Proj4->{func}()"; my $out = $in->new_or_inplace(); # Always set the badflag to 1 here, to handle possible bad projection values: $out->badflag(1); PDL::GIS::Proj::fwd_trans_inplace( $out->((0)), $out->((1)), $opt->{proj_params}, 1 ); return $out; }; # Inverse transformation: $self->{inv} = sub { my $in = shift; my $opt = shift; my $sub = "PDL::Transform::Proj4->{inv}()"; my $out = $in->new_or_inplace(); # Always set the badflag to 1 here, to handle possible bad projection values: $out->badflag(1); PDL::GIS::Proj::inv_trans_inplace( $out->((0)), $out->((1)), $opt->{proj_params}, 1 ); return $out; }; return $self; } # End of new()... sub update_proj_string { my $self = shift; my $sub = "PDL::Transform::Proj4::update_proj_string()"; # (Re)Generate the proj_params string from the options passed: # delete( $self->{params}->{proj_params} ); my $proj_string = ""; foreach my $param ( keys %{ $self->{params} } ) { next unless defined( $self->{params}->{$param} ); $proj_string .= ( $self->{params}->{$param} eq 'ON' ) ? "+$param " : " +$param=" . $self->{params}->{$param} . " "; #print STDERR "$sub: Adding \'$proj_string\'...\n"; } #print STDERR "$sub: Final proj_params: \'$proj_string\'\n"; $self->{params}->{proj_params} = $proj_string; } # End of update_proj_string()... sub proj_params { my $self = shift; $self->update_proj_string(); return $self->{params}->{proj_params}; } # End of proj_params()... sub t_proj { PDL::Transform::Proj4->new( @_ ); } # End of t_proj()... 1; =head1 FUNCTIONS =head2 t_proj This is the main entry point for the generalized interface. See above on its usage. =cut =head2 t_proj_aea Autogenerated transformation function for Proj4 projection code aea. The full name for this projection is Albers Equal Area. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_aea { PDL::Transform::Proj4::aea->new( @_ ); } =head2 t_proj_aeqd Autogenerated transformation function for Proj4 projection code aeqd. The full name for this projection is Azimuthal Equidistant. Projection Parameters =for options =over 4 =item guam =item lat_0 =back =cut sub t_proj_aeqd { PDL::Transform::Proj4::aeqd->new( @_ ); } =head2 t_proj_airy Autogenerated transformation function for Proj4 projection code airy. The full name for this projection is Airy. Projection Parameters =for options =over 4 =item lat_b =item no_cut =back =cut sub t_proj_airy { PDL::Transform::Proj4::airy->new( @_ ); } =head2 t_proj_aitoff Autogenerated transformation function for Proj4 projection code aitoff. The full name for this projection is Aitoff. =cut sub t_proj_aitoff { PDL::Transform::Proj4::aitoff->new( @_ ); } =head2 t_proj_alsk Autogenerated transformation function for Proj4 projection code alsk. The full name for this projection is Mod. Stereographic of Alaska. =cut sub t_proj_alsk { PDL::Transform::Proj4::alsk->new( @_ ); } =head2 t_proj_apian Autogenerated transformation function for Proj4 projection code apian. The full name for this projection is Apian Globular I. =cut sub t_proj_apian { PDL::Transform::Proj4::apian->new( @_ ); } =head2 t_proj_august Autogenerated transformation function for Proj4 projection code august. The full name for this projection is August Epicycloidal. =cut sub t_proj_august { PDL::Transform::Proj4::august->new( @_ ); } =head2 t_proj_bacon Autogenerated transformation function for Proj4 projection code bacon. The full name for this projection is Bacon Globular. =cut sub t_proj_bacon { PDL::Transform::Proj4::bacon->new( @_ ); } =head2 t_proj_bipc Autogenerated transformation function for Proj4 projection code bipc. The full name for this projection is Bipolar conic of western hemisphere. =cut sub t_proj_bipc { PDL::Transform::Proj4::bipc->new( @_ ); } =head2 t_proj_boggs Autogenerated transformation function for Proj4 projection code boggs. The full name for this projection is Boggs Eumorphic. =cut sub t_proj_boggs { PDL::Transform::Proj4::boggs->new( @_ ); } =head2 t_proj_bonne Autogenerated transformation function for Proj4 projection code bonne. The full name for this projection is Bonne (Werner lat_1=90). Projection Parameters =for options =over 4 =item lat_1 =back =cut sub t_proj_bonne { PDL::Transform::Proj4::bonne->new( @_ ); } =head2 t_proj_calcofi Autogenerated transformation function for Proj4 projection code calcofi. The full name for this projection is Cal Coop Ocean Fish Invest Lines/Stations. =cut sub t_proj_calcofi { PDL::Transform::Proj4::calcofi->new( @_ ); } =head2 t_proj_cass Autogenerated transformation function for Proj4 projection code cass. The full name for this projection is Cassini. =cut sub t_proj_cass { PDL::Transform::Proj4::cass->new( @_ ); } =head2 t_proj_cc Autogenerated transformation function for Proj4 projection code cc. The full name for this projection is Central Cylindrical. =cut sub t_proj_cc { PDL::Transform::Proj4::cc->new( @_ ); } =head2 t_proj_cea Autogenerated transformation function for Proj4 projection code cea. The full name for this projection is Equal Area Cylindrical. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_cea { PDL::Transform::Proj4::cea->new( @_ ); } =head2 t_proj_chamb Autogenerated transformation function for Proj4 projection code chamb. The full name for this projection is Chamberlin Trimetric. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lat_3 =item lon_1 =item lon_2 =item lon_3 =back =cut sub t_proj_chamb { PDL::Transform::Proj4::chamb->new( @_ ); } =head2 t_proj_collg Autogenerated transformation function for Proj4 projection code collg. The full name for this projection is Collignon. =cut sub t_proj_collg { PDL::Transform::Proj4::collg->new( @_ ); } =head2 t_proj_comill Autogenerated transformation function for Proj4 projection code comill. The full name for this projection is Compact Miller. =cut sub t_proj_comill { PDL::Transform::Proj4::comill->new( @_ ); } =head2 t_proj_crast Autogenerated transformation function for Proj4 projection code crast. The full name for this projection is Craster Parabolic (Putnins P4). =cut sub t_proj_crast { PDL::Transform::Proj4::crast->new( @_ ); } =head2 t_proj_denoy Autogenerated transformation function for Proj4 projection code denoy. The full name for this projection is Denoyer Semi-Elliptical. =cut sub t_proj_denoy { PDL::Transform::Proj4::denoy->new( @_ ); } =head2 t_proj_eck1 Autogenerated transformation function for Proj4 projection code eck1. The full name for this projection is Eckert I. =cut sub t_proj_eck1 { PDL::Transform::Proj4::eck1->new( @_ ); } =head2 t_proj_eck2 Autogenerated transformation function for Proj4 projection code eck2. The full name for this projection is Eckert II. =cut sub t_proj_eck2 { PDL::Transform::Proj4::eck2->new( @_ ); } =head2 t_proj_eck3 Autogenerated transformation function for Proj4 projection code eck3. The full name for this projection is Eckert III. =cut sub t_proj_eck3 { PDL::Transform::Proj4::eck3->new( @_ ); } =head2 t_proj_eck4 Autogenerated transformation function for Proj4 projection code eck4. The full name for this projection is Eckert IV. =cut sub t_proj_eck4 { PDL::Transform::Proj4::eck4->new( @_ ); } =head2 t_proj_eck5 Autogenerated transformation function for Proj4 projection code eck5. The full name for this projection is Eckert V. =cut sub t_proj_eck5 { PDL::Transform::Proj4::eck5->new( @_ ); } =head2 t_proj_eck6 Autogenerated transformation function for Proj4 projection code eck6. The full name for this projection is Eckert VI. =cut sub t_proj_eck6 { PDL::Transform::Proj4::eck6->new( @_ ); } =head2 t_proj_eqc Autogenerated transformation function for Proj4 projection code eqc. The full name for this projection is Equidistant Cylindrical (Plate Caree). Projection Parameters =for options =over 4 =item lat_00 =item lat_ts =back =cut sub t_proj_eqc { PDL::Transform::Proj4::eqc->new( @_ ); } =head2 t_proj_eqdc Autogenerated transformation function for Proj4 projection code eqdc. The full name for this projection is Equidistant Conic. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_eqdc { PDL::Transform::Proj4::eqdc->new( @_ ); } =head2 t_proj_etmerc Autogenerated transformation function for Proj4 projection code etmerc. The full name for this projection is Extended Transverse Mercator. Projection Parameters =for options =over 4 =item lat_0(0) =item lat_ts(0) =back =cut sub t_proj_etmerc { PDL::Transform::Proj4::etmerc->new( @_ ); } =head2 t_proj_euler Autogenerated transformation function for Proj4 projection code euler. The full name for this projection is Euler. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_euler { PDL::Transform::Proj4::euler->new( @_ ); } =head2 t_proj_fahey Autogenerated transformation function for Proj4 projection code fahey. The full name for this projection is Fahey. =cut sub t_proj_fahey { PDL::Transform::Proj4::fahey->new( @_ ); } =head2 t_proj_fouc Autogenerated transformation function for Proj4 projection code fouc. The full name for this projection is Foucaut. =cut sub t_proj_fouc { PDL::Transform::Proj4::fouc->new( @_ ); } =head2 t_proj_fouc_s Autogenerated transformation function for Proj4 projection code fouc_s. The full name for this projection is Foucaut Sinusoidal. =cut sub t_proj_fouc_s { PDL::Transform::Proj4::fouc_s->new( @_ ); } =head2 t_proj_gall Autogenerated transformation function for Proj4 projection code gall. The full name for this projection is Gall (Gall Stereographic). =cut sub t_proj_gall { PDL::Transform::Proj4::gall->new( @_ ); } =head2 t_proj_geocent Autogenerated transformation function for Proj4 projection code geocent. The full name for this projection is Geocentric. =cut sub t_proj_geocent { PDL::Transform::Proj4::geocent->new( @_ ); } =head2 t_proj_geos Autogenerated transformation function for Proj4 projection code geos. The full name for this projection is Geostationary Satellite View. Projection Parameters =for options =over 4 =item h =back =cut sub t_proj_geos { PDL::Transform::Proj4::geos->new( @_ ); } =head2 t_proj_gins8 Autogenerated transformation function for Proj4 projection code gins8. The full name for this projection is Ginsburg VIII (TsNIIGAiK). =cut sub t_proj_gins8 { PDL::Transform::Proj4::gins8->new( @_ ); } =head2 t_proj_gn_sinu Autogenerated transformation function for Proj4 projection code gn_sinu. The full name for this projection is General Sinusoidal Series. Projection Parameters =for options =over 4 =item m =item n =back =cut sub t_proj_gn_sinu { PDL::Transform::Proj4::gn_sinu->new( @_ ); } =head2 t_proj_gnom Autogenerated transformation function for Proj4 projection code gnom. The full name for this projection is Gnomonic. =cut sub t_proj_gnom { PDL::Transform::Proj4::gnom->new( @_ ); } =head2 t_proj_goode Autogenerated transformation function for Proj4 projection code goode. The full name for this projection is Goode Homolosine. =cut sub t_proj_goode { PDL::Transform::Proj4::goode->new( @_ ); } =head2 t_proj_gs48 Autogenerated transformation function for Proj4 projection code gs48. The full name for this projection is Mod. Stereographic of 48 U.S.. =cut sub t_proj_gs48 { PDL::Transform::Proj4::gs48->new( @_ ); } =head2 t_proj_gs50 Autogenerated transformation function for Proj4 projection code gs50. The full name for this projection is Mod. Stereographic of 50 U.S.. =cut sub t_proj_gs50 { PDL::Transform::Proj4::gs50->new( @_ ); } =head2 t_proj_gstmerc Autogenerated transformation function for Proj4 projection code gstmerc. The full name for this projection is Gauss-Schreiber Transverse Mercator (aka Gauss-Laborde Reunion). Projection Parameters =for options =over 4 =item k_0 =item lat_0 =item lon_0 =back =cut sub t_proj_gstmerc { PDL::Transform::Proj4::gstmerc->new( @_ ); } =head2 t_proj_hammer Autogenerated transformation function for Proj4 projection code hammer. The full name for this projection is Hammer & Eckert-Greifendorff. Projection Parameters =for options =over 4 =item M =item W =back =cut sub t_proj_hammer { PDL::Transform::Proj4::hammer->new( @_ ); } =head2 t_proj_hatano Autogenerated transformation function for Proj4 projection code hatano. The full name for this projection is Hatano Asymmetrical Equal Area. =cut sub t_proj_hatano { PDL::Transform::Proj4::hatano->new( @_ ); } =head2 t_proj_healpix Autogenerated transformation function for Proj4 projection code healpix. The full name for this projection is HEALPix. =cut sub t_proj_healpix { PDL::Transform::Proj4::healpix->new( @_ ); } =head2 t_proj_igh Autogenerated transformation function for Proj4 projection code igh. The full name for this projection is Interrupted Goode Homolosine. =cut sub t_proj_igh { PDL::Transform::Proj4::igh->new( @_ ); } =head2 t_proj_imw_p Autogenerated transformation function for Proj4 projection code imw_p. The full name for this projection is International Map of the World Polyconic. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lon_1 =back =cut sub t_proj_imw_p { PDL::Transform::Proj4::imw_p->new( @_ ); } =head2 t_proj_isea Autogenerated transformation function for Proj4 projection code isea. The full name for this projection is Icosahedral Snyder Equal Area. =cut sub t_proj_isea { PDL::Transform::Proj4::isea->new( @_ ); } =head2 t_proj_kav5 Autogenerated transformation function for Proj4 projection code kav5. The full name for this projection is Kavraisky V. =cut sub t_proj_kav5 { PDL::Transform::Proj4::kav5->new( @_ ); } =head2 t_proj_kav7 Autogenerated transformation function for Proj4 projection code kav7. The full name for this projection is Kavraisky VII. =cut sub t_proj_kav7 { PDL::Transform::Proj4::kav7->new( @_ ); } =head2 t_proj_krovak Autogenerated transformation function for Proj4 projection code krovak. The full name for this projection is Krovak. =cut sub t_proj_krovak { PDL::Transform::Proj4::krovak->new( @_ ); } =head2 t_proj_labrd Autogenerated transformation function for Proj4 projection code labrd. The full name for this projection is Laborde. =cut sub t_proj_labrd { PDL::Transform::Proj4::labrd->new( @_ ); } =head2 t_proj_laea Autogenerated transformation function for Proj4 projection code laea. The full name for this projection is Lambert Azimuthal Equal Area. =cut sub t_proj_laea { PDL::Transform::Proj4::laea->new( @_ ); } =head2 t_proj_lagrng Autogenerated transformation function for Proj4 projection code lagrng. The full name for this projection is Lagrange. Projection Parameters =for options =over 4 =item W =back =cut sub t_proj_lagrng { PDL::Transform::Proj4::lagrng->new( @_ ); } =head2 t_proj_larr Autogenerated transformation function for Proj4 projection code larr. The full name for this projection is Larrivee. =cut sub t_proj_larr { PDL::Transform::Proj4::larr->new( @_ ); } =head2 t_proj_lask Autogenerated transformation function for Proj4 projection code lask. The full name for this projection is Laskowski. =cut sub t_proj_lask { PDL::Transform::Proj4::lask->new( @_ ); } =head2 t_proj_latlon Autogenerated transformation function for Proj4 projection code latlon. The full name for this projection is Lat/long (Geodetic alias). =cut sub t_proj_latlon { PDL::Transform::Proj4::latlon->new( @_ ); } =head2 t_proj_latlong Autogenerated transformation function for Proj4 projection code latlong. The full name for this projection is Lat/long (Geodetic alias). =cut sub t_proj_latlong { PDL::Transform::Proj4::latlong->new( @_ ); } =head2 t_proj_lcc Autogenerated transformation function for Proj4 projection code lcc. The full name for this projection is Lambert Conformal Conic. Projection Parameters =for options =over 4 =item lat_0 =item lat_1 =item lat_2 =back =cut sub t_proj_lcc { PDL::Transform::Proj4::lcc->new( @_ ); } =head2 t_proj_lcca Autogenerated transformation function for Proj4 projection code lcca. The full name for this projection is Lambert Conformal Conic Alternative. Projection Parameters =for options =over 4 =item lat_0 =back =cut sub t_proj_lcca { PDL::Transform::Proj4::lcca->new( @_ ); } =head2 t_proj_leac Autogenerated transformation function for Proj4 projection code leac. The full name for this projection is Lambert Equal Area Conic. Projection Parameters =for options =over 4 =item lat_1 =item south =back =cut sub t_proj_leac { PDL::Transform::Proj4::leac->new( @_ ); } =head2 t_proj_lee_os Autogenerated transformation function for Proj4 projection code lee_os. The full name for this projection is Lee Oblated Stereographic. =cut sub t_proj_lee_os { PDL::Transform::Proj4::lee_os->new( @_ ); } =head2 t_proj_longlat Autogenerated transformation function for Proj4 projection code longlat. The full name for this projection is Lat/long (Geodetic alias). =cut sub t_proj_longlat { PDL::Transform::Proj4::longlat->new( @_ ); } =head2 t_proj_lonlat Autogenerated transformation function for Proj4 projection code lonlat. The full name for this projection is Lat/long (Geodetic). =cut sub t_proj_lonlat { PDL::Transform::Proj4::lonlat->new( @_ ); } =head2 t_proj_loxim Autogenerated transformation function for Proj4 projection code loxim. The full name for this projection is Loximuthal. =cut sub t_proj_loxim { PDL::Transform::Proj4::loxim->new( @_ ); } =head2 t_proj_lsat Autogenerated transformation function for Proj4 projection code lsat. The full name for this projection is Space oblique for LANDSAT. Projection Parameters =for options =over 4 =item lsat =item path =back =cut sub t_proj_lsat { PDL::Transform::Proj4::lsat->new( @_ ); } =head2 t_proj_mbt_fps Autogenerated transformation function for Proj4 projection code mbt_fps. The full name for this projection is McBryde-Thomas Flat-Pole Sine (No. 2). =cut sub t_proj_mbt_fps { PDL::Transform::Proj4::mbt_fps->new( @_ ); } =head2 t_proj_mbt_s Autogenerated transformation function for Proj4 projection code mbt_s. The full name for this projection is McBryde-Thomas Flat-Polar Sine (No. 1). =cut sub t_proj_mbt_s { PDL::Transform::Proj4::mbt_s->new( @_ ); } =head2 t_proj_mbtfpp Autogenerated transformation function for Proj4 projection code mbtfpp. The full name for this projection is McBride-Thomas Flat-Polar Parabolic. =cut sub t_proj_mbtfpp { PDL::Transform::Proj4::mbtfpp->new( @_ ); } =head2 t_proj_mbtfpq Autogenerated transformation function for Proj4 projection code mbtfpq. The full name for this projection is McBryde-Thomas Flat-Polar Quartic. =cut sub t_proj_mbtfpq { PDL::Transform::Proj4::mbtfpq->new( @_ ); } =head2 t_proj_mbtfps Autogenerated transformation function for Proj4 projection code mbtfps. The full name for this projection is McBryde-Thomas Flat-Polar Sinusoidal. =cut sub t_proj_mbtfps { PDL::Transform::Proj4::mbtfps->new( @_ ); } =head2 t_proj_merc Autogenerated transformation function for Proj4 projection code merc. The full name for this projection is Mercator. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_merc { PDL::Transform::Proj4::merc->new( @_ ); } =head2 t_proj_mil_os Autogenerated transformation function for Proj4 projection code mil_os. The full name for this projection is Miller Oblated Stereographic. =cut sub t_proj_mil_os { PDL::Transform::Proj4::mil_os->new( @_ ); } =head2 t_proj_mill Autogenerated transformation function for Proj4 projection code mill. The full name for this projection is Miller Cylindrical. =cut sub t_proj_mill { PDL::Transform::Proj4::mill->new( @_ ); } =head2 t_proj_misrsom Autogenerated transformation function for Proj4 projection code misrsom. The full name for this projection is Space oblique for MISR. Projection Parameters =for options =over 4 =item path =back =cut sub t_proj_misrsom { PDL::Transform::Proj4::misrsom->new( @_ ); } =head2 t_proj_moll Autogenerated transformation function for Proj4 projection code moll. The full name for this projection is Mollweide. =cut sub t_proj_moll { PDL::Transform::Proj4::moll->new( @_ ); } =head2 t_proj_murd1 Autogenerated transformation function for Proj4 projection code murd1. The full name for this projection is Murdoch I. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_murd1 { PDL::Transform::Proj4::murd1->new( @_ ); } =head2 t_proj_murd2 Autogenerated transformation function for Proj4 projection code murd2. The full name for this projection is Murdoch II. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_murd2 { PDL::Transform::Proj4::murd2->new( @_ ); } =head2 t_proj_murd3 Autogenerated transformation function for Proj4 projection code murd3. The full name for this projection is Murdoch III. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_murd3 { PDL::Transform::Proj4::murd3->new( @_ ); } =head2 t_proj_natearth Autogenerated transformation function for Proj4 projection code natearth. The full name for this projection is Natural Earth. =cut sub t_proj_natearth { PDL::Transform::Proj4::natearth->new( @_ ); } =head2 t_proj_natearth2 Autogenerated transformation function for Proj4 projection code natearth2. The full name for this projection is Natural Earth 2. =cut sub t_proj_natearth2 { PDL::Transform::Proj4::natearth2->new( @_ ); } =head2 t_proj_nell Autogenerated transformation function for Proj4 projection code nell. The full name for this projection is Nell. =cut sub t_proj_nell { PDL::Transform::Proj4::nell->new( @_ ); } =head2 t_proj_nell_h Autogenerated transformation function for Proj4 projection code nell_h. The full name for this projection is Nell-Hammer. =cut sub t_proj_nell_h { PDL::Transform::Proj4::nell_h->new( @_ ); } =head2 t_proj_nicol Autogenerated transformation function for Proj4 projection code nicol. The full name for this projection is Nicolosi Globular. =cut sub t_proj_nicol { PDL::Transform::Proj4::nicol->new( @_ ); } =head2 t_proj_nsper Autogenerated transformation function for Proj4 projection code nsper. The full name for this projection is Near-sided perspective. Projection Parameters =for options =over 4 =item h =back =cut sub t_proj_nsper { PDL::Transform::Proj4::nsper->new( @_ ); } =head2 t_proj_nzmg Autogenerated transformation function for Proj4 projection code nzmg. The full name for this projection is New Zealand Map Grid. =cut sub t_proj_nzmg { PDL::Transform::Proj4::nzmg->new( @_ ); } =head2 t_proj_ob_tran Autogenerated transformation function for Proj4 projection code ob_tran. The full name for this projection is General Oblique Transformation. Projection Parameters =for options =over 4 =item o_alpha =item o_lat_1 =item o_lat_2 =item o_lat_c =item o_lat_p =item o_lon_1 =item o_lon_2 =item o_lon_c =item o_lon_p =item o_proj =back =cut sub t_proj_ob_tran { PDL::Transform::Proj4::ob_tran->new( @_ ); } =head2 t_proj_ocea Autogenerated transformation function for Proj4 projection code ocea. The full name for this projection is Oblique Cylindrical Equal Area. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lon_1 =item lon_2 =back =cut sub t_proj_ocea { PDL::Transform::Proj4::ocea->new( @_ ); } =head2 t_proj_oea Autogenerated transformation function for Proj4 projection code oea. The full name for this projection is Oblated Equal Area. Projection Parameters =for options =over 4 =item m =item n =item theta =back =cut sub t_proj_oea { PDL::Transform::Proj4::oea->new( @_ ); } =head2 t_proj_omerc Autogenerated transformation function for Proj4 projection code omerc. The full name for this projection is Oblique Mercator. Projection Parameters =for options =over 4 =item alpha =item gamma =item lat_1 =item lat_2 =item lon_1 =item lon_2 =item lonc =item no_off =back =cut sub t_proj_omerc { PDL::Transform::Proj4::omerc->new( @_ ); } =head2 t_proj_ortel Autogenerated transformation function for Proj4 projection code ortel. The full name for this projection is Ortelius Oval. =cut sub t_proj_ortel { PDL::Transform::Proj4::ortel->new( @_ ); } =head2 t_proj_ortho Autogenerated transformation function for Proj4 projection code ortho. The full name for this projection is Orthographic. =cut sub t_proj_ortho { PDL::Transform::Proj4::ortho->new( @_ ); } =head2 t_proj_patterson Autogenerated transformation function for Proj4 projection code patterson. The full name for this projection is Patterson Cylindrical. =cut sub t_proj_patterson { PDL::Transform::Proj4::patterson->new( @_ ); } =head2 t_proj_pconic Autogenerated transformation function for Proj4 projection code pconic. The full name for this projection is Perspective Conic. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_pconic { PDL::Transform::Proj4::pconic->new( @_ ); } =head2 t_proj_poly Autogenerated transformation function for Proj4 projection code poly. The full name for this projection is Polyconic (American). =cut sub t_proj_poly { PDL::Transform::Proj4::poly->new( @_ ); } =head2 t_proj_putp1 Autogenerated transformation function for Proj4 projection code putp1. The full name for this projection is Putnins P1. =cut sub t_proj_putp1 { PDL::Transform::Proj4::putp1->new( @_ ); } =head2 t_proj_putp2 Autogenerated transformation function for Proj4 projection code putp2. The full name for this projection is Putnins P2. =cut sub t_proj_putp2 { PDL::Transform::Proj4::putp2->new( @_ ); } =head2 t_proj_putp3 Autogenerated transformation function for Proj4 projection code putp3. The full name for this projection is Putnins P3. =cut sub t_proj_putp3 { PDL::Transform::Proj4::putp3->new( @_ ); } =head2 t_proj_putp3p Autogenerated transformation function for Proj4 projection code putp3p. The full name for this projection is Putnins P3'. =cut sub t_proj_putp3p { PDL::Transform::Proj4::putp3p->new( @_ ); } =head2 t_proj_putp4p Autogenerated transformation function for Proj4 projection code putp4p. The full name for this projection is Putnins P4'. =cut sub t_proj_putp4p { PDL::Transform::Proj4::putp4p->new( @_ ); } =head2 t_proj_putp5 Autogenerated transformation function for Proj4 projection code putp5. The full name for this projection is Putnins P5. =cut sub t_proj_putp5 { PDL::Transform::Proj4::putp5->new( @_ ); } =head2 t_proj_putp5p Autogenerated transformation function for Proj4 projection code putp5p. The full name for this projection is Putnins P5'. =cut sub t_proj_putp5p { PDL::Transform::Proj4::putp5p->new( @_ ); } =head2 t_proj_putp6 Autogenerated transformation function for Proj4 projection code putp6. The full name for this projection is Putnins P6. =cut sub t_proj_putp6 { PDL::Transform::Proj4::putp6->new( @_ ); } =head2 t_proj_putp6p Autogenerated transformation function for Proj4 projection code putp6p. The full name for this projection is Putnins P6'. =cut sub t_proj_putp6p { PDL::Transform::Proj4::putp6p->new( @_ ); } =head2 t_proj_qsc Autogenerated transformation function for Proj4 projection code qsc. The full name for this projection is Quadrilateralized Spherical Cube. =cut sub t_proj_qsc { PDL::Transform::Proj4::qsc->new( @_ ); } =head2 t_proj_qua_aut Autogenerated transformation function for Proj4 projection code qua_aut. The full name for this projection is Quartic Authalic. =cut sub t_proj_qua_aut { PDL::Transform::Proj4::qua_aut->new( @_ ); } =head2 t_proj_rhealpix Autogenerated transformation function for Proj4 projection code rhealpix. The full name for this projection is rHEALPix. Projection Parameters =for options =over 4 =item south_square =back =cut sub t_proj_rhealpix { PDL::Transform::Proj4::rhealpix->new( @_ ); } =head2 t_proj_robin Autogenerated transformation function for Proj4 projection code robin. The full name for this projection is Robinson. =cut sub t_proj_robin { PDL::Transform::Proj4::robin->new( @_ ); } =head2 t_proj_rouss Autogenerated transformation function for Proj4 projection code rouss. The full name for this projection is Roussilhe Stereographic. =cut sub t_proj_rouss { PDL::Transform::Proj4::rouss->new( @_ ); } =head2 t_proj_rpoly Autogenerated transformation function for Proj4 projection code rpoly. The full name for this projection is Rectangular Polyconic. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_rpoly { PDL::Transform::Proj4::rpoly->new( @_ ); } =head2 t_proj_sch Autogenerated transformation function for Proj4 projection code sch. The full name for this projection is Spherical Cross-track Height. Projection Parameters =for options =over 4 =item h_0 =item phdg_0 =item plat_0 =item plon_0 =back =cut sub t_proj_sch { PDL::Transform::Proj4::sch->new( @_ ); } =head2 t_proj_sinu Autogenerated transformation function for Proj4 projection code sinu. The full name for this projection is Sinusoidal (Sanson-Flamsteed). =cut sub t_proj_sinu { PDL::Transform::Proj4::sinu->new( @_ ); } =head2 t_proj_somerc Autogenerated transformation function for Proj4 projection code somerc. The full name for this projection is Swiss. Obl. Mercator. =cut sub t_proj_somerc { PDL::Transform::Proj4::somerc->new( @_ ); } =head2 t_proj_stere Autogenerated transformation function for Proj4 projection code stere. The full name for this projection is Stereographic. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_stere { PDL::Transform::Proj4::stere->new( @_ ); } =head2 t_proj_sterea Autogenerated transformation function for Proj4 projection code sterea. The full name for this projection is Oblique Stereographic Alternative. =cut sub t_proj_sterea { PDL::Transform::Proj4::sterea->new( @_ ); } =head2 t_proj_tcc Autogenerated transformation function for Proj4 projection code tcc. The full name for this projection is Transverse Central Cylindrical. =cut sub t_proj_tcc { PDL::Transform::Proj4::tcc->new( @_ ); } =head2 t_proj_tcea Autogenerated transformation function for Proj4 projection code tcea. The full name for this projection is Transverse Cylindrical Equal Area. =cut sub t_proj_tcea { PDL::Transform::Proj4::tcea->new( @_ ); } =head2 t_proj_times Autogenerated transformation function for Proj4 projection code times. The full name for this projection is Times. =cut sub t_proj_times { PDL::Transform::Proj4::times->new( @_ ); } =head2 t_proj_tissot Autogenerated transformation function for Proj4 projection code tissot. The full name for this projection is Tissot. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_tissot { PDL::Transform::Proj4::tissot->new( @_ ); } =head2 t_proj_tmerc Autogenerated transformation function for Proj4 projection code tmerc. The full name for this projection is Transverse Mercator. =cut sub t_proj_tmerc { PDL::Transform::Proj4::tmerc->new( @_ ); } =head2 t_proj_tpeqd Autogenerated transformation function for Proj4 projection code tpeqd. The full name for this projection is Two Point Equidistant. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lon_1 =item lon_2 =back =cut sub t_proj_tpeqd { PDL::Transform::Proj4::tpeqd->new( @_ ); } =head2 t_proj_tpers Autogenerated transformation function for Proj4 projection code tpers. The full name for this projection is Tilted perspective. Projection Parameters =for options =over 4 =item azi =item h =item tilt =back =cut sub t_proj_tpers { PDL::Transform::Proj4::tpers->new( @_ ); } =head2 t_proj_ups Autogenerated transformation function for Proj4 projection code ups. The full name for this projection is Universal Polar Stereographic. Projection Parameters =for options =over 4 =item south =back =cut sub t_proj_ups { PDL::Transform::Proj4::ups->new( @_ ); } =head2 t_proj_urm5 Autogenerated transformation function for Proj4 projection code urm5. The full name for this projection is Urmaev V. Projection Parameters =for options =over 4 =item alpha =item n =item q =back =cut sub t_proj_urm5 { PDL::Transform::Proj4::urm5->new( @_ ); } =head2 t_proj_urmfps Autogenerated transformation function for Proj4 projection code urmfps. The full name for this projection is Urmaev Flat-Polar Sinusoidal. Projection Parameters =for options =over 4 =item n =back =cut sub t_proj_urmfps { PDL::Transform::Proj4::urmfps->new( @_ ); } =head2 t_proj_utm Autogenerated transformation function for Proj4 projection code utm. The full name for this projection is Universal Transverse Mercator (UTM). Projection Parameters =for options =over 4 =item south =item zone =back =cut sub t_proj_utm { PDL::Transform::Proj4::utm->new( @_ ); } =head2 t_proj_vandg Autogenerated transformation function for Proj4 projection code vandg. The full name for this projection is van der Grinten (I). =cut sub t_proj_vandg { PDL::Transform::Proj4::vandg->new( @_ ); } =head2 t_proj_vandg2 Autogenerated transformation function for Proj4 projection code vandg2. The full name for this projection is van der Grinten II. =cut sub t_proj_vandg2 { PDL::Transform::Proj4::vandg2->new( @_ ); } =head2 t_proj_vandg3 Autogenerated transformation function for Proj4 projection code vandg3. The full name for this projection is van der Grinten III. =cut sub t_proj_vandg3 { PDL::Transform::Proj4::vandg3->new( @_ ); } =head2 t_proj_vandg4 Autogenerated transformation function for Proj4 projection code vandg4. The full name for this projection is van der Grinten IV. =cut sub t_proj_vandg4 { PDL::Transform::Proj4::vandg4->new( @_ ); } =head2 t_proj_vitk1 Autogenerated transformation function for Proj4 projection code vitk1. The full name for this projection is Vitkovsky I. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_vitk1 { PDL::Transform::Proj4::vitk1->new( @_ ); } =head2 t_proj_wag1 Autogenerated transformation function for Proj4 projection code wag1. The full name for this projection is Wagner I (Kavraisky VI). =cut sub t_proj_wag1 { PDL::Transform::Proj4::wag1->new( @_ ); } =head2 t_proj_wag2 Autogenerated transformation function for Proj4 projection code wag2. The full name for this projection is Wagner II. =cut sub t_proj_wag2 { PDL::Transform::Proj4::wag2->new( @_ ); } =head2 t_proj_wag3 Autogenerated transformation function for Proj4 projection code wag3. The full name for this projection is Wagner III. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_wag3 { PDL::Transform::Proj4::wag3->new( @_ ); } =head2 t_proj_wag4 Autogenerated transformation function for Proj4 projection code wag4. The full name for this projection is Wagner IV. =cut sub t_proj_wag4 { PDL::Transform::Proj4::wag4->new( @_ ); } =head2 t_proj_wag5 Autogenerated transformation function for Proj4 projection code wag5. The full name for this projection is Wagner V. =cut sub t_proj_wag5 { PDL::Transform::Proj4::wag5->new( @_ ); } =head2 t_proj_wag6 Autogenerated transformation function for Proj4 projection code wag6. The full name for this projection is Wagner VI. =cut sub t_proj_wag6 { PDL::Transform::Proj4::wag6->new( @_ ); } =head2 t_proj_wag7 Autogenerated transformation function for Proj4 projection code wag7. The full name for this projection is Wagner VII. =cut sub t_proj_wag7 { PDL::Transform::Proj4::wag7->new( @_ ); } =head2 t_proj_weren Autogenerated transformation function for Proj4 projection code weren. The full name for this projection is Werenskiold I. =cut sub t_proj_weren { PDL::Transform::Proj4::weren->new( @_ ); } =head2 t_proj_wink1 Autogenerated transformation function for Proj4 projection code wink1. The full name for this projection is Winkel I. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_wink1 { PDL::Transform::Proj4::wink1->new( @_ ); } =head2 t_proj_wink2 Autogenerated transformation function for Proj4 projection code wink2. The full name for this projection is Winkel II. Projection Parameters =for options =over 4 =item lat_1 =back =cut sub t_proj_wink2 { PDL::Transform::Proj4::wink2->new( @_ ); } =head2 t_proj_wintri Autogenerated transformation function for Proj4 projection code wintri. The full name for this projection is Winkel Tripel. Projection Parameters =for options =over 4 =item lat_1 =back =cut sub t_proj_wintri { PDL::Transform::Proj4::wintri->new( @_ ); } *_proj4_dummy = \&PDL::_proj4_dummy; ; # Autogenerated code for the Proj4 projection code: # aea # package PDL::Transform::Proj4::aea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::aea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Albers Equal Area"; $self->{proj_code} = "aea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::aea::new()... 1; # Autogenerated code for the Proj4 projection code: # aeqd # package PDL::Transform::Proj4::aeqd; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::aeqd::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Azimuthal Equidistant"; $self->{proj_code} = "aeqd"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_0 guam ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::aeqd::new()... 1; # Autogenerated code for the Proj4 projection code: # airy # package PDL::Transform::Proj4::airy; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::airy::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Airy"; $self->{proj_code} = "airy"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( no_cut lat_b ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::airy::new()... 1; # Autogenerated code for the Proj4 projection code: # aitoff # package PDL::Transform::Proj4::aitoff; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::aitoff::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Aitoff"; $self->{proj_code} = "aitoff"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::aitoff::new()... 1; # Autogenerated code for the Proj4 projection code: # alsk # package PDL::Transform::Proj4::alsk; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::alsk::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Mod. Stereographic of Alaska"; $self->{proj_code} = "alsk"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::alsk::new()... 1; # Autogenerated code for the Proj4 projection code: # apian # package PDL::Transform::Proj4::apian; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::apian::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Apian Globular I"; $self->{proj_code} = "apian"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::apian::new()... 1; # Autogenerated code for the Proj4 projection code: # august # package PDL::Transform::Proj4::august; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::august::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "August Epicycloidal"; $self->{proj_code} = "august"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::august::new()... 1; # Autogenerated code for the Proj4 projection code: # bacon # package PDL::Transform::Proj4::bacon; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::bacon::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Bacon Globular"; $self->{proj_code} = "bacon"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::bacon::new()... 1; # Autogenerated code for the Proj4 projection code: # bipc # package PDL::Transform::Proj4::bipc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::bipc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Bipolar conic of western hemisphere"; $self->{proj_code} = "bipc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::bipc::new()... 1; # Autogenerated code for the Proj4 projection code: # boggs # package PDL::Transform::Proj4::boggs; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::boggs::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Boggs Eumorphic"; $self->{proj_code} = "boggs"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::boggs::new()... 1; # Autogenerated code for the Proj4 projection code: # bonne # package PDL::Transform::Proj4::bonne; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::bonne::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Bonne (Werner lat_1=90)"; $self->{proj_code} = "bonne"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::bonne::new()... 1; # Autogenerated code for the Proj4 projection code: # calcofi # package PDL::Transform::Proj4::calcofi; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::calcofi::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Cal Coop Ocean Fish Invest Lines/Stations"; $self->{proj_code} = "calcofi"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::calcofi::new()... 1; # Autogenerated code for the Proj4 projection code: # cass # package PDL::Transform::Proj4::cass; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::cass::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Cassini"; $self->{proj_code} = "cass"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::cass::new()... 1; # Autogenerated code for the Proj4 projection code: # cc # package PDL::Transform::Proj4::cc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::cc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Central Cylindrical"; $self->{proj_code} = "cc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::cc::new()... 1; # Autogenerated code for the Proj4 projection code: # cea # package PDL::Transform::Proj4::cea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::cea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Equal Area Cylindrical"; $self->{proj_code} = "cea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::cea::new()... 1; # Autogenerated code for the Proj4 projection code: # chamb # package PDL::Transform::Proj4::chamb; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::chamb::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Chamberlin Trimetric"; $self->{proj_code} = "chamb"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lon_1 lat_2 lon_2 lat_3 lon_3 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::chamb::new()... 1; # Autogenerated code for the Proj4 projection code: # collg # package PDL::Transform::Proj4::collg; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::collg::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Collignon"; $self->{proj_code} = "collg"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::collg::new()... 1; # Autogenerated code for the Proj4 projection code: # comill # package PDL::Transform::Proj4::comill; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::comill::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Compact Miller"; $self->{proj_code} = "comill"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::comill::new()... 1; # Autogenerated code for the Proj4 projection code: # crast # package PDL::Transform::Proj4::crast; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::crast::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Craster Parabolic (Putnins P4)"; $self->{proj_code} = "crast"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::crast::new()... 1; # Autogenerated code for the Proj4 projection code: # denoy # package PDL::Transform::Proj4::denoy; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::denoy::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Denoyer Semi-Elliptical"; $self->{proj_code} = "denoy"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::denoy::new()... 1; # Autogenerated code for the Proj4 projection code: # eck1 # package PDL::Transform::Proj4::eck1; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Eckert I"; $self->{proj_code} = "eck1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck1::new()... 1; # Autogenerated code for the Proj4 projection code: # eck2 # package PDL::Transform::Proj4::eck2; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Eckert II"; $self->{proj_code} = "eck2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck2::new()... 1; # Autogenerated code for the Proj4 projection code: # eck3 # package PDL::Transform::Proj4::eck3; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Eckert III"; $self->{proj_code} = "eck3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck3::new()... 1; # Autogenerated code for the Proj4 projection code: # eck4 # package PDL::Transform::Proj4::eck4; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Eckert IV"; $self->{proj_code} = "eck4"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck4::new()... 1; # Autogenerated code for the Proj4 projection code: # eck5 # package PDL::Transform::Proj4::eck5; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Eckert V"; $self->{proj_code} = "eck5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck5::new()... 1; # Autogenerated code for the Proj4 projection code: # eck6 # package PDL::Transform::Proj4::eck6; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck6::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Eckert VI"; $self->{proj_code} = "eck6"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck6::new()... 1; # Autogenerated code for the Proj4 projection code: # eqc # package PDL::Transform::Proj4::eqc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eqc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Equidistant Cylindrical (Plate Caree)"; $self->{proj_code} = "eqc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts lat_00 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eqc::new()... 1; # Autogenerated code for the Proj4 projection code: # eqdc # package PDL::Transform::Proj4::eqdc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eqdc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Equidistant Conic"; $self->{proj_code} = "eqdc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eqdc::new()... 1; # Autogenerated code for the Proj4 projection code: # etmerc # package PDL::Transform::Proj4::etmerc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::etmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Extended Transverse Mercator"; $self->{proj_code} = "etmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts(0) lat_0(0) ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::etmerc::new()... 1; # Autogenerated code for the Proj4 projection code: # euler # package PDL::Transform::Proj4::euler; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::euler::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Euler"; $self->{proj_code} = "euler"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::euler::new()... 1; # Autogenerated code for the Proj4 projection code: # fahey # package PDL::Transform::Proj4::fahey; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::fahey::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Fahey"; $self->{proj_code} = "fahey"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::fahey::new()... 1; # Autogenerated code for the Proj4 projection code: # fouc # package PDL::Transform::Proj4::fouc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::fouc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Foucaut"; $self->{proj_code} = "fouc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::fouc::new()... 1; # Autogenerated code for the Proj4 projection code: # fouc_s # package PDL::Transform::Proj4::fouc_s; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::fouc_s::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Foucaut Sinusoidal"; $self->{proj_code} = "fouc_s"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::fouc_s::new()... 1; # Autogenerated code for the Proj4 projection code: # gall # package PDL::Transform::Proj4::gall; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gall::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Gall (Gall Stereographic)"; $self->{proj_code} = "gall"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gall::new()... 1; # Autogenerated code for the Proj4 projection code: # geocent # package PDL::Transform::Proj4::geocent; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::geocent::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Geocentric"; $self->{proj_code} = "geocent"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::geocent::new()... 1; # Autogenerated code for the Proj4 projection code: # geos # package PDL::Transform::Proj4::geos; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::geos::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Geostationary Satellite View"; $self->{proj_code} = "geos"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( h ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::geos::new()... 1; # Autogenerated code for the Proj4 projection code: # gins8 # package PDL::Transform::Proj4::gins8; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gins8::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Ginsburg VIII (TsNIIGAiK)"; $self->{proj_code} = "gins8"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gins8::new()... 1; # Autogenerated code for the Proj4 projection code: # gn_sinu # package PDL::Transform::Proj4::gn_sinu; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gn_sinu::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "General Sinusoidal Series"; $self->{proj_code} = "gn_sinu"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( m n ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gn_sinu::new()... 1; # Autogenerated code for the Proj4 projection code: # gnom # package PDL::Transform::Proj4::gnom; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gnom::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Gnomonic"; $self->{proj_code} = "gnom"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gnom::new()... 1; # Autogenerated code for the Proj4 projection code: # goode # package PDL::Transform::Proj4::goode; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::goode::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Goode Homolosine"; $self->{proj_code} = "goode"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::goode::new()... 1; # Autogenerated code for the Proj4 projection code: # gs48 # package PDL::Transform::Proj4::gs48; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gs48::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Mod. Stereographic of 48 U.S."; $self->{proj_code} = "gs48"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gs48::new()... 1; # Autogenerated code for the Proj4 projection code: # gs50 # package PDL::Transform::Proj4::gs50; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gs50::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Mod. Stereographic of 50 U.S."; $self->{proj_code} = "gs50"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gs50::new()... 1; # Autogenerated code for the Proj4 projection code: # gstmerc # package PDL::Transform::Proj4::gstmerc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gstmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Gauss-Schreiber Transverse Mercator (aka Gauss-Laborde Reunion)"; $self->{proj_code} = "gstmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_0 lon_0 k_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gstmerc::new()... 1; # Autogenerated code for the Proj4 projection code: # hammer # package PDL::Transform::Proj4::hammer; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::hammer::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Hammer & Eckert-Greifendorff"; $self->{proj_code} = "hammer"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( W M ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::hammer::new()... 1; # Autogenerated code for the Proj4 projection code: # hatano # package PDL::Transform::Proj4::hatano; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::hatano::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Hatano Asymmetrical Equal Area"; $self->{proj_code} = "hatano"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::hatano::new()... 1; # Autogenerated code for the Proj4 projection code: # healpix # package PDL::Transform::Proj4::healpix; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::healpix::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "HEALPix"; $self->{proj_code} = "healpix"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::healpix::new()... 1; # Autogenerated code for the Proj4 projection code: # igh # package PDL::Transform::Proj4::igh; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::igh::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Interrupted Goode Homolosine"; $self->{proj_code} = "igh"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::igh::new()... 1; # Autogenerated code for the Proj4 projection code: # imw_p # package PDL::Transform::Proj4::imw_p; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::imw_p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "International Map of the World Polyconic"; $self->{proj_code} = "imw_p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 lon_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::imw_p::new()... 1; # Autogenerated code for the Proj4 projection code: # isea # package PDL::Transform::Proj4::isea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::isea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Icosahedral Snyder Equal Area"; $self->{proj_code} = "isea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::isea::new()... 1; # Autogenerated code for the Proj4 projection code: # kav5 # package PDL::Transform::Proj4::kav5; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::kav5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Kavraisky V"; $self->{proj_code} = "kav5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::kav5::new()... 1; # Autogenerated code for the Proj4 projection code: # kav7 # package PDL::Transform::Proj4::kav7; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::kav7::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Kavraisky VII"; $self->{proj_code} = "kav7"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::kav7::new()... 1; # Autogenerated code for the Proj4 projection code: # krovak # package PDL::Transform::Proj4::krovak; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::krovak::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Krovak"; $self->{proj_code} = "krovak"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::krovak::new()... 1; # Autogenerated code for the Proj4 projection code: # labrd # package PDL::Transform::Proj4::labrd; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::labrd::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Laborde"; $self->{proj_code} = "labrd"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::labrd::new()... 1; # Autogenerated code for the Proj4 projection code: # laea # package PDL::Transform::Proj4::laea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::laea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lambert Azimuthal Equal Area"; $self->{proj_code} = "laea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::laea::new()... 1; # Autogenerated code for the Proj4 projection code: # lagrng # package PDL::Transform::Proj4::lagrng; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lagrng::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lagrange"; $self->{proj_code} = "lagrng"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( W ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lagrng::new()... 1; # Autogenerated code for the Proj4 projection code: # larr # package PDL::Transform::Proj4::larr; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::larr::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Larrivee"; $self->{proj_code} = "larr"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::larr::new()... 1; # Autogenerated code for the Proj4 projection code: # lask # package PDL::Transform::Proj4::lask; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lask::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Laskowski"; $self->{proj_code} = "lask"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lask::new()... 1; # Autogenerated code for the Proj4 projection code: # latlon # package PDL::Transform::Proj4::latlon; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::latlon::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lat/long (Geodetic alias)"; $self->{proj_code} = "latlon"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::latlon::new()... 1; # Autogenerated code for the Proj4 projection code: # latlong # package PDL::Transform::Proj4::latlong; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::latlong::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lat/long (Geodetic alias)"; $self->{proj_code} = "latlong"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::latlong::new()... 1; # Autogenerated code for the Proj4 projection code: # lcc # package PDL::Transform::Proj4::lcc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lcc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lambert Conformal Conic"; $self->{proj_code} = "lcc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 lat_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lcc::new()... 1; # Autogenerated code for the Proj4 projection code: # lcca # package PDL::Transform::Proj4::lcca; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lcca::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lambert Conformal Conic Alternative"; $self->{proj_code} = "lcca"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lcca::new()... 1; # Autogenerated code for the Proj4 projection code: # leac # package PDL::Transform::Proj4::leac; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::leac::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lambert Equal Area Conic"; $self->{proj_code} = "leac"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 south ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::leac::new()... 1; # Autogenerated code for the Proj4 projection code: # lee_os # package PDL::Transform::Proj4::lee_os; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lee_os::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lee Oblated Stereographic"; $self->{proj_code} = "lee_os"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lee_os::new()... 1; # Autogenerated code for the Proj4 projection code: # longlat # package PDL::Transform::Proj4::longlat; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::longlat::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lat/long (Geodetic alias)"; $self->{proj_code} = "longlat"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::longlat::new()... 1; # Autogenerated code for the Proj4 projection code: # lonlat # package PDL::Transform::Proj4::lonlat; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lonlat::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Lat/long (Geodetic)"; $self->{proj_code} = "lonlat"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lonlat::new()... 1; # Autogenerated code for the Proj4 projection code: # loxim # package PDL::Transform::Proj4::loxim; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::loxim::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Loximuthal"; $self->{proj_code} = "loxim"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::loxim::new()... 1; # Autogenerated code for the Proj4 projection code: # lsat # package PDL::Transform::Proj4::lsat; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lsat::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Space oblique for LANDSAT"; $self->{proj_code} = "lsat"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lsat path ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lsat::new()... 1; # Autogenerated code for the Proj4 projection code: # mbt_fps # package PDL::Transform::Proj4::mbt_fps; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbt_fps::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "McBryde-Thomas Flat-Pole Sine (No. 2)"; $self->{proj_code} = "mbt_fps"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbt_fps::new()... 1; # Autogenerated code for the Proj4 projection code: # mbt_s # package PDL::Transform::Proj4::mbt_s; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbt_s::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "McBryde-Thomas Flat-Polar Sine (No. 1)"; $self->{proj_code} = "mbt_s"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbt_s::new()... 1; # Autogenerated code for the Proj4 projection code: # mbtfpp # package PDL::Transform::Proj4::mbtfpp; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbtfpp::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "McBride-Thomas Flat-Polar Parabolic"; $self->{proj_code} = "mbtfpp"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbtfpp::new()... 1; # Autogenerated code for the Proj4 projection code: # mbtfpq # package PDL::Transform::Proj4::mbtfpq; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbtfpq::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "McBryde-Thomas Flat-Polar Quartic"; $self->{proj_code} = "mbtfpq"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbtfpq::new()... 1; # Autogenerated code for the Proj4 projection code: # mbtfps # package PDL::Transform::Proj4::mbtfps; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbtfps::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "McBryde-Thomas Flat-Polar Sinusoidal"; $self->{proj_code} = "mbtfps"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbtfps::new()... 1; # Autogenerated code for the Proj4 projection code: # merc # package PDL::Transform::Proj4::merc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::merc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Mercator"; $self->{proj_code} = "merc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::merc::new()... 1; # Autogenerated code for the Proj4 projection code: # mil_os # package PDL::Transform::Proj4::mil_os; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mil_os::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Miller Oblated Stereographic"; $self->{proj_code} = "mil_os"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mil_os::new()... 1; # Autogenerated code for the Proj4 projection code: # mill # package PDL::Transform::Proj4::mill; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mill::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Miller Cylindrical"; $self->{proj_code} = "mill"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mill::new()... 1; # Autogenerated code for the Proj4 projection code: # misrsom # package PDL::Transform::Proj4::misrsom; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::misrsom::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Space oblique for MISR"; $self->{proj_code} = "misrsom"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( path ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::misrsom::new()... 1; # Autogenerated code for the Proj4 projection code: # moll # package PDL::Transform::Proj4::moll; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::moll::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Mollweide"; $self->{proj_code} = "moll"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::moll::new()... 1; # Autogenerated code for the Proj4 projection code: # murd1 # package PDL::Transform::Proj4::murd1; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::murd1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Murdoch I"; $self->{proj_code} = "murd1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::murd1::new()... 1; # Autogenerated code for the Proj4 projection code: # murd2 # package PDL::Transform::Proj4::murd2; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::murd2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Murdoch II"; $self->{proj_code} = "murd2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::murd2::new()... 1; # Autogenerated code for the Proj4 projection code: # murd3 # package PDL::Transform::Proj4::murd3; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::murd3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Murdoch III"; $self->{proj_code} = "murd3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::murd3::new()... 1; # Autogenerated code for the Proj4 projection code: # natearth # package PDL::Transform::Proj4::natearth; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::natearth::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Natural Earth"; $self->{proj_code} = "natearth"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::natearth::new()... 1; # Autogenerated code for the Proj4 projection code: # natearth2 # package PDL::Transform::Proj4::natearth2; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::natearth2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Natural Earth 2"; $self->{proj_code} = "natearth2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::natearth2::new()... 1; # Autogenerated code for the Proj4 projection code: # nell # package PDL::Transform::Proj4::nell; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nell::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Nell"; $self->{proj_code} = "nell"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nell::new()... 1; # Autogenerated code for the Proj4 projection code: # nell_h # package PDL::Transform::Proj4::nell_h; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nell_h::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Nell-Hammer"; $self->{proj_code} = "nell_h"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nell_h::new()... 1; # Autogenerated code for the Proj4 projection code: # nicol # package PDL::Transform::Proj4::nicol; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nicol::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Nicolosi Globular"; $self->{proj_code} = "nicol"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nicol::new()... 1; # Autogenerated code for the Proj4 projection code: # nsper # package PDL::Transform::Proj4::nsper; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nsper::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Near-sided perspective"; $self->{proj_code} = "nsper"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( h ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nsper::new()... 1; # Autogenerated code for the Proj4 projection code: # nzmg # package PDL::Transform::Proj4::nzmg; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nzmg::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "New Zealand Map Grid"; $self->{proj_code} = "nzmg"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nzmg::new()... 1; # Autogenerated code for the Proj4 projection code: # ob_tran # package PDL::Transform::Proj4::ob_tran; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ob_tran::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "General Oblique Transformation"; $self->{proj_code} = "ob_tran"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( o_proj o_lat_p o_lon_p o_alpha o_lon_c o_lat_c o_lon_1 o_lat_1 o_lon_2 o_lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ob_tran::new()... 1; # Autogenerated code for the Proj4 projection code: # ocea # package PDL::Transform::Proj4::ocea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ocea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Oblique Cylindrical Equal Area"; $self->{proj_code} = "ocea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 lon_1 lon_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ocea::new()... 1; # Autogenerated code for the Proj4 projection code: # oea # package PDL::Transform::Proj4::oea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::oea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Oblated Equal Area"; $self->{proj_code} = "oea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( n m theta ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::oea::new()... 1; # Autogenerated code for the Proj4 projection code: # omerc # package PDL::Transform::Proj4::omerc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::omerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Oblique Mercator"; $self->{proj_code} = "omerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( alpha gamma no_off lonc lon_1 lat_1 lon_2 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::omerc::new()... 1; # Autogenerated code for the Proj4 projection code: # ortel # package PDL::Transform::Proj4::ortel; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ortel::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Ortelius Oval"; $self->{proj_code} = "ortel"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ortel::new()... 1; # Autogenerated code for the Proj4 projection code: # ortho # package PDL::Transform::Proj4::ortho; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ortho::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Orthographic"; $self->{proj_code} = "ortho"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ortho::new()... 1; # Autogenerated code for the Proj4 projection code: # patterson # package PDL::Transform::Proj4::patterson; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::patterson::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Patterson Cylindrical"; $self->{proj_code} = "patterson"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::patterson::new()... 1; # Autogenerated code for the Proj4 projection code: # pconic # package PDL::Transform::Proj4::pconic; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::pconic::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Perspective Conic"; $self->{proj_code} = "pconic"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::pconic::new()... 1; # Autogenerated code for the Proj4 projection code: # poly # package PDL::Transform::Proj4::poly; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::poly::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Polyconic (American)"; $self->{proj_code} = "poly"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::poly::new()... 1; # Autogenerated code for the Proj4 projection code: # putp1 # package PDL::Transform::Proj4::putp1; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P1"; $self->{proj_code} = "putp1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp1::new()... 1; # Autogenerated code for the Proj4 projection code: # putp2 # package PDL::Transform::Proj4::putp2; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P2"; $self->{proj_code} = "putp2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp2::new()... 1; # Autogenerated code for the Proj4 projection code: # putp3 # package PDL::Transform::Proj4::putp3; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P3"; $self->{proj_code} = "putp3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp3::new()... 1; # Autogenerated code for the Proj4 projection code: # putp3p # package PDL::Transform::Proj4::putp3p; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp3p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P3'"; $self->{proj_code} = "putp3p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp3p::new()... 1; # Autogenerated code for the Proj4 projection code: # putp4p # package PDL::Transform::Proj4::putp4p; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp4p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P4'"; $self->{proj_code} = "putp4p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp4p::new()... 1; # Autogenerated code for the Proj4 projection code: # putp5 # package PDL::Transform::Proj4::putp5; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P5"; $self->{proj_code} = "putp5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp5::new()... 1; # Autogenerated code for the Proj4 projection code: # putp5p # package PDL::Transform::Proj4::putp5p; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp5p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P5'"; $self->{proj_code} = "putp5p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp5p::new()... 1; # Autogenerated code for the Proj4 projection code: # putp6 # package PDL::Transform::Proj4::putp6; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp6::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P6"; $self->{proj_code} = "putp6"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp6::new()... 1; # Autogenerated code for the Proj4 projection code: # putp6p # package PDL::Transform::Proj4::putp6p; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp6p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Putnins P6'"; $self->{proj_code} = "putp6p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp6p::new()... 1; # Autogenerated code for the Proj4 projection code: # qsc # package PDL::Transform::Proj4::qsc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::qsc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Quadrilateralized Spherical Cube"; $self->{proj_code} = "qsc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::qsc::new()... 1; # Autogenerated code for the Proj4 projection code: # qua_aut # package PDL::Transform::Proj4::qua_aut; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::qua_aut::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Quartic Authalic"; $self->{proj_code} = "qua_aut"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::qua_aut::new()... 1; # Autogenerated code for the Proj4 projection code: # rhealpix # package PDL::Transform::Proj4::rhealpix; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::rhealpix::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "rHEALPix"; $self->{proj_code} = "rhealpix"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( south_square ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::rhealpix::new()... 1; # Autogenerated code for the Proj4 projection code: # robin # package PDL::Transform::Proj4::robin; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::robin::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Robinson"; $self->{proj_code} = "robin"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::robin::new()... 1; # Autogenerated code for the Proj4 projection code: # rouss # package PDL::Transform::Proj4::rouss; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::rouss::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Roussilhe Stereographic"; $self->{proj_code} = "rouss"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::rouss::new()... 1; # Autogenerated code for the Proj4 projection code: # rpoly # package PDL::Transform::Proj4::rpoly; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::rpoly::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Rectangular Polyconic"; $self->{proj_code} = "rpoly"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::rpoly::new()... 1; # Autogenerated code for the Proj4 projection code: # sch # package PDL::Transform::Proj4::sch; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::sch::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Spherical Cross-track Height"; $self->{proj_code} = "sch"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( plat_0 plon_0 phdg_0 h_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::sch::new()... 1; # Autogenerated code for the Proj4 projection code: # sinu # package PDL::Transform::Proj4::sinu; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::sinu::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Sinusoidal (Sanson-Flamsteed)"; $self->{proj_code} = "sinu"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::sinu::new()... 1; # Autogenerated code for the Proj4 projection code: # somerc # package PDL::Transform::Proj4::somerc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::somerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Swiss. Obl. Mercator"; $self->{proj_code} = "somerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::somerc::new()... 1; # Autogenerated code for the Proj4 projection code: # stere # package PDL::Transform::Proj4::stere; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::stere::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Stereographic"; $self->{proj_code} = "stere"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::stere::new()... 1; # Autogenerated code for the Proj4 projection code: # sterea # package PDL::Transform::Proj4::sterea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::sterea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Oblique Stereographic Alternative"; $self->{proj_code} = "sterea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::sterea::new()... 1; # Autogenerated code for the Proj4 projection code: # tcc # package PDL::Transform::Proj4::tcc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tcc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Transverse Central Cylindrical"; $self->{proj_code} = "tcc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tcc::new()... 1; # Autogenerated code for the Proj4 projection code: # tcea # package PDL::Transform::Proj4::tcea; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tcea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Transverse Cylindrical Equal Area"; $self->{proj_code} = "tcea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tcea::new()... 1; # Autogenerated code for the Proj4 projection code: # times # package PDL::Transform::Proj4::times; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::times::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Times"; $self->{proj_code} = "times"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::times::new()... 1; # Autogenerated code for the Proj4 projection code: # tissot # package PDL::Transform::Proj4::tissot; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tissot::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Tissot"; $self->{proj_code} = "tissot"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tissot::new()... 1; # Autogenerated code for the Proj4 projection code: # tmerc # package PDL::Transform::Proj4::tmerc; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Transverse Mercator"; $self->{proj_code} = "tmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tmerc::new()... 1; # Autogenerated code for the Proj4 projection code: # tpeqd # package PDL::Transform::Proj4::tpeqd; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tpeqd::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Two Point Equidistant"; $self->{proj_code} = "tpeqd"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lon_1 lat_2 lon_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tpeqd::new()... 1; # Autogenerated code for the Proj4 projection code: # tpers # package PDL::Transform::Proj4::tpers; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tpers::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Tilted perspective"; $self->{proj_code} = "tpers"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( tilt azi h ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tpers::new()... 1; # Autogenerated code for the Proj4 projection code: # ups # package PDL::Transform::Proj4::ups; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ups::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Universal Polar Stereographic"; $self->{proj_code} = "ups"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( south ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ups::new()... 1; # Autogenerated code for the Proj4 projection code: # urm5 # package PDL::Transform::Proj4::urm5; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::urm5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Urmaev V"; $self->{proj_code} = "urm5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( n q alpha ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::urm5::new()... 1; # Autogenerated code for the Proj4 projection code: # urmfps # package PDL::Transform::Proj4::urmfps; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::urmfps::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Urmaev Flat-Polar Sinusoidal"; $self->{proj_code} = "urmfps"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( n ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::urmfps::new()... 1; # Autogenerated code for the Proj4 projection code: # utm # package PDL::Transform::Proj4::utm; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::utm::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Universal Transverse Mercator (UTM)"; $self->{proj_code} = "utm"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( zone south ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::utm::new()... 1; # Autogenerated code for the Proj4 projection code: # vandg # package PDL::Transform::Proj4::vandg; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "van der Grinten (I)"; $self->{proj_code} = "vandg"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg::new()... 1; # Autogenerated code for the Proj4 projection code: # vandg2 # package PDL::Transform::Proj4::vandg2; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "van der Grinten II"; $self->{proj_code} = "vandg2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg2::new()... 1; # Autogenerated code for the Proj4 projection code: # vandg3 # package PDL::Transform::Proj4::vandg3; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "van der Grinten III"; $self->{proj_code} = "vandg3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg3::new()... 1; # Autogenerated code for the Proj4 projection code: # vandg4 # package PDL::Transform::Proj4::vandg4; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "van der Grinten IV"; $self->{proj_code} = "vandg4"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg4::new()... 1; # Autogenerated code for the Proj4 projection code: # vitk1 # package PDL::Transform::Proj4::vitk1; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vitk1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Vitkovsky I"; $self->{proj_code} = "vitk1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vitk1::new()... 1; # Autogenerated code for the Proj4 projection code: # wag1 # package PDL::Transform::Proj4::wag1; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Wagner I (Kavraisky VI)"; $self->{proj_code} = "wag1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag1::new()... 1; # Autogenerated code for the Proj4 projection code: # wag2 # package PDL::Transform::Proj4::wag2; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Wagner II"; $self->{proj_code} = "wag2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag2::new()... 1; # Autogenerated code for the Proj4 projection code: # wag3 # package PDL::Transform::Proj4::wag3; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Wagner III"; $self->{proj_code} = "wag3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag3::new()... 1; # Autogenerated code for the Proj4 projection code: # wag4 # package PDL::Transform::Proj4::wag4; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Wagner IV"; $self->{proj_code} = "wag4"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag4::new()... 1; # Autogenerated code for the Proj4 projection code: # wag5 # package PDL::Transform::Proj4::wag5; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Wagner V"; $self->{proj_code} = "wag5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag5::new()... 1; # Autogenerated code for the Proj4 projection code: # wag6 # package PDL::Transform::Proj4::wag6; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag6::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Wagner VI"; $self->{proj_code} = "wag6"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag6::new()... 1; # Autogenerated code for the Proj4 projection code: # wag7 # package PDL::Transform::Proj4::wag7; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag7::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Wagner VII"; $self->{proj_code} = "wag7"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag7::new()... 1; # Autogenerated code for the Proj4 projection code: # weren # package PDL::Transform::Proj4::weren; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::weren::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Werenskiold I"; $self->{proj_code} = "weren"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::weren::new()... 1; # Autogenerated code for the Proj4 projection code: # wink1 # package PDL::Transform::Proj4::wink1; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wink1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Winkel I"; $self->{proj_code} = "wink1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wink1::new()... 1; # Autogenerated code for the Proj4 projection code: # wink2 # package PDL::Transform::Proj4::wink2; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wink2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Winkel II"; $self->{proj_code} = "wink2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wink2::new()... 1; # Autogenerated code for the Proj4 projection code: # wintri # package PDL::Transform::Proj4::wintri; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wintri::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Winkel Tripel"; $self->{proj_code} = "wintri"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wintri::new()... 1; =head1 AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut # Exit with OK status 1; ��������������������������������������������������������������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Transform.pm����������������������������������������������������������������0000644�0601750�0601001�00000311676�13110402061�014624� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Transform; @EXPORT_OK = qw( apply invert map PDL::PP map unmap t_inverse t_compose t_wrap t_identity t_lookup t_linear t_scale t_offset t_rot t_fits t_code t_cylindrical t_radial t_quadratic t_cubic t_quadratic t_spherical t_projective ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Transform ; =head1 NAME PDL::Transform - Coordinate transforms, image warping, and N-D functions =head1 SYNOPSIS use PDL::Transform; my $t = new PDL::Transform::<type>(<opt>) $out = $t->apply($in) # Apply transform to some N-vectors (Transform method) $out = $in->apply($t) # Apply transform to some N-vectors (PDL method) $im1 = $t->map($im); # Transform image coordinates (Transform method) $im1 = $im->map($t); # Transform image coordinates (PDL method) $t2 = $t->compose($t1); # compose two transforms $t2 = $t x $t1; # compose two transforms (by analogy to matrix mult.) $t3 = $t2->inverse(); # invert a transform $t3 = !$t2; # invert a transform (by analogy to logical "not") =head1 DESCRIPTION PDL::Transform is a convenient way to represent coordinate transformations and resample images. It embodies functions mapping R^N -> R^M, both with and without inverses. Provision exists for parametrizing functions, and for composing them. You can use this part of the Transform object to keep track of arbitrary functions mapping R^N -> R^M with or without inverses. The simplest way to use a Transform object is to transform vector data between coordinate systems. The L<apply|/apply> method accepts a PDL whose 0th dimension is coordinate index (all other dimensions are threaded over) and transforms the vectors into the new coordinate system. Transform also includes image resampling, via the L<map|/map> method. You define a coordinate transform using a Transform object, then use it to remap an image PDL. The output is a remapped, resampled image. You can define and compose several transformations, then apply them all at once to an image. The image is interpolated only once, when all the composed transformations are applied. In keeping with standard practice, but somewhat counterintuitively, the L<map|/map> engine uses the inverse transform to map coordinates FROM the destination dataspace (or image plane) TO the source dataspace; hence PDL::Transform keeps track of both the forward and inverse transform. For terseness and convenience, most of the constructors are exported into the current package with the name C<< t_<transform> >>, so the following (for example) are synonyms: $t = new PDL::Transform::Radial(); # Long way $t = t_radial(); # Short way Several math operators are overloaded, so that you can compose and invert functions with expression syntax instead of method syntax (see below). =head1 EXAMPLE Coordinate transformations and mappings are a little counterintuitive at first. Here are some examples of transforms in action: use PDL::Transform; $a = rfits('m51.fits'); # Substitute path if necessary! $ts = t_linear(Scale=>3); # Scaling transform $w = pgwin(xs); $w->imag($a); ## Grow m51 by a factor of 3; origin is at lower left. $b = $ts->map($a,{pix=>1}); # pix option uses direct pixel coord system $w->imag($b); ## Shrink m51 by a factor of 3; origin still at lower left. $c = $ts->unmap($a, {pix=>1}); $w->imag($c); ## Grow m51 by a factor of 3; origin is at scientific origin. $d = $ts->map($a,$a->hdr); # FITS hdr template prevents autoscaling $w->imag($d); ## Shrink m51 by a factor of 3; origin is still at sci. origin. $e = $ts->unmap($a,$a->hdr); $w->imag($e); ## A no-op: shrink m51 by a factor of 3, then autoscale back to size $f = $ts->map($a); # No template causes autoscaling of output =head1 OPERATOR OVERLOADS =over 3 =item '!' The bang is a unary inversion operator. It binds exactly as tightly as the normal bang operator. =item 'x' By analogy to matrix multiplication, 'x' is the compose operator, so these two expressions are equivalent: $f->inverse()->compose($g)->compose($f) # long way !$f x $g x $f # short way Both of those expressions are equivalent to the mathematical expression f^-1 o g o f, or f^-1(g(f(x))). =item '**' By analogy to numeric powers, you can apply an operator a positive integer number of times with the ** operator: $f->compose($f)->compose($f) # long way $f**3 # short way =back =head1 INTERNALS Transforms are perl hashes. Here's a list of the meaning of each key: =over 3 =item func Ref to a subroutine that evaluates the transformed coordinates. It's called with the input coordinate, and the "params" hash. This springboarding is done via explicit ref rather than by subclassing, for convenience both in coding new transforms (just add the appropriate sub to the module) and in adding custom transforms at run-time. Note that, if possible, new C<func>s should support L<inplace|PDL::Core/inplace> operation to save memory when the data are flagged inplace. But C<func> should always return its result even when flagged to compute in-place. C<func> should treat the 0th dimension of its input as a dimensional index (running 0..N-1 for R^N operation) and thread over all other input dimensions. =item inv Ref to an inverse method that reverses the transformation. It must accept the same "params" hash that the forward method accepts. This key can be left undefined in cases where there is no inverse. =item idim, odim Number of useful dimensions for indexing on the input and output sides (ie the order of the 0th dimension of the coordinates to be fed in or that come out). If this is set to 0, then as many are allocated as needed. =item name A shorthand name for the transformation (convenient for debugging). You should plan on using UNIVERAL::isa to identify classes of transformation, e.g. all linear transformations should be subclasses of PDL::Transform::Linear. That makes it easier to add smarts to, e.g., the compose() method. =item itype An array containing the name of the quantity that is expected from the input piddle for the transform, for each dimension. This field is advisory, and can be left blank if there's no obvious quantity associated with the transform. This is analogous to the CTYPEn field used in FITS headers. =item oname Same as itype, but reporting what quantity is delivered for each dimension. =item iunit The units expected on input, if a specific unit (e.g. degrees) is expected. This field is advisory, and can be left blank if there's no obvious unit associated with the transform. =item ounit Same as iunit, but reporting what quantity is delivered for each dimension. =item params Hash ref containing relevant parameters or anything else the func needs to work right. =item is_inverse Bit indicating whether the transform has been inverted. That is useful for some stringifications (see the PDL::Transform::Linear stringifier), and may be useful for other things. =back Transforms should be inplace-aware where possible, to prevent excessive memory usage. If you define a new type of transform, consider generating a new stringify method for it. Just define the sub "stringify" in the subclass package. It should call SUPER::stringify to generate the first line (though the PDL::Transform::Composition bends this rule by tweaking the top-level line), then output (indented) additional lines as necessary to fully describe the transformation. =head1 NOTES Transforms have a mechanism for labeling the units and type of each coordinate, but it is just advisory. A routine to identify and, if necessary, modify units by scaling would be a good idea. Currently, it just assumes that the coordinates are correct for (e.g.) FITS scientific-to-pixel transformations. Composition works OK but should probably be done in a more sophisticated way so that, for example, linear transformations are combined at the matrix level instead of just strung together pixel-to-pixel. =head1 MODULE INTERFACE There are both operators and constructors. The constructors are all exported, all begin with "t_", and all return objects that are subclasses of PDL::Transform. The L<apply|/apply>, L<invert|/invert>, L<map|/map>, and L<unmap|/unmap> methods are also exported to the C<PDL> package: they are both Transform methods and PDL methods. =cut =head1 FUNCTIONS =cut =head2 apply =for sig Signature: (data(); PDL::Transform t) =for usage $out = $data->apply($t); $out = $t->apply($data); =for ref Apply a transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is a PDL to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar but transformed PDL. For convenience, this is both a PDL method and a Transform method. =cut use Carp; *PDL::apply = \&apply; sub apply { my($me) = shift; my($from) = shift; if(UNIVERSAL::isa($me,'PDL')){ my($a) = $from; $from = $me; $me = $a; } if(UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($from,'PDL')){ croak "Applying a PDL::Transform with no func! Oops.\n" unless(defined($me->{func}) and ref($me->{func}) eq 'CODE'); my $result = &{$me->{func}}($from,$me->{params}); $result->is_inplace(0); # clear inplace flag, just in case. return $result; } else { croak "apply requires both a PDL and a PDL::Transform.\n"; } } =head2 invert =for sig Signature: (data(); PDL::Transform t) =for usage $out = $t->invert($data); $out = $data->invert($t); =for ref Apply an inverse transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is a piddle to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar piddle. For convenience this is both a PDL method and a PDL::Transform method. =cut *PDL::invert = \&invert; sub invert { my($me) = shift; my($data) = shift; if(UNIVERSAL::isa($me,'PDL')){ my($a) = $data; $data = $me; $me = $a; } if(UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($data,'PDL')){ croak "Inverting a PDL::Transform with no inverse! Oops.\n" unless(defined($me->{inv}) and ref($me->{inv}) eq 'CODE'); my $result = &{$me->{inv}}($data, $me->{params}); $result->is_inplace(0); # make sure inplace flag is clear. return $result; } else { croak("invert requires a PDL and a PDL::Transform (did you want 'inverse' instead?)\n"); } } =head2 map =for sig Signature: (k0(); SV *in; SV *out; SV *map; SV *boundary; SV *method; SV *big; SV *blur; SV *sv_min; SV *flux; SV *bv) =head2 match =for usage $b = $a->match($c); # Match $c's header and size $b = $a->match([100,200]); # Rescale to 100x200 pixels $b = $a->match([100,200],{rect=>1}); # Rescale and remove rotation/skew. =for ref Resample a scientific image to the same coordinate system as another. The example above is syntactic sugar for $b = $a->map(t_identity, $c, ...); it resamples the input PDL with the identity transformation in scientific coordinates, and matches the pixel coordinate system to $c's FITS header. There is one difference between match and map: match makes the C<rectify> option to C<map> default to 0, not 1. This only affects matching where autoscaling is required (i.e. the array ref example above). By default, that example simply scales $a to the new size and maintains any rotation or skew in its scientiic-to-pixel coordinate transform. =head2 map =for usage $b = $a->map($xform,[<template>],[\%opt]); # Distort $a with transform $xform $b = $a->map(t_identity,[$pdl],[\%opt]); # rescale $a to match $pdl's dims. =for ref Resample an image or N-D dataset using a coordinate transform. The data are resampled so that the new pixel indices are proportional to the transformed coordinates rather than the original ones. The operation uses the inverse transform: each output pixel location is inverse-transformed back to a location in the original dataset, and the value is interpolated or sampled appropriately and copied into the output domain. A variety of sampling options are available, trading off speed and mathematical correctness. For convenience, this is both a PDL method and a PDL::Transform method. C<map> is FITS-aware: if there is a FITS header in the input data, then the coordinate transform acts on the scientific coordinate system rather than the pixel coordinate system. By default, the output coordinates are separated from pixel coordinates by a single layer of indirection. You can specify the mapping between output transform (scientific) coordinates to pixel coordinates using the C<orange> and C<irange> options (see below), or by supplying a FITS header in the template. If you don't specify an output transform, then the output is autoscaled: C<map> transforms a few vectors in the forward direction to generate a mapping that will put most of the data on the image plane, for most transformations. The calculated mapping gets stuck in the output's FITS header. Autoscaling is especially useful for rescaling images -- if you specify the identity transform and allow autoscaling, you duplicate the functionality of L<rescale2d|PDL::Image2D/rescale2d>, but with more options for interpolation. You can operate in pixel space, and avoid autoscaling of the output, by setting the C<nofits> option (see below). The output has the same data type as the input. This is a feature, but it can lead to strange-looking banding behaviors if you use interpolation on an integer input variable. The C<template> can be one of: =over 3 =item * a PDL The PDL and its header are copied to the output array, which is then populated with data. If the PDL has a FITS header, then the FITS transform is automatically applied so that $t applies to the output scientific coordinates and not to the output pixel coordinates. In this case the NAXIS fields of the FITS header are ignored. =item * a FITS header stored as a hash ref The FITS NAXIS fields are used to define the output array, and the FITS transformation is applied to the coordinates so that $t applies to the output scientific coordinates. =item * a list ref This is a list of dimensions for the output array. The code estimates appropriate pixel scaling factors to fill the available space. The scaling factors are placed in the output FITS header. =item * nothing In this case, the input image size is used as a template, and scaling is done as with the list ref case (above). =back OPTIONS: The following options are interpreted: =over 3 =item b, bound, boundary, Boundary (default = 'truncate') This is the boundary condition to be applied to the input image; it is passed verbatim to L<range|PDL::Slices/range> or L<interpND|PDL::Primitive/interpND> in the sampling or interpolating stage. Other values are 'forbid','extend', and 'periodic'. You can abbreviate this to a single letter. The default 'truncate' causes the entire notional space outside the original image to be filled with 0. =item pix, Pixel, nf, nofits, NoFITS (default = 0) If you set this to a true value, then FITS headers and interpretation are ignored; the transformation is treated as being in raw pixel coordinates. =item j, J, just, justify, Justify (default = 0) If you set this to 1, then output pixels are autoscaled to have unit aspect ratio in the output coordinates. If you set it to a non-1 value, then it is the aspect ratio between the first dimension and all subsequent dimensions -- or, for a 2-D transformation, the scientific pixel aspect ratio. Values less than 1 shrink the scale in the first dimension compared to the other dimensions; values greater than 1 enlarge it compared to the other dimensions. (This is the same sense as in the L<PGPLOT|PDL::Graphics::PGPLOT>interface.) =item ir, irange, input_range, Input_Range This is a way to modify the autoscaling. It specifies the range of input scientific (not necessarily pixel) coordinates that you want to be mapped to the output image. It can be either a nested array ref or a piddle. The 0th dim (outside coordinate in the array ref) is dimension index in the data; the 1st dim should have order 2. For example, passing in either [[-1,2],[3,4]] or pdl([[-1,2],[3,4]]) limites the map to the quadrilateral in input space defined by the four points (-1,3), (-1,4), (2,4), and (2,3). As with plain autoscaling, the quadrilateral gets sparsely sampled by the autoranger, so pathological transformations can give you strange results. This parameter is overridden by C<orange>, below. =item or, orange, output_range, Output_Range This sets the window of output space that is to be sampled onto the output array. It works exactly like C<irange>, except that it specifies a quadrilateral in output space. Since the output pixel array is itself a quadrilateral, you get pretty much exactly what you asked for. This parameter overrides C<irange>, if both are specified. It forces rectification of the output (so that scientific axes align with the pixel grid). =item r, rect, rectify This option defaults TRUE and controls how autoscaling is performed. If it is true or undefined, then autoscaling adjusts so that pixel coordinates in the output image are proportional to individual scientific coordinates. If it is false, then autoscaling automatically applies the inverse of any input FITS transformation *before* autoscaling the pixels. In the special case of linear transformations, this preserves the rectangular shape of the original pixel grid and makes output pixel coordinate proportional to input coordinate. =item m, method, Method This option controls the interpolation method to be used. Interpolation greatly affects both speed and quality of output. For most cases the option is directly passed to L<interpND|PDL::Primitive/interpnd> for interpolation. Possible options, in order from fastest to slowest, are: =over 3 =item * s, sample (default for ints) Pixel values in the output plane are sampled from the closest data value in the input plane. This is very fast but not very accurate for either magnification or decimation (shrinking). It is the default for templates of integer type. =item * l, linear (default for floats) Pixel values are linearly interpolated from the closest data value in the input plane. This is reasonably fast but only accurate for magnification. Decimation (shrinking) of the image causes aliasing and loss of photometry as features fall between the samples. It is the default for floating-point templates. =item * c, cubic Pixel values are interpolated using an N-cubic scheme from a 4-pixel N-cube around each coordinate value. As with linear interpolation, this is only accurate for magnification. =item * f, fft Pixel values are interpolated using the term coefficients of the Fourier transform of the original data. This is the most appropriate technique for some kinds of data, but can yield undesired "ringing" for expansion of normal images. Best suited to studying images with repetitive or wavelike features. =item * h, hanning Pixel values are filtered through a spatially-variable filter tuned to the computed Jacobian of the transformation, with hanning-window (cosine) pixel rolloff in each dimension. This prevents aliasing in the case where the image is distorted or shrunk, but allows small amounts of aliasing at pixel edges wherever the image is enlarged. =item * g, gaussian, j, jacobian Pixel values are filtered through a spatially-variable filter tuned to the computed Jacobian of the transformation, with radial Gaussian rolloff. This is the most accurate resampling method, in the sense of introducing the fewest artifacts into a properly sampled data set. This method uses a lookup table to speed up calculation of the Gaussian weighting. =item * G This method works exactly like 'g' (above), except that the Gaussian values are computed explicitly for every sample -- which is considerably slower. =back =item blur, Blur (default = 1.0) This value scales the input-space footprint of each output pixel in the gaussian and hanning methods. It's retained for historical reasons. Larger values yield blurrier images; values significantly smaller than unity cause aliasing. The parameter has slightly different meanings for Gaussian and Hanning interpolation. For Hanning interpolation, numbers smaller than unity control the sharpness of the border at the edge of each pixel (so that blur=>0 is equivalent to sampling for non-decimating transforms). For Gaussian interpolation, the blur factor parameter controls the width parameter of the Gaussian around the center of each pixel. =item sv, SV (default = 1.0) This value lets you set the lower limit of the transformation's singular values in the hanning and gaussian methods, limiting the minimum radius of influence associated with each output pixel. Large numbers yield smoother interpolation in magnified parts of the image but don't affect reduced parts of the image. =item big, Big (default = 0.5) This is the largest allowable input spot size which may be mapped to a single output pixel by the hanning and gaussian methods, in units of the largest non-thread input dimension. (i.e. the default won't let you reduce the original image to less than 5 pixels across). This places a limit on how long the processing can take for pathological transformations. Smaller numbers keep the code from hanging for a long time; larger numbers provide for photometric accuracy in more pathological cases. Numbers larer than 1.0 are silly, because they allow the entire input array to be compressed into a region smaller than a single pixel. Wherever an output pixel would require averaging over an area that is too big in input space, it instead gets NaN or the bad value. =item phot, photometry, Photometry This lets you set the style of photometric conversion to be used in the hanning or gaussian methods. You may choose: =over 3 =item * 0, s, surf, surface, Surface (default) (this is the default): surface brightness is preserved over the transformation, so features maintain their original intensity. This is what the sampling and interpolation methods do. =item * 1, f, flux, Flux Total flux is preserved over the transformation, so that the brightness integral over image regions is preserved. Parts of the image that are shrunk wind up brighter; parts that are enlarged end up fainter. =back =back VARIABLE FILTERING: The 'hanning' and 'gaussian' methods of interpolation give photometrically accurate resampling of the input data for arbitrary transformations. At each pixel, the code generates a linear approximation to the input transformation, and uses that linearization to estimate the "footprint" of the output pixel in the input space. The output value is a weighted average of the appropriate input spaces. A caveat about these methods is that they assume the transformation is continuous. Transformations that contain discontinuities will give incorrect results near the discontinuity. In particular, the 180th meridian isn't handled well in lat/lon mapping transformations (see L<PDL::Transform::Cartography>) -- pixels along the 180th meridian get the average value of everything along the parallel occupied by the pixel. This flaw is inherent in the assumptions that underly creating a Jacobian matrix. Maybe someone will write code to work around it. Maybe that someone is you. BAD VALUES: If your PDL was compiled with bad value support, C<map()> supports bad values in the data array. Bad values in the input array are propagated to the output array. The 'g' and 'h' methods will do some smoothing over bad values: if more than 1/3 of the weighted input-array footprint of a given output pixel is bad, then the output pixel gets marked bad. =for bad map does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::match { # Set default for rectification to 0 for simple matching... if( ref($_[$#_]) ne 'HASH' ) { push(@_,{}) } my @k = grep(m/^r(e(c(t)?)?)?/,keys %{$_[$#_]}); unless(@k) { $_[$#_]->{rectify} = 0; } t_identity()->map(@_); } *PDL::map = \↦ sub map { my($me) = shift; my($in) = shift; if(UNIVERSAL::isa($me,'PDL') && UNIVERSAL::isa($in,'PDL::Transform')) { my($a) = $in; $in = $me; $me = $a; } barf ("PDL::Transform::map: source is not defined or is not a PDL\n") unless(defined $in and UNIVERSAL::isa($in,'PDL')); barf ("PDL::Transform::map: source is empty\n") unless($in->nelem); my($tmp) = shift; my($opt) = shift; # Check for options-but-no-template case if(ref $tmp eq 'HASH' && !(defined $opt)) { if(!defined($tmp->{NAXIS})) { # FITS headers all have NAXIS. $opt = $tmp; $tmp = undef; } } croak("PDL::Transform::map: Option 'p' was ambiguous and has been removed. You probably want 'pix' or 'phot'.") if exists($opt->{'p'}); $tmp = [$in->dims] unless(defined($tmp)); # Generate an appropriate output piddle for values to go in my($out); my(@odims); my($ohdr); if(UNIVERSAL::isa($tmp,'PDL')) { @odims = $tmp->dims; my($a); if(defined ($a = $tmp->gethdr)) { my(%b) = %{$a}; $ohdr = \%b; } } elsif(ref $tmp eq 'HASH') { # (must be a fits header -- or would be filtered above) for my $i(1..$tmp->{NAXIS}){ push(@odims,$tmp->{"NAXIS$i"}); } # deep-copy fits header into output my %foo = %{$tmp}; $ohdr = \%foo; } elsif(ref $tmp eq 'ARRAY') { @odims = @$tmp; } else { barf("map: confused about dimensions of the output array...\n"); } if(scalar(@odims) < scalar($in->dims)) { my @idims = $in->dims; push(@odims, splice(@idims,scalar(@odims))); } $out = PDL::new_from_specification('PDL',$in->type,@odims); $out->sethdr($ohdr) if defined($ohdr); if($PDL::Bad::Status) { # set badflag on output all the time if possible, to account for boundary violations $out->badflag(1); } ############################## ## Figure out the dimensionality of the ## transform itself (extra dimensions come along for the ride) my $nd = $me->{odim} || $me->{idim} || 2; my @sizes = $out->dims; my @dd = @sizes; splice @dd,$nd; # Cut out dimensions after the end # Check that there are elements in the output fields... barf "map: output has no dims!\n" unless(@dd); my $ddtotal = 1; map {$ddtotal *= $_} @dd; barf "map: output has no elements (at least one dim is 0)!\n" unless($ddtotal); ############################## # If necessary, generate an appropriate FITS header for the output. my $nofits = _opt($opt, ['nf','nofits','NoFITS','pix','pixel','Pixel']); ############################## # Autoscale by transforming a subset of the input points' coordinates # to the output range, and pick a FITS header that fits the output # coordinates into the given template. # # Autoscaling always produces a simple, linear mapping in the FITS header. # We support more complex mappings (via t_fits) but only to match a pre-existing # FITS header (which doesn't use autoscaling). # # If the rectify option is set (the default) then the image is rectified # in scientific coordinates; if it is clear, then the existing matrix # is used, preserving any shear or rotation in the coordinate system. # Since we eschew CROTA whenever possible, the CDi_j formalism is used instead. my $f_in = (defined($in->hdr->{NAXIS}) ? t_fits($in,{ignore_rgb=>1}) : t_identity()); unless((defined $out->gethdr && $out->hdr->{NAXIS}) or $nofits) { print "generating output FITS header..." if($PDL::Transform::debug); $out->sethdr($in->hdr_copy) # Copy extraneous fields... if(defined $in->hdr); my $samp_ratio = 300; my $orange = _opt($opt, ['or','orange','output_range','Output_Range'], undef); my $omin; my $omax; my $osize; my $rectify = _opt($opt,['r','rect','rectify','Rectify'],1); if (defined $orange) { # orange always rectifies the coordinates -- the output scientific # coordinates *must* align with the axes, or orange wouldn't make # sense. print "using user's orange..." if($PDL::Transform::debug); $orange = pdl($orange) unless(UNIVERSAL::isa($orange,'PDL')); barf "map: orange must be 2xN for an N-D transform" unless ( (($orange->dim(1)) == $nd ) && $orange->ndims == 2); $omin = $orange->slice("(0)"); $omax = $orange->slice("(1)"); $osize = $omax - $omin; $rectify = 1; } else { ############################## # Real autoscaling happens here. if(!$rectify and ref( $f_in ) !~ /Linear/i) { if( $f_in->{name} ne 'identity' ) { print STDERR "Warning: map can't preserve nonlinear FITS distortions while autoscaling.\n"; } $rectify=1; } my $f_tr = ( $rectify ? $me x $f_in : ( ($me->{name} eq 'identity') ? # Simple optimization for match() $me : # identity -- just matching !$f_in x $me x $f_in # common case ) ); my $samps = (pdl(($in->dims)[0..$nd-1]))->clip(0,$samp_ratio); my $coords = ndcoords(($samps + 1)->list); my $t; my $irange = _opt($opt, ['ir','irange','input_range','Input_Range'], undef); # If input range is defined, sample that quadrilateral -- else # sample the quad defined by the boundaries of the input image. if(defined $irange) { print "using user's irange..." if($PDL::Transform::debug); $irange = pdl($irange) unless(UNIVERSAL::isa($irange,'PDL')); barf "map: irange must be 2xN for an N-D transform" unless ( (($irange->dim(1)) == $nd ) && $irange->ndims == 2); $coords *= ($irange->slice("(1)") - $irange->slice("(0)")) / $samps; $coords += $irange->slice("(0)"); $coords -= 0.5; # offset to pixel corners... $t = $me; } else { $coords *= pdl(($in->dims)[0..$nd-1]) / $samps; $coords -= 0.5; # offset to pixel corners... $t = $f_tr; } my $ocoords = $t->apply($coords)->mv(0,-1)->clump($nd); # discard non-finite entries my $oc2 = $ocoords->range( which( $ocoords-> xchg(0,1)-> sumover-> isfinite ) ->dummy(0,1) ); $omin = $oc2->minimum; $omax = $oc2->maximum; $osize = $omax - $omin; my $tosize; ($tosize = $osize->where($osize == 0)) .= 1.0; } my ($scale) = $osize / pdl(($out->dims)[0..$nd-1]); my $justify = _opt($opt,['j','J','just','justify','Justify'],0); if($justify) { my $tmp; # work around perl -d "feature" ($tmp = $scale->slice("0")) *= $justify; $scale .= $scale->max; $scale->slice("0") /= $justify; } print "done with autoscale. Making fits header....\n" if($PDL::Transform::debug); if( $rectify ) { # Rectified header generation -- make a simple coordinate header with no # rotation or skew. print "rectify\n" if($PDL::Transform::debug); for my $d(1..$nd) { $out->hdr->{"CRPIX$d"} = 1 + ($out->dim($d-1)-1)/2 ; $out->hdr->{"CDELT$d"} = $scale->at($d-1); $out->hdr->{"CRVAL$d"} = ( $omin->at($d-1) + $omax->at($d-1) ) /2 ; $out->hdr->{"NAXIS$d"} = $out->dim($d-1); $out->hdr->{"CTYPE$d"} = ( (defined($me->{otype}) ? $me->{otype}->[$d-1] : "") || $in->hdr->{"CTYPE$d"} || ""); $out->hdr->{"CUNIT$d"} = ( (defined($me->{ounit}) ? $me->{ounit}->[$d-1] : "") || $in->hdr->{"CUNIT$d"} || $in->hdr->{"CTYPE$d"} || ""); } $out->hdr->{"NAXIS"} = $nd; $out->hdr->{"SIMPLE"} = 'T'; $out->hdr->{"HISTORY"} .= "Header written by PDL::Transform::Cartography::map"; ### Eliminate fancy newfangled output header pointing tags if they exist ### These are the CROTA<n>, PCi_j, and CDi_j. for $k(keys %{$out->hdr}) { if( $k=~m/(^CROTA\d*$)|(^(CD|PC)\d+_\d+[A-Z]?$)/ ){ delete $out->hdr->{$k}; } } } else { # Non-rectified output -- generate a CDi_j matrix instead of the simple formalism. # We have to deal with a linear transformation: we've got: (scaling) x !input x (t x input), # where input is a linear transformation with offset and scaling is a simple scaling. We have # the scaling parameters and the matrix for !input -- we have only to merge them and then we # can write out the FITS header in CDi_j form. print "non-rectify\n" if($PDL::Transform::debug); my $midpoint_val = (pdl(($out->dims)[0..$nd-1])/2 * $scale)->apply( $f_in ); print "midpoint_val is $midpoint_val\n" if($PDL::Transform::debug); # linear transformation unless(ref($f_in) =~ m/Linear/) { croak("Whups -- got a nonlinear t_fits transformation. Can't deal with it."); } my $inv_sc_mat = zeroes($nd,$nd); $inv_sc_mat->diagonal(0,1) .= $scale; my $mat = $f_in->{params}->{matrix} x $inv_sc_mat; print "scale is $scale; mat is $mat\n" if($PDL::Transform::debug); print "looping dims 1..$nd: " if($PDL::Transform::debug); for my $d(1..$nd) { print "$d..." if($PDL::Transform::debug); $out->hdr->{"CRPIX$d"} = 1 + ($out->dim($d-1)-1)/2; $out->hdr->{"CRVAL$d"} = $midpoint_val->at($d-1); $out->hdr->{"NAXIS$d"} = $out->dim($d-1); $out->hdr->{"CTYPE$d"} = ( (defined($me->{otype}) ? $me->{otype}->[$d-1] : "") || $in->hdr->{"CTYPE$d"} || ""); $out->hdr->{"CUNIT$d"} = ( (defined($me->{ounit}) ? $me->{ounit}->[$d-1] : "") || $in->hdr->{"CUNIT$d"} || $in->hdr->{"CTYPE$d"} || ""); for my $e(1..$nd) { $out->hdr->{"CD${d}_${e}"} = $mat->at($d-1,$e-1); print "setting CD${d}_${e} to ".$mat->at($d-1,$e-1)."\n" if($PDL::Transform::debug); } } ## Eliminate competing header pointing tags if they exist for $k(keys %{$out->hdr}) { if( $k =~ m/(^CROTA\d*$)|(^(PC)\d+_\d+[A-Z]?$)|(CDELT\d*$)/ ) { delete $out->hdr->{$k}; } } } } $out->hdrcpy(1); ############################## # Sandwich the transform between the input and output plane FITS headers. unless($nofits) { $me = !(t_fits($out,{ignore_rgb=>1})) x $me x $f_in; } ############################## ## Figure out the interpND options my $method = _opt($opt,['m','method','Method'],undef); my $bound = _opt($opt,['b','bound','boundary','Boundary'],'t'); ############################## ## Rubber meets the road: calculate the inverse transformed points. my $ndc = PDL::Basic::ndcoords(@dd); my $idx = $me->invert($ndc->double); barf "map: Transformation had no inverse\n" unless defined($idx); ############################## ## Integrate ? (Jacobian, Gaussian, Hanning) my $integrate = ($method =~ m/^[jghJGH]/) if defined($method); ############################## ## Sampling code: ## just transform and interpolate. ## ( Kind of an anticlimax after all that, eh? ) if(!$integrate) { my $a = $in->interpND($idx,{method=>$method, bound=>$bound}); my $tmp; # work around perl -d "feature" ($tmp = $out->slice(":")) .= $a; # trivial slice prevents header overwrite... return $out; } ############################## ## Anti-aliasing code: ## Condition the input and call the pixelwise C interpolator. ## barf("PDL::Transform::map: Too many dims in transformation\n") if($in->ndims < $idx->ndims-1); #################### ## Condition the threading -- pixelwise interpolator only threads ## in 1 dimension, so squish all thread dimensions into 1, if necessary my @iddims = $idx->dims; if($in->ndims == $#iddims) { $in2 = $in->dummy(-1,1); } else { $in2 = ( $in ->reorder($nd..$in->ndims-1, 0..$nd-1) ->clump($in->ndims - $nd) ->mv(0,-1) ); } #################### # Allocate the output array my $o2 = PDL->new_from_specification($in2->type, @iddims[1..$#iddims], $in2->dim(-1) ); #################### # Pack boundary string if necessary if(defined $bound) { if(ref $bound eq 'ARRAY') { my ($s,$el); foreach $el(@$bound) { barf "Illegal boundary value '$el' in range" unless( $el =~ m/^([0123fFtTeEpPmM])/ ); $s .= $1; } $bound = $s; } elsif($bound !~ m/^[0123ftepx]+$/ && $bound =~ m/^([0123ftepx])/i ) { $bound = $1; } } #################### # Get the blur and minimum-sv values my $blur = _opt($opt,['blur','Blur'],1.0); my $svmin = _opt($opt,['sv','SV'],1.0); my $big = _opt($opt,['big','Big'],1.0); my $flux = _opt($opt,['phot','photometry'],0); my @idims = $in->dims; $flux = ($flux =~ m/^[1fF]/); $big = $big * max(pdl(@idims[0..$nd])); $blur = $blur->at(0) if(ref $blur); $svmin = $svmin->at(0) if(ref $svmin); my $bv; if($PDL::Bad::Status and $in->badflag){ $bv = $in->badvalue; } else { $bv = 0; } ### The first argument is a dummy to set $GENERIC. $idx = double($idx) unless($idx->type == double); print "Calling _map_int...\n" if($PDL::Transform::debug); &PDL::_map_int( $in2->flat->index(0), $in2, $o2, $idx, $bound, $method, $big, $blur, $svmin, $flux, $bv); my @rdims = (@iddims[1..$#iddims], @idims[$#iddims..$#idims]); { my $tmp; # work around perl -d "feature" ($tmp = $out->slice(":")) .= $o2->reshape(@rdims); } return $out; } *map = \&PDL::map; ###################################################################### =head2 unmap =for sig Signature: (data(); PDL::Transform a; template(); \%opt) =for usage $out_image = $in_image->unmap($t,[<options>],[<template>]); $out_image = $t->unmap($in_image,[<options>],[<template>]); =for ref Map an image or N-D dataset using the inverse as a coordinate transform. This convenience function just inverts $t and calls L<map|/map> on the inverse; everything works the same otherwise. For convenience, it is both a PDL method and a PDL::Transform method. =cut *PDL::unmap = \&unmap; sub unmap { my($me) = shift; my($data) = shift; my(@params) = @_; if(UNIVERSAL::isa($data,'PDL::Transform') && UNIVERSAL::isa($me,'PDL')) { my $a = $data; $data = $me; $me = $a; } return $me->inverse->map($data,@params); } =head2 t_inverse =for usage $t2 = t_inverse($t); $t2 = $t->inverse; $t2 = $t ** -1; $t2 = !$t; =for ref Return the inverse of a PDL::Transform. This just reverses the func/inv, idim/odim, itype/otype, and iunit/ounit pairs. Note that sometimes you end up with a transform that cannot be applied or mapped, because either the mathematical inverse doesn't exist or the inverse func isn't implemented. You can invert a transform by raising it to a negative power, or by negating it with '!'. The inverse transform remains connected to the main transform because they both point to the original parameters hash. That turns out to be useful. =cut *t_inverse = \&inverse; sub inverse { my($me) = shift; unless(defined($me->{inv})) { Carp::cluck("PDL::Transform::inverse: got a transform with no inverse.\n"); return undef; } my(%out) = %$me; # force explicit copy of top-level my($out) = \%out; $out->{inv} = $me->{func}; $out->{func} = $me->{inv}; $out->{idim} = $me->{odim}; $out->{odim} = $me->{idim}; $out->{otype} = $me->{itype}; $out->{itype} = $me->{otype}; $out->{ounit} = $me->{iunit}; $out->{iunit} = $me->{ounit}; $out->{name} = "(inverse ".$me->{name}.")"; $out->{is_inverse} = !($out->{is_inverse}); bless $out,(ref $me); return $out; } =head2 t_compose =for usage $f2 = t_compose($f, $g,[...]); $f2 = $f->compose($g[,$h,$i,...]); $f2 = $f x $g x ...; =for ref Function composition: f(g(x)), f(g(h(x))), ... You can also compose transforms using the overloaded matrix-multiplication (nee repeat) operator 'x'. This is accomplished by inserting a splicing code ref into the C<func> and C<inv> slots. It combines multiple compositions into a single list of transforms to be executed in order, fram last to first (in keeping with standard mathematical notation). If one of the functions is itself a composition, it is interpolated into the list rather than left separate. Ultimately, linear transformations may also be combined within the list. No checking is done that the itype/otype and iunit/ounit fields are compatible -- that may happen later, or you can implement it yourself if you like. =cut @PDL::Transform::Composition::ISA = ('PDL::Transform'); sub PDL::Transform::Composition::stringify { package PDL::Transform::Composition; my($me) = shift; my($out) = SUPER::stringify $me; $out; } *t_compose = \&compose; sub compose { local($_); my(@funcs) = @_; my($me) = PDL::Transform->new; # No inputs case: return the identity function return $me if(!@funcs); $me->{name} = ""; my($f); my(@clist); for $f(@funcs) { $me->{idim} = $f->{idim} if($f->{idim} > $me->{idim}); $me->{odim} = $f->{odim} if($f->{odim} > $me->{odim}); if(UNIVERSAL::isa($f,"PDL::Transform::Composition")) { if($f->{is_inverse}) { for(reverse(@{$f->{params}->{clist}})) { push(@clist,$_->inverse); $me->{name} .= " o inverse ( ".$_->{name}." )"; } } else { for(@{$f->{params}->{clist}}) { push(@clist,$_); $me->{name} .= " o ".$_->{name}; } } } else { # Not a composition -- just push the transform onto the list. push(@clist,$f); $me->{name} .= " o ".$f->{name}; } } $me->{name}=~ s/^ o //; # Get rid of leading composition mark $me->{otype} = $funcs[0]->{otype}; $me->{ounit} = $funcs[0]->{ounit}; $me->{itype} = $funcs[-1]->{itype}; $me->{iunit} = $funcs[-1]->{iunit}; $me->{params}->{clist} = \@clist; $me->{func} = sub { my ($data,$p) = @_; my ($ip) = $data->is_inplace; for my $t ( reverse @{$p->{clist}} ) { croak("Error: tried to apply a PDL::Transform with no function inside a composition!\n offending transform: $t\n") unless(defined($t->{func}) and ref($t->{func}) eq 'CODE'); $data = $t->{func}($ip ? $data->inplace : $data, $t->{params}); } $data->is_inplace(0); # clear inplace flag (avoid core bug with inplace) $data; }; $me->{inv} = sub { my($data,$p) = @_; my($ip) = $data->is_inplace; for my $t ( @{$p->{clist}} ) { croak("Error: tried to invert a non-invertible PDL::Transform inside a composition!\n offending transform: $t\n") unless(defined($t->{inv}) and ref($t->{inv}) eq 'CODE'); $data = &{$t->{inv}}($ip ? $data->inplace : $data, $t->{params}); } $data; }; return bless($me,'PDL::Transform::Composition'); } =head2 t_wrap =for usage $g1fg = $f->wrap($g); $g1fg = t_wrap($f,$g); =for ref Shift a transform into a different space by 'wrapping' it with a second. This is just a convenience function for two L<t_compose|/t_compose> calls. C<< $a->wrap($b) >> is the same as C<(!$b) x $a x $b>: the resulting transform first hits the data with $b, then with $a, then with the inverse of $b. For example, to shift the origin of rotation, do this: $im = rfits('m51.fits'); $tf = t_fits($im); $tr = t_linear({rot=>30}); $im1 = $tr->map($tr); # Rotate around pixel origin $im2 = $tr->map($tr->wrap($tf)); # Rotate round FITS scientific origin =cut *t_wrap = \&wrap; sub wrap { my($f) = shift; my($g) = shift; return $g->inverse->compose($f,$g); } ###################################################################### # Composition operator -- handles 'x'. sub _compose_op { my($a,$b,$c) = @_; $c ? compose($b,$a) : compose($a,$b); } # Raise-to-power operator -- handles '**'. sub _pow_op { my($a,$b,$c) = @_; barf("%s", "Can't raise anything to the power of a transform") if($c || UNIVERSAL::isa($b,'PDL::Transform')) ; $a = $a->inverse if($b < 0); return $a if(abs($b) == 1); return new PDL::Transform if(abs($b) == 0); my(@l); for my $i(1..abs($b)) { push(@l,$a); } t_compose(@l); } =head2 t_identity =for usage my $xform = t_identity my $xform = new PDL::Transform; =for ref Generic constructor generates the identity transform. This constructor really is trivial -- it is mainly used by the other transform constructors. It takes no parameters and returns the identity transform. =cut sub _identity { return shift; } sub t_identity { new PDL::Transform(@_) }; sub new { my($class) = shift; my $me = {name=>'identity', idim => 0, odim => 0, func=>\&PDL::Transform::_identity, inv=>\&PDL::Transform::_identity, params=>{} }; return bless $me,$class; } =head2 t_lookup =for usage $f = t_lookup($lookup, {<options>}); =for ref Transform by lookup into an explicit table. You specify an N+1-D PDL that is interpreted as an N-D lookup table of column vectors (vector index comes last). The last dimension has order equal to the output dimensionality of the transform. For added flexibility in data space, You can specify pre-lookup linear scaling and offset of the data. Of course you can specify the interpolation method to be used. The linear scaling stuff is a little primitive; if you want more, try composing the linear transform with this one. The prescribed values in the lookup table are treated as pixel-centered: that is, if your input array has N elements per row then valid data exist between the locations (-0.5) and (N-0.5) in lookup pixel space, because the pixels (which are numbered from 0 to N-1) are centered on their locations. Lookup is done using L<interpND|PDL::Primitive/interpnd>, so the boundary conditions and threading behaviour follow from that. The indexed-over dimensions come first in the table, followed by a single dimension containing the column vector to be output for each set of other dimensions -- ie to output 2-vectors from 2 input parameters, each of which can range from 0 to 49, you want an index that has dimension list (50,50,2). For the identity lookup table you could use C<cat(xvals(50,50),yvals(50,50))>. If you want to output a single value per input vector, you still need that last index threading dimension -- if necessary, use C<dummy(-1,1)>. The lookup index scaling is: out = lookup[ (scale * data) + offset ]. A simplistic table inversion routine is included. This means that you can (for example) use the C<map> method with C<t_lookup> transformations. But the table inversion is exceedingly slow, and not practical for tables larger than about 100x100. The inversion table is calculated in its entirety the first time it is needed, and then cached until the object is destroyed. Options are listed below; there are several synonyms for each. =over 3 =item s, scale, Scale (default 1.0) Specifies the linear amount of scaling to be done before lookup. You can feed in a scalar or an N-vector; other values may cause trouble. If you want to save space in your table, then specify smaller scale numbers. =item o, offset, Offset (default 0.0) Specifies the linear amount of offset before lookup. This is only a scalar, because it is intended to let you switch to corner-centered coordinates if you want to (just feed in o=-0.25). =item b, bound, boundary, Boundary Boundary condition to be fed to L<interpND|PDL::Primitive/interpND> =item m, method, Method Interpolation method to be fed to L<interpND|PDL::Primitive/interpND> =back EXAMPLE To scale logarithmically the Y axis of m51, try: $a = float rfits('m51.fits'); $lookup = xvals(128,128) -> cat( 10**(yvals(128,128)/50) * 256/10**2.55 ); $t = t_lookup($lookup); $b = $t->map($a); To do the same thing but with a smaller lookup table, try: $lookup = 16 * xvals(17,17)->cat(10**(yvals(17,17)/(100/16)) * 16/10**2.55); $t = t_lookup($lookup,{scale=>1/16.0}); $b = $t->map($a); (Notice that, although the lookup table coordinates are is divided by 16, it is a 17x17 -- so linear interpolation works right to the edge of the original domain.) NOTES Inverses are not yet implemented -- the best way to do it might be by judicious use of map() on the forward transformation. the type/unit fields are ignored. =cut sub t_lookup { my($class) = 'PDL::Transform'; my($source)= shift; my($o) = shift; if(!defined($o) && ((ref $source) eq 'HASH')) { Carp::cluck("lookup transform called as sub not method; using 'PDL::Transform' as class...\n"); $o = $source; $source = $class; $class = "PDL::Transform"; } $o = {} unless(ref $o eq 'HASH'); my($me) = PDL::Transform::new($class); my($bound) = _opt($o,['b','bound','boundary','Boundary']); my($method)= _opt($o,['m','meth','method','Method']); $me->{idim} = $source->ndims - 1; $me->{odim} = $source->dim($source->ndims-1); $me->{params} = { table => $source, scale => _opt($o,['s','scale','Scale'],1.0), offset => _opt($o,['o','off','offset','Offset'],0.0), interpND_opt => { method => $method, bound => $bound, bad => _opt($o,['bad'],0) } }; my $lookup_func = sub { my($data,$p,$table,$scale,$offset) = @_; $data = pdl($data) unless ((ref $data) && (UNIVERSAL::isa($data,'PDL'))); $main::foo = $data; if($data->dim(0) > $me->{idim}) { barf("Too many dims (".$data->dim(0).") for your table (".$me->{idim}.")\n"); }; my($a)= ($table ->interpND(float($data) * $scale + $offset, $p->{interpND_opt} ) ); # Put the index dimension (and threaded indices) back at the front of # the dimension list. my($dnd) = $data->ndims - 1; return ($a -> ndims > $data->ndims - 1) ? ($a->reorder( $dnd..($dnd + $table->ndims - $data->dim(0)-1) , 0..$data->ndims-2 ) ) : $a; }; $me->{func} = sub {my($data,$p) = @_; &$lookup_func($data,$p,$p->{table},$p->{scale},$p->{offset})}; ####### ## Lazy inverse -- find it if and only if we need it... $me->{inv} = sub { my $data = shift; my $p = shift; if(!defined($p->{'itable'})) { if($me->{idim} != $me->{odim}) { barf("t_lookup: can't calculate an inverse of a projection operation! (idim != odim)"); } print "t_lookup: Warning, table inversion is only weakly supported. \n I'll try to invert it using a pretty boneheaded algorithm...\n (If it takes too long, consider writing a faster algorithm!)\n Calculating inverse table (will be cached)...\n" if($PDL::verbose || $PDL::debug || $PDL::Transform::debug); my $itable = zeroes($p->{table}); my $minvals = $p->{table}->clump($me->{idim})->minimum; my $maxvals = $p->{table}->clump($me->{idim})->maximum; # Scale so that the range runs from 0 through the top pixel in the table my $scale = ( pdl( $itable->dims )->slice("0:-2")-1 ) / (($maxvals - $minvals)+ (($maxvals-$minvals) == 0)); my $offset = - ($minvals * $scale); $p->{iscale} = $scale; $p->{ioffset} = $offset; my $enl_scale = $p->{'enl_scale'} || 10; my $smallcoords = ndcoords((pdl($enl_scale * 2 + 1)->at(0)) x $me->{idim})/ $enl_scale - 1; # $oloop runs over (point, index) for all points in the output table, in # $p->{table} output space $oloop = ndcoords($itable->mv(-1,0)->slice("(0)"))-> double-> mv(0,-1)-> clump($itable->ndims-1); # oloop: (pixel, index) { my $tmp; # work around perl -d "feature" ($tmp = $oloop->mv(-1,0)) -= $offset; ($tmp = $oloop->mv(-1,0)) /= $scale; } # The Right Thing to do here is to take the outer product of $itable and $otable, then collapse # to find minimum distance. But memory demands for that would be HUGE. Instead we do an # elementwise calculation. print "t_lookup: inverting ".$oloop->dim(0)." points...\n" if($PDL::verbose || $PDL::debug || $PDL::Transform::debug); my $pt = $p->{table}->mv(-1,0); # pt runs (index, x,y,...) my $itable_flattened = zeroes($oloop); for $i(0..$oloop->dim(0)-1) { my $olp = $oloop->slice("($i)"); # olp runs (index) my $diff = ($pt - $olp); # diff runs (index, x, y, ...) my $r2 = ($diff * $diff)->sumover; # r2 runs (x,y,...) my $c = whichND($r2==$r2->min)->slice(":,(0)"); # c runs (index) # Now zero in on the neighborhood around the point of closest approach. my $neighborhood = $p->{table}->interpND($c + $smallcoords,{method=>'linear',bound=>'t'})-> mv(-1,0); # neighborhood runs (index, dx, dy,...) $diff = $neighborhood - $olp; # diff runs (index, dx, dy, ...) $r2 = ($diff * $diff)->sumover; # r2 runs (dx,dy,...) my $dc = $smallcoords->mv(0,-1)->indexND(0+whichND($r2==$r2->min)->slice(":,(0)")); my $coord = $c + $dc; # At last, we've found the best-fit to an enl_scale'th of an input-table pixel. # Back it out to input-science coordinates, and stuff it in the inverse table. my $tmp; # work around perl -d "feature" ($tmp = $itable_flattened->slice("($i)")) .= $coord; print " $i..." if( ($i%1000==0) && ( $PDL::verbose || $PDL::debug || $PDL::Transform::debug)); } { my $tmp; # work around perl -d "feature" ($tmp = $itable->clump($itable->ndims-1)) .= $itable_flattened; ($tmp = $itable->mv(-1,0)) -= $p->{offset}; ($tmp = $itable->mv(-1,0)) /= $p->{scale}; } $p->{itable} = $itable; } &$lookup_func($data,$p, $p->{itable},$p->{iscale},$p->{ioffset}) ; }; $me->{name} = 'Lookup'; return $me; } =head2 t_linear =for usage $f = t_linear({options}); =for ref Linear (affine) transformations with optional offset t_linear implements simple matrix multiplication with offset, also known as the affine transformations. You specify the linear transformation with pre-offset, a mixing matrix, and a post-offset. That overspecifies the transformation, so you can choose your favorite method to specify the transform you want. The inverse transform is automagically generated, provided that it actually exists (the transform matrix is invertible). Otherwise, the inverse transform just croaks. Extra dimensions in the input vector are ignored, so if you pass a 3xN vector into a 3-D linear transformation, the final dimension is passed through unchanged. The options you can usefully pass in are: =over 3 =item s, scale, Scale A scaling scalar (heh), vector, or matrix. If you specify a vector it is treated as a diagonal matrix (for convenience). It gets left-multiplied with the transformation matrix you specify (or the identity), so that if you specify both a scale and a matrix the scaling is done after the rotation or skewing or whatever. =item r, rot, rota, rotation, Rotation A rotation angle in degrees -- useful for 2-D and 3-D data only. If you pass in a scalar, it specifies a rotation from the 0th axis toward the 1st axis. If you pass in a 3-vector as either a PDL or an array ref (as in "rot=>[3,4,5]"), then it is treated as a set of Euler angles in three dimensions, and a rotation matrix is generated that does the following, in order: =over 3 =item * Rotate by rot->(2) degrees from 0th to 1st axis =item * Rotate by rot->(1) degrees from the 2nd to the 0th axis =item * Rotate by rot->(0) degrees from the 1st to the 2nd axis =back The rotation matrix is left-multiplied with the transformation matrix you specify, so that if you specify both rotation and a general matrix the rotation happens after the more general operation -- though that is deprecated. Of course, you can duplicate this functionality -- and get more general -- by generating your own rotation matrix and feeding it in with the C<matrix> option. =item m, matrix, Matrix The transformation matrix. It does not even have to be square, if you want to change the dimensionality of your input. If it is invertible (note: must be square for that), then you automagically get an inverse transform too. =item pre, preoffset, offset, Offset The vector to be added to the data before they get multiplied by the matrix (equivalent of CRVAL in FITS, if you are converting from scientific to pixel units). =item post, postoffset, shift, Shift The vector to be added to the data after it gets multiplied by the matrix (equivalent of CRPIX-1 in FITS, if youre converting from scientific to pixel units). =item d, dim, dims, Dims Most of the time it is obvious how many dimensions you want to deal with: if you supply a matrix, it defines the transformation; if you input offset vectors in the C<pre> and C<post> options, those define the number of dimensions. But if you only supply scalars, there is no way to tell and the default number of dimensions is 2. This provides a way to do, e.g., 3-D scaling: just set C<{s=><scale-factor>, dims=>3}> and you are on your way. =back NOTES the type/unit fields are currently ignored by t_linear. =cut @PDL::Transform::Linear::ISA = ('PDL::Transform'); sub t_linear { new PDL::Transform::Linear(@_); } sub PDL::Transform::Linear::new { my($class) = shift; my($o) = $_[0]; pop @_ if (($#_ % 2 ==0) && !defined($_[-1])); #suppresses a warning if @_ has an odd number of elements and the #last is undef if(!(ref $o)) { $o = {@_}; } my($me) = PDL::Transform::new($class); $me->{name} = "linear"; $me->{params}->{pre} = _opt($o,['pre','Pre','preoffset','offset', 'Offset','PreOffset','Preoffset'],0); $me->{params}->{pre} = pdl($me->{params}->{pre}) if(defined $me->{params}->{pre}); $me->{params}->{post} = _opt($o,['post','Post','postoffset','PostOffset', 'shift','Shift'],0); $me->{params}->{post} = pdl($me->{params}->{post}) if(defined $me->{params}->{post}); $me->{params}->{matrix} = _opt($o,['m','matrix','Matrix','mat','Mat']); $me->{params}->{matrix} = pdl($me->{params}->{matrix}) if(defined $me->{params}->{matrix}); $me->{params}->{rot} = _opt($o,['r','rot','rota','rotation','Rotation']); $me->{params}->{rot} = 0 unless defined($me->{params}->{rot}); $me->{params}->{rot} = pdl($me->{params}->{rot}); my $o_dims = _opt($o,['d','dim','dims','Dims']); $o_dims = pdl($o_dims) if defined($o_dims); my $scale = _opt($o,['s','scale','Scale']); $scale = pdl($scale) if defined($scale); # Figure out the number of dimensions to transform, and, # if necessary, generate a new matrix. if(defined($me->{params}->{matrix})) { my $mat = $me->{params}->{matrix} = $me->{params}->{matrix}->slice(":,:"); $me->{idim} = $mat->dim(0); $me->{odim} = $mat->dim(1); } else { if(defined($me->{params}->{rot}) && UNIVERSAL::isa($me->{params}->{rot},'PDL')) { $me->{idim} = $me->{odim} = 2 if($me->{params}->{rot}->nelem == 1); $me->{idim} = $me->{odim} = 3 if($me->{params}->{rot}->nelem == 3); } if(defined($scale) && UNIVERSAL::isa($scale,'PDL') && $scale->getndims > 0) { $me->{idim} = $me->{odim} = $scale->dim(0); $me->{odim} = $scale->dim(0); } elsif(defined($me->{params}->{pre}) && UNIVERSAL::isa($me->{params}->{pre},'PDL') && $me->{params}->{pre}->getndims > 0) { $me->{idim} = $me->{odim} = $me->{params}->{pre}->dim(0); } elsif(defined($me->{params}->{post}) && UNIVERSAL::isa($me->{params}->{post},'PDL') && $me->{params}->{post}->getndims > 0) { $me->{idim} = $me->{odim} = $me->{params}->{post}->dim(0); } elsif(defined($o_dims)) { $me->{idim} = $me->{odim} = $o_dims; } else { print "PDL::Transform::Linear: assuming 2-D transform (set dims option to change)\n" if($PDL::Transform::debug); $me->{idim} = $me->{odim} = 2; } $me->{params}->{matrix} = PDL->zeroes($me->{idim},$me->{odim}); my $tmp; # work around perl -d "feature" ($tmp = $me->{params}->{matrix}->diagonal(0,1)) .= 1; } ### Handle rotation option my $rot = $me->{params}->{rot}; if(defined($rot)) { # Subrotation closure -- rotates from axis $d->(0) --> $d->(1). my $subrot = sub { my($d,$angle,$m)=@_; my($i) = identity($m->dim(0)); my($subm) = $i->dice($d,$d); $angle = $angle->at(0) if(UNIVERSAL::isa($angle,'PDL')); my($a) = $angle * $DEG2RAD; $subm .= $subm x pdl([cos($a),-sin($a)],[sin($a),cos($a)]); $m .= $m x $i; }; if(UNIVERSAL::isa($rot,'PDL') && $rot->nelem > 1) { if($rot->ndims == 2) { $me->{params}->{matrix} x= $rot; } elsif($rot->nelem == 3) { my $rm = identity(3); # Do these in reverse order to make it more like # function composition! &$subrot(pdl(0,1),$rot->at(2),$rm); &$subrot(pdl(2,0),$rot->at(1),$rm); &$subrot(pdl(1,2),$rot->at(0),$rm); $me->{params}->{matrix} .= $me->{params}->{matrix} x $rm; } else { barf("PDL::Transform::Linear: Got a strange rot option -- giving up.\n"); } } else { if($rot != 0 and $me->{params}->{matrix}->dim(0)>1) { &$subrot(pdl(0,1),$rot,$me->{params}->{matrix}); } } } # # Apply scaling # $me->{params}->{matrix} = $me->{params}->{matrix}->slice(":,:"); my $tmp; # work around perl -d "feature" ($tmp = $me->{params}->{matrix}->diagonal(0,1)) *= $scale if defined($scale); # # Check for an inverse and apply it if possible # my($o2); if($me->{params}->{matrix}->det($o2 = {lu=>undef})) { $me->{params}->{inverse} = $me->{params}->{matrix}->inv($o2); } else { delete $me->{params}->{inverse}; } $me->{params}->{idim} = $me->{idim}; $me->{params}->{odim} = $me->{odim}; ############################## # The meat -- just shift, matrix-multiply, and shift again. $me->{func} = sub { my($in,$opt) = @_; my($d) = $opt->{matrix}->dim(0)-1; barf("Linear transform: transform is $d-D; data only ".($in->dim(0))."\n") if($in->dim(0) < $d); my($a) = $in->slice("0:$d")->copy + $opt->{pre}; my($out) = $in->is_inplace ? $in : $in->copy; my $tmp; # work around perl -d "feature" ($tmp = $out->slice("0:$d")) .= $a x $opt->{matrix} + $opt->{post}; return $out; }; $me->{inv} = (defined $me->{params}->{inverse}) ? sub { my($in,$opt) = @_; my($d) = $opt->{inverse}->dim(0)-1; barf("Linear transform: transform is $d-D; data only ".($in->dim(0))."\n") if($in->dim(0) < $d); my($a) = $in->slice("0:$d")->copy - $opt->{post}; my($out) = $in->is_inplace ? $in : $in->copy; my $tmp; # work around perl -d "feature" ($tmp = $out->slice("0:$d")) .= $a x $opt->{inverse} - $opt->{pre}; $out; } : undef; return $me; } sub PDL::Transform::Linear::stringify { package PDL::Transform::Linear; my($me) = shift; my($out) = SUPER::stringify $me; my $mp = $me->{params}; if(!($me->{is_inverse})){ $out .= "Pre-add: ".($mp->{pre})."\n" if(defined $mp->{pre}); $out .= "Post-add: ".($mp->{post})."\n" if(defined $mp->{post}); $out .= "Forward matrix:".($mp->{matrix}) if(defined $mp->{matrix}); $out .= "Inverse matrix:".($mp->{inverse}) if(defined $mp->{inverse}); } else { $out .= "Pre-add: ".(-$mp->{post})."\n" if(defined $mp->{post}); $out .= "Post-add: ".(-$mp->{pre})."\n" if(defined $mp->{pre}); $out .= "Forward matrix:".($mp->{inverse}) if(defined $mp->{inverse}); $out .= "Inverse matrix:".($mp->{matrix}) if(defined $mp->{matrix}); } $out =~ s/\n/\n /go; $out; } =head2 t_scale =for usage $f = t_scale(<scale>) =for ref Convenience interface to L<t_linear|/t_linear>. t_scale produces a transform that scales around the origin by a fixed amount. It acts exactly the same as C<t_linear(Scale=>\<scale\>)>. =cut sub t_scale { my($scale) = shift; my($b) = shift; return t_linear(scale=>$scale,%{$b}) if(ref $b eq 'HASH'); t_linear(Scale=>$scale,$b,@_); } =head2 t_offset =for usage $f = t_offset(<shift>) =for ref Convenience interface to L<t_linear|/t_linear>. t_offset produces a transform that shifts the origin to a new location. It acts exactly the same as C<t_linear(Pre=>\<shift\>)>. =cut sub t_offset { my($pre) = shift; my($b) = shift; return t_linear(pre=>$pre,%{$b}) if(ref $b eq 'HASH'); t_linear(pre=>$pre,$b,@_); } =head2 t_rot =for usage $f = t_rot(<rotation-in-degrees>) =for ref Convenience interface to L<t_linear|/t_linear>. t_rot produces a rotation transform in 2-D (scalar), 3-D (3-vector), or N-D (matrix). It acts exactly the same as C<t_linear(Rot=>\<shift\>)>. =cut *t_rot = \&t_rotate; sub t_rotate { my $rot = shift; my($b) = shift; return t_linear(rot=>$rot,%{$b}) if(ref $b eq 'HASH'); t_linear(rot=>$rot,$b,@_); } =head2 t_fits =for usage $f = t_fits($fits,[option]); =for ref FITS pixel-to-scientific transformation with inverse You feed in a hash ref or a PDL with one of those as a header, and you get back a transform that converts 0-originated, pixel-centered coordinates into scientific coordinates via the transformation in the FITS header. For most FITS headers, the transform is reversible, so applying the inverse goes the other way. This is just a convenience subclass of PDL::Transform::Linear, but with unit/type support using the FITS header you supply. For now, this transform is rather limited -- it really ought to accept units differences and stuff like that, but they are just ignored for now. Probably that would require putting units into the whole transform framework. This transform implements the linear transform part of the WCS FITS standard outlined in Greisen & Calabata 2002 (A&A in press; find it at "http://arxiv.org/abs/astro-ph/0207407"). As a special case, you can pass in the boolean option "ignore_rgb" (default 0), and if you pass in a 3-D FITS header in which the last dimension has exactly 3 elements, it will be ignored in the output transformation. That turns out to be handy for handling rgb images. =cut sub t_fits { my($class) = 'PDL::Transform::Linear'; my($hdr) = shift; my($opt) = shift; if(ref $opt ne 'HASH') { $opt = defined $opt ? {$opt,@_} : {} ; } $hdr = $hdr->gethdr if(defined $hdr && UNIVERSAL::isa($hdr,'PDL')); croak('PDL::Transform::FITS::new requires a FITS header hash\n') if(!defined $hdr || ref $hdr ne 'HASH' || !defined($hdr->{NAXIS})); my($n) = $hdr->{NAXIS}; $n = $n->at(0) if(UNIVERSAL::isa($n,'PDL')); $n = 2 if($opt->{ignore_rgb} && $n==3 && $hdr->{NAXIS3} == 3); my($matrix) = PDL->zeroes($hdr->{NAXIS},$hdr->{NAXIS}); my($pre) = PDL->zeroes($n); my($post) = PDL->zeroes($n); ############################## # Scaling: Use CDi_j formalism if present; otherwise use the # older PCi_j + CDELTi formalism. my(@hgrab); if(@hgrab = grep(m/^CD\d{1,3}_\d{1,3}$/,keys %$hdr)) { # assignment # # CDi_j formalism # for my $h(@hgrab) { $h =~ m/CD(\d{1,3})_(\d{1,3})/; # Should always match my $tmp; # work around perl -d "feature" ($tmp = $matrix->slice("(".($1-1)."),(".($2-1).")")) .= $hdr->{$h}; } print "PDL::Transform::FITS: Detected CDi_j matrix: \n",$matrix,"\n" if($PDL::Transform::debug); } else { # # PCi_j + CDELTi formalism # If PCi_j aren't present, and N=2, then try using CROTA or # CROTA2 to generate a rotation matrix instea. # my($cdm) = PDL->zeroes($n,$n); my($cd) = $cdm->diagonal(0,1); my($cpm) = PDL->zeroes($n,$n); my $tmp; # work around perl -d "feature" ($tmp = $cpm->diagonal(0,1)) .= 1; # PC: diagonal defaults to unity $cd .= 1; if( @hgrab = grep(m/^PC\d{1,3}_\d{1,3}$/,keys %$hdr) ) { # assignment for my $h(@hgrab) { $h =~ m/PC(\d{1,3})_(\d{1,3})$/ || die "t_fits - match failed! This should never happen!"; my $tmp; # work around perl -d "feature" ($tmp = $cpm->slice("(".($1-1)."),(".($2-1).")")) .= $hdr->{$h}; } print "PDL::Transform::FITS: Detected PCi_j matrix: \n",$cpm,"\n" if($PDL::Transform::debug && @hgrab); } elsif($n==2 && ( defined $hdr->{CROTA} || defined $hdr->{CROTA1} || defined $hdr->{CROTA2}) ) { ## CROTA is deprecated; CROTA1 was used for a while but is unofficial; ## CROTA2 is encouraged instead. my $cr; $cr = $hdr->{CROTA2} unless defined $cr; $cr = $hdr->{CROTA} unless defined $cr; $cr = $hdr->{CROTA1} unless defined $cr; $cr *= $DEG2RAD; # Rotation matrix rotates counterclockwise to get from sci to pixel coords # (detector has been rotated ccw, according to FITS standard) $cpm .= pdl( [cos($cr), sin($cr)],[-sin($cr),cos($cr)] ); } for my $i(1..$n) { my $tmp; # work around perl -d "feature" ($tmp = $cd->slice("(".($i-1).")")) .= $hdr->{"CDELT$i"}; } #If there are no CDELTs, then we assume they are all 1.0, #as in PDL::Graphics::PGPLOT::Window::_FITS_tr. $cd+=1 if (all($cd==0)); $matrix = $cdm x $cpm; } my($i1) = 0; for my $i(1..$n) { my $tmp; # work around perl -d "feature" ($tmp = $pre->slice("($i1)")) .= 1 - $hdr->{"CRPIX$i"}; ($tmp = $post->slice("($i1)")) .= $hdr->{"CRVAL$i"}; $i1++; } my($me) = PDL::Transform::Linear::new($class, {'pre'=>$pre, 'post'=>$post, 'matrix'=>$matrix }); $me->{name} = 'FITS'; my (@otype,@ounit,@itype,@iunit); our (@names) = ('X','Y','Z') unless @names; for my $i(1..$hdr->{NAXIS}) { push(@otype,$hdr->{"CTYPE$i"}); push(@ounit,$hdr->{"CUNIT$i"}); push(@itype,"Image ". ( ($i-1<=$#names) ? $names[$i-1] : "${i}th dim" )); push(@iunit,"Pixels"); } $me->{otype} = \@otype; $me->{itype} = \@itype; $me->{ounit} = \@ounit; $me->{iunit} = \@iunit; # Check for nonlinear projection... # if($hdr->{CTYPE1} =~ m/(\w\w\w\w)\-(\w\w\w)/) { # print "Nonlinear transformation found... ignoring nonlinear part...\n"; # } return $me; } =head2 t_code =for usage $f = t_code(<func>,[<inv>],[options]); =for ref Transform implementing arbitrary perl code. This is a way of getting quick-and-dirty new transforms. You pass in anonymous (or otherwise) code refs pointing to subroutines that implement the forward and, optionally, inverse transforms. The subroutines should accept a data PDL followed by a parameter hash ref, and return the transformed data PDL. The parameter hash ref can be set via the options, if you want to. Options that are accepted are: =over 3 =item p,params The parameter hash that will be passed back to your code (defaults to the empty hash). =item n,name The name of the transform (defaults to "code"). =item i, idim (default 2) The number of input dimensions (additional ones should be passed through unchanged) =item o, odim (default 2) The number of output dimensions =item itype The type of the input dimensions, in an array ref (optional and advisiory) =item otype The type of the output dimension, in an array ref (optional and advisory) =item iunit The units that are expected for the input dimensions (optional and advisory) =item ounit The units that are returned in the output (optional and advisory). =back The code variables are executable perl code, either as a code ref or as a string that will be eval'ed to produce code refs. If you pass in a string, it gets eval'ed at call time to get a code ref. If it compiles OK but does not return a code ref, then it gets re-evaluated with "sub { ... }" wrapped around it, to get a code ref. Note that code callbacks like this can be used to do really weird things and generate equally weird results -- caveat scriptor! =cut sub t_code { my($class) = 'PDL::Transform'; my($func, $inv, $o) = @_; if(ref $inv eq 'HASH') { $o = $inv; $inv = undef; } my($me) = PDL::Transform::new($class); $me->{name} = _opt($o,['n','name','Name']) || "code"; $me->{func} = $func; $me->{inv} = $inv; $me->{params} = _opt($o,['p','params','Params']) || {}; $me->{idim} = _opt($o,['i','idim']) || 2; $me->{odim} = _opt($o,['o','odim']) || 2; $me->{itype} = _opt($o,['itype']) || []; $me->{otype} = _opt($o,['otype']) || []; $me->{iunit} = _opt($o,['iunit']) || []; $me->{ounit} = _opt($o,['ounit']) || []; $me; } =head2 t_cylindrical C<t_cylindrical> is an alias for C<t_radial> =head2 t_radial =for usage $f = t_radial(<options>); =for ref Convert Cartesian to radial/cylindrical coordinates. (2-D/3-D; with inverse) Converts 2-D Cartesian to radial (theta,r) coordinates. You can choose direct or conformal conversion. Direct conversion preserves radial distance from the origin; conformal conversion preserves local angles, so that each small-enough part of the image only appears to be scaled and rotated, not stretched. Conformal conversion puts the radius on a logarithmic scale, so that scaling of the original image plane is equivalent to a simple offset of the transformed image plane. If you use three or more dimensions, the higher dimensions are ignored, yielding a conversion from Cartesian to cylindrical coordinates, which is why there are two aliases for the same transform. If you use higher dimensionality than 2, you must manually specify the origin or you will get dimension mismatch errors when you apply the transform. Theta runs B<clockwise> instead of the more usual counterclockwise; that is to preserve the mirror sense of small structures. OPTIONS: =over 3 =item d, direct, Direct Generate (theta,r) coordinates out (this is the default); incompatible with Conformal. Theta is in radians, and the radial coordinate is in the units of distance in the input plane. =item r0, c, conformal, Conformal If defined, this floating-point value causes t_radial to generate (theta, ln(r/r0)) coordinates out. Theta is in radians, and the radial coordinate varies by 1 for each e-folding of the r0-scaled distance from the input origin. The logarithmic scaling is useful for viewing both large and small things at the same time, and for keeping shapes of small things preserved in the image. =item o, origin, Origin [default (0,0,0)] This is the origin of the expansion. Pass in a PDL or an array ref. =item u, unit, Unit [default 'radians'] This is the angular unit to be used for the azimuth. =back EXAMPLES These examples do transformations back into the same size image as they started from; by suitable use of the "transform" option to L<unmap|/unmap> you can send them to any size array you like. Examine radial structure in M51: Here, we scale the output to stretch 2*pi radians out to the full image width in the horizontal direction, and to stretch 1 radius out to a diameter in the vertical direction. $a = rfits('m51.fits'); $ts = t_linear(s => [250/2.0/3.14159, 2]); # Scale to fill orig. image $tu = t_radial(o => [130,130]); # Expand around galactic core $b = $a->map($ts x $tu); Examine radial structure in M51 (conformal): Here, we scale the output to stretch 2*pi radians out to the full image width in the horizontal direction, and scale the vertical direction by the exact same amount to preserve conformality of the operation. Notice that each piece of the image looks "natural" -- only scaled and not stretched. $a = rfits('m51.fits') $ts = t_linear(s=> 250/2.0/3.14159); # Note scalar (heh) scale. $tu = t_radial(o=> [130,130], r0=>5); # 5 pix. radius -> bottom of image $b = $ts->compose($tu)->unmap($a); =cut *t_cylindrical = \&t_radial; sub t_radial { my($class) = 'PDL::Transform'; my($o) = $_[0]; if(ref $o ne 'HASH') { $o = { @_ }; } my($me) = PDL::Transform::new($class); $me->{params}->{origin} = _opt($o,['o','origin','Origin']); $me->{params}->{origin} = pdl(0,0) unless defined($me->{params}->{origin}); $me->{params}->{origin} = PDL->pdl($me->{params}->{origin}); $me->{params}->{r0} = _opt($o,['r0','R0','c','conformal','Conformal']); $me->{params}->{origin} = PDL->pdl($me->{params}->{origin}); $me->{params}->{u} = _opt($o,['u','unit','Unit'],'radians'); ### Replace this kludge with a units call $me->{params}->{angunit} = ($me->{params}->{u} =~ m/^d/i) ? $RAD2DEG : 1.0; print "radial: conversion is $me->{params}->{angunit}\n" if($PDL::Transform::debug); $me->{name} = "radial (direct)"; $me->{idim} = 2; $me->{odim} = 2; if($me->{params}->{r0}) { $me->{otype} = ["Azimuth", "Ln radius" . ($me->{params}->{r0} != 1.0 ? "/$me->{params}->{r0}" : "")]; $me->{ounit} = [$me->{params}->{u},'']; # true-but-null prevents copying } else { $me->{otype} = ["Azimuth","Radius"]; $me->{ounit} = [$me->{params}->{u},'']; # false value copies prev. unit } $me->{func} = sub { my($data,$o) = @_; my($out) = ($data->new_or_inplace); my($d) = $data->copy; my $tmp; # work around perl -d "feature" ($tmp = $d->slice("0:1")) -= $o->{origin}; my($d0) = $d->slice("(0)"); my($d1) = $d->slice("(1)"); # (mod operator on atan2 puts everything in the interval [0,2*PI).) ($tmp = $out->slice("(0)")) .= (atan2(-$d1,$d0) % (2*$PI)) * $me->{params}->{angunit}; ($tmp = $out->slice("(1)")) .= (defined $o->{r0}) ? 0.5 * log( ($d1*$d1 + $d0 * $d0) / ($o->{r0} * $o->{r0}) ) : sqrt($d1*$d1 + $d0*$d0); $out; }; $me->{inv} = sub { my($d,$o) = @_; my($d0,$d1,$out)= ( ($d->is_inplace) ? ($d->slice("(0)")->copy, $d->slice("(1)")->copy->dummy(0,2), $d) : ($d->slice("(0)"), $d->slice("(1)")->dummy(0,2), $d->copy) ); $d0 /= $me->{params}->{angunit}; my($os) = $out->slice("0:1"); $os .= append(cos($d0)->dummy(0,1),-sin($d0)->dummy(0,1)); $os *= defined $o->{r0} ? ($o->{r0} * exp($d1)) : $d1; $os += $o->{origin}; $out; }; $me; } =head2 t_quadratic =for usage $t = t_quadratic(<options>); =for ref Quadratic scaling -- cylindrical pincushion (n-d; with inverse) Quadratic scaling emulates pincushion in a cylindrical optical system: separate quadratic scaling is applied to each axis. You can apply separate distortion along any of the principal axes. If you want different axes, use L<t_wrap|/t_wrap> and L<t_linear|/t_linear> to rotate them to the correct angle. The scaling options may be scalars or vectors; if they are scalars then the expansion is isotropic. The formula for the expansion is: f(a) = ( <a> + <strength> * a^2/<L_0> ) / (abs(<strength>) + 1) where <strength> is a scaling coefficient and <L_0> is a fundamental length scale. Negative values of <strength> result in a pincushion contraction. Note that, because quadratic scaling does not have a strict inverse for coordinate systems that cross the origin, we cheat slightly and use $x * abs($x) rather than $x**2. This does the Right thing for pincushion and barrel distortion, but means that t_quadratic does not behave exactly like t_cubic with a null cubic strength coefficient. OPTIONS =over 3 =item o,origin,Origin The origin of the pincushion. (default is the, er, origin). =item l,l0,length,Length,r0 The fundamental scale of the transformation -- the radius that remains unchanged. (default=1) =item s,str,strength,Strength The relative strength of the pincushion. (default = 0.1) =item honest (default=0) Sets whether this is a true quadratic coordinate transform. The more common form is pincushion or cylindrical distortion, which switches branches of the square root at the origin (for symmetric expansion). Setting honest to a non-false value forces true quadratic behavior, which is not mirror-symmetric about the origin. =item d, dim, dims, Dims The number of dimensions to quadratically scale (default is the dimensionality of your input vectors) =back =cut sub t_quadratic { my($class) = 'PDL::Transform'; my($o) = $_[0]; if(ref $o ne 'HASH') { $o = {@_}; } my($me) = PDL::Transform::new($class); $me->{params}->{origin} = _opt($o,['o','origin','Origin'],pdl(0)); $me->{params}->{l0} = _opt($o,['r0','l','l0','length','Length'],pdl(1)); $me->{params}->{str} = _opt($o,['s','str','strength','Strength'],pdl(0.1)); $me->{params}->{dim} = _opt($o,['d','dim','dims','Dims']); $me->{name} = "quadratic"; $me->{func} = sub { my($data,$o) = @_; my($dd) = $data->copy - $o->{origin}; my($d) = (defined $o->{dim}) ? $dd->slice("0:".($o->{dim}-1)) : $dd; $d += $o->{str} * ($d * abs($d)) / $o->{l0}; $d /= (abs($o->{str}) + 1); $d += $o->{origin}; if($data->is_inplace) { $data .= $dd; return $data; } $dd; }; $me->{inv} = sub { my($data,$opt) = @_; my($dd) = $data->copy ; my($d) = (defined $opt->{dim}) ? $dd->slice("0:".($opt->{dim}-1)) : $dd; my($o) = $opt->{origin}; my($s) = $opt->{str}; my($l) = $opt->{l0}; $d .= ((-1 + sqrt(1 + 4 * $s/$l * abs($d-$o) * (1+abs($s)))) / 2 / $s * $l) * (1 - 2*($d < $o)); $d += $o; if($data->is_inplace) { $data .= $dd; return $data; } $dd; }; $me; } =head2 t_cubic =for usage $t = t_cubic(<options>); =for ref Cubic scaling - cubic pincushion (n-d; with inverse) Cubic scaling is a generalization of t_quadratic to a purely cubic expansion. The formula for the expansion is: f(a) = ( a' + st * a'^3/L_0^2 ) / (1 + abs(st)) + origin where a'=(a-origin). That is a simple pincushion expansion/contraction that is fixed at a distance of L_0 from the origin. Because there is no quadratic term the result is always invertible with one real root, and there is no mucking about with complex numbers or multivalued solutions. OPTIONS =over 3 =item o,origin,Origin The origin of the pincushion. (default is the, er, origin). =item l,l0,length,Length,r0 The fundamental scale of the transformation -- the radius that remains unchanged. (default=1) =item d, dim, dims, Dims The number of dimensions to treat (default is the dimensionality of your input vectors) =back =cut sub t_cubic { my ($class) = 'PDL::Transform'; my($o) = $_[0]; if(ref $o ne 'HASH') { $o = {@_}; } my($me) = PDL::Transform::new($class); $me->{params}->{dim} = _opt($o,['d','dim','dims','Dims'],undef); $me->{params}->{origin} = _opt($o,['o','origin','Origin'],pdl(0)); $me->{params}->{l0} = _opt($o,['r0','l','l0','length','Length'],pdl(1)); $me->{params}->{st} = _opt($o,['s','st','str'],pdl(0)); $me->{name} = "cubic"; $me->{params}->{cuberoot} = sub { my $a = shift; my $as = 1 - 2*($a<0); return $as * ( abs($a) ** (1/3) ); }; $me->{func} = sub { my($data,$o) = @_; my($dd) = $data->copy; my($d) = (defined $o->{dim}) ? $dd->slice("0:".($o->{dim}-1)) : $dd; $d -= $o->{origin}; my $dl0 = $d / $o->{l0}; # f(x) = x + x**3 * ($o->{st} / $o->{l0}**2): # A = ($o->{st}/$dl0**2) # B = 0 # C = 1 # D = -f(x) $d += $o->{st} * $d * $dl0 * $dl0; $d /= ($o->{st}**2 + 1); $d += $o->{origin}; if($data->is_inplace) { $data .= $dd; return $data; } return $dd; }; $me->{inv} = sub { my($data,$o) = @_; my($l) = $o->{l0}; my($dd) = $data->copy; my($d) = (defined $o->{dim}) ? $dd->slice("0:".($o->{dim}-1)) : $dd; $d -= $o->{origin}; $d *= ($o->{st}+1); # Now we have to solve: # A x^3 + B X^2 + C x + D dd = 0 # with the assignments above for A,B,C,D. # Since B is zero, this is greatly simplified - the discriminant is always negative, # so there is always exactly one real root. # # The only real hassle is creating a symmetric cube root; for convenience # is stashed in the params hash. # First: create coefficients for mnemonics. my ($A, $C, $D) = ( $o->{st} / $l / $l, 1, - $d ); my $alpha = 27 * $A * $A * $D; my $beta = 3 * $A * $C; my $inner_root = sqrt( $alpha * $alpha + 4 * $beta * $beta * $beta ); $d .= (-1 / (3 * $A)) * ( + &{$o->{cuberoot}}( 0.5 * ( $alpha + $inner_root ) ) + &{$o->{cuberoot}}( 0.5 * ( $alpha - $inner_root ) ) ); $d += $origin; if($data->is_inplace) { $data .= $dd; return $data; } else { return $dd; } }; $me; } =head2 t_quartic =for usage $t = t_quartic(<options>); =for ref Quartic scaling -- cylindrical pincushion (n-d; with inverse) Quartic scaling is a generalization of t_quadratic to a quartic expansion. Only even powers of the input coordinates are retained, and (as with t_quadratic) sign is preserved, making it an odd function although a true quartic transformation would be an even function. You can apply separate distortion along any of the principal axes. If you want different axes, use L<t_wrap|/t_wrap> and L<t_linear|/t_linear> to rotate them to the correct angle. The scaling options may be scalars or vectors; if they are scalars then the expansion is isotropic. The formula for the expansion is: f(a) = ( <a> + <strength> * a^2/<L_0> ) / (abs(<strength>) + 1) where <strength> is a scaling coefficient and <L_0> is a fundamental length scale. Negative values of <strength> result in a pincushion contraction. Note that, because quadratic scaling does not have a strict inverse for coordinate systems that cross the origin, we cheat slightly and use $x * abs($x) rather than $x**2. This does the Right thing for pincushion and barrel distortion, but means that t_quadratic does not behave exactly like t_cubic with a null cubic strength coefficient. OPTIONS =over 3 =item o,origin,Origin The origin of the pincushion. (default is the, er, origin). =item l,l0,length,Length,r0 The fundamental scale of the transformation -- the radius that remains unchanged. (default=1) =item s,str,strength,Strength The relative strength of the pincushion. (default = 0.1) =item honest (default=0) Sets whether this is a true quadratic coordinate transform. The more common form is pincushion or cylindrical distortion, which switches branches of the square root at the origin (for symmetric expansion). Setting honest to a non-false value forces true quadratic behavior, which is not mirror-symmetric about the origin. =item d, dim, dims, Dims The number of dimensions to quadratically scale (default is the dimensionality of your input vectors) =back =cut sub t_quartic { my($class) = 'PDL::Transform'; my($o) = $_[0]; if(ref $o ne 'HASH') { $o = {@_}; } my($me) = PDL::Transform::new($class); $me->{params}->{origin} = _opt($o,['o','origin','Origin'],pdl(0)); $me->{params}->{l0} = _opt($o,['r0','l','l0','length','Length'],pdl(1)); $me->{params}->{str} = _opt($o,['s','str','strength','Strength'],pdl(0.1)); $me->{params}->{dim} = _opt($o,['d','dim','dims','Dims']); $me->{name} = "quadratic"; $me->{func} = sub { my($data,$o) = @_; my($dd) = $data->copy - $o->{origin}; my($d) = (defined $o->{dim}) ? $dd->slice("0:".($o->{dim}-1)) : $dd; $d += $o->{str} * ($d * abs($d)) / $o->{l0}; $d /= (abs($o->{str}) + 1); $d += $o->{origin}; if($data->is_inplace) { $data .= $dd; return $data; } $dd; }; $me->{inv} = sub { my($data,$opt) = @_; my($dd) = $data->copy ; my($d) = (defined $opt->{dim}) ? $dd->slice("0:".($opt->{dim}-1)) : $dd; my($o) = $opt->{origin}; my($s) = $opt->{str}; my($l) = $opt->{l0}; $d .= ((-1 + sqrt(1 + 4 * $s/$l * abs($d-$o) * (1+abs($s)))) / 2 / $s * $l) * (1 - 2*($d < $o)); $d += $o; if($data->is_inplace) { $data .= $dd; return $data; } $dd; }; $me; } =head2 t_spherical =for usage $t = t_spherical(<options>); =for ref Convert Cartesian to spherical coordinates. (3-D; with inverse) Convert 3-D Cartesian to spherical (theta, phi, r) coordinates. Theta is longitude, centered on 0, and phi is latitude, also centered on 0. Unless you specify Euler angles, the pole points in the +Z direction and the prime meridian is in the +X direction. The default is for theta and phi to be in radians; you can select degrees if you want them. Just as the L<t_radial|/t_radial> 2-D transform acts like a 3-D cylindrical transform by ignoring third and higher dimensions, Spherical acts like a hypercylindrical transform in four (or higher) dimensions. Also as with L<t_radial|/t_radial>, you must manually specify the origin if you want to use more dimensions than 3. To deal with latitude & longitude on the surface of a sphere (rather than full 3-D coordinates), see L<t_unit_sphere|PDL::Transform::Cartography/t_unit_sphere>. OPTIONS: =over 3 =item o, origin, Origin [default (0,0,0)] This is the Cartesian origin of the spherical expansion. Pass in a PDL or an array ref. =item e, euler, Euler [default (0,0,0)] This is a 3-vector containing Euler angles to change the angle of the pole and ordinate. The first two numbers are the (theta, phi) angles of the pole in a (+Z,+X) spherical expansion, and the last is the angle that the new prime meridian makes with the meridian of a simply tilted sphere. This is implemented by composing the output transform with a PDL::Transform::Linear object. =item u, unit, Unit (default radians) This option sets the angular unit to be used. Acceptable values are "degrees","radians", or reasonable substrings thereof (e.g. "deg", and "rad", but "d" and "r" are deprecated). Once genuine unit processing comes online (a la Math::Units) any angular unit should be OK. =back =cut sub t_spherical { my($class) = 'PDL::Transform'; my($o) = $_[0]; if(ref $o ne 'HASH') { $o = { @_ } ; } my($me) = PDL::Transform::new($class); $me->{idim}=3; $me->{odim}=3; $me->{params}->{origin} = _opt($o,['o','origin','Origin']); $me->{params}->{origin} = PDL->zeroes(3) unless defined($me->{params}->{origin}); $me->{params}->{origin} = PDL->pdl($me->{params}->{origin}); $me->{params}->{deg} = _opt($o,['d','degrees','Degrees']); my $unit = _opt($o,['u','unit','Unit']); $me->{params}->{angunit} = ($unit =~ m/^d/i) ? $DEG2RAD : undef; $me->{name} = "spherical"; $me->{func} = sub { my($data,$o) = @_; my($d) = $data->copy - $o->{origin}; my($d0,$d1,$d2) = ($d->slice("(0)"),$d->slice("(1)"),$d->slice("(2)")); my($out) = ($d->is_inplace) ? $data : $data->copy; my $tmp; # work around perl -d "feature" ($tmp = $out->slice("(0)")) .= atan2($d1, $d0); ($tmp = $out->slice("(2)")) .= sqrt($d0*$d0 + $d1*$d1 + $d2*$d2); ($tmp = $out->slice("(1)")) .= asin($d2 / $out->slice("(2)")); ($tmp = $out->slice("0:1")) /= $o->{angunit} if(defined $o->{angunit}); $out; }; $me->{inv} = sub { my($d,$o) = @_; my($theta,$phi,$r,$out) = ( ($d->is_inplace) ? ($d->slice("(0)")->copy, $d->slice("(1)")->copy, $d->slice("(2)")->copy, $d) : ($d->slice("(0)"), $d->slice("(1)"), $d->slice("(2)"), $d->copy) ); my($x,$y,$z) = ($out->slice("(0)"),$out->slice("(1)"),$out->slice("(2)")); my($ph,$th); if(defined $o->{angunit}){ $ph = $o->{angunit} * $phi; $th = $o->{angunit} * $theta; } else { $ph = $phi; $th = $theta; } $z .= $r * sin($ph); $x .= $r * cos($ph); $y .= $x * sin($th); $x *= cos($th); $out += $o->{origin}; $out; }; $me; } =head2 t_projective =for usage $t = t_projective(<options>); =for ref Projective transformation Projective transforms are simple quadratic, quasi-linear transformations. They are the simplest transformation that can continuously warp an image plane so that four arbitrarily chosen points exactly map to four other arbitrarily chosen points. They have the property that straight lines remain straight after transformation. You can specify your projective transformation directly in homogeneous coordinates, or (in 2 dimensions only) as a set of four unique points that are mapped one to the other by the transformation. Projective transforms are quasi-linear because they are most easily described as a linear transformation in homogeneous coordinates (e.g. (x',y',w) where w is a normalization factor: x = x'/w, etc.). In those coordinates, an N-D projective transformation is represented as simple multiplication of an N+1-vector by an N+1 x N+1 matrix, whose lower-right corner value is 1. If the bottom row of the matrix consists of all zeroes, then the transformation reduces to a linear affine transformation (as in L<t_linear|/t_linear>). If the bottom row of the matrix contains nonzero elements, then the transformed x,y,z,etc. coordinates are related to the original coordinates by a quadratic polynomial, because the normalization factor 'w' allows a second factor of x,y, and/or z to enter the equations. OPTIONS: =over 3 =item m, mat, matrix, Matrix If specified, this is the homogeneous-coordinate matrix to use. It must be N+1 x N+1, for an N-dimensional transformation. =item p, point, points, Points If specified, this is the set of four points that should be mapped one to the other. The homogeneous-coordinate matrix is calculated from them. You should feed in a 2x2x4 PDL, where the 0 dimension runs over coordinate, the 1 dimension runs between input and output, and the 2 dimension runs over point. For example, specifying p=> pdl([ [[0,1],[0,1]], [[5,9],[5,8]], [[9,4],[9,3]], [[0,0],[0,0]] ]) maps the origin and the point (0,1) to themselves, the point (5,9) to (5,8), and the point (9,4) to (9,3). This is similar to the behavior of fitwarp2d with a quadratic polynomial. =back =cut sub t_projective { my($class) = 'PDL::Transform'; my($o) = $_[0]; if(ref $o ne 'HASH') { $o = { @_ }; } my($me) = PDL::Transform::new($class); $me->{name} = "projective"; ### Set options... $me->{params}->{idim} = $me->{idim} = _opt($o,['d','dim','Dim']); my $matrix; if(defined ($matrix=_opt($o,['m','matrix','Matrix']))) { $matrix = pdl($matrix); die "t_projective: needs a square matrix" if($matrix->dims != 2 || $matrix->dim(0) != $matrix->dim(1)); $me->{params}->{idim} = $matrix->dim(0)-1 unless(defined($me->{params}->{idim})); $me->{idim} = $me->{params}->{idim}; die "t_projective: matrix not compatible with given dimension (should be N+1xN+1)\n" unless($me->{params}->{idim}==$matrix->dim(0)-1); my $inv = $matrix->inv; print STDERR "t_projective: warning - received non-invertible matrix\n" unless(all($inv*0 == 0)); $me->{params}->{matrix} = $matrix; $me->{params}->{matinv} = $inv; } elsif(defined ($p=pdl(_opt($o,['p','point','points','Point','Points'])))) { die "t_projective: points array should be 2(x,y) x 2(in,out) x 4(point)\n\t(only 2-D points spec is available just now, sorry)\n" unless($p->dims==3 && all(pdl($p->dims)==pdl(2,2,4))); # Solve the system of N equations to find the projective transform my ($p0,$p1,$p2,$p3) = ( $p->slice(":,(0),(0)"), $p->slice(":,(0),(1)"), $p->slice(":,(0),(2)"), $p->slice(":,(0),(3)") ); my ($P0,$P1,$P2,$P3) = ( $p->slice(":,(1),(0)"), $p->slice(":,(1),(1)"), $p->slice(":,(1),(2)"), $p->slice(":,(1),(3)") ); #print "declaring PDL...\n" ; my $M = pdl( [ [$p0->at(0), $p0->at(1), 1, 0, 0, 0, -$P0->at(0)*$p0->at(0), -$P0->at(0)*$p0->at(1)], [ 0, 0, 0, $p0->at(0), $p0->at(1), 1, -$P0->at(1)*$p0->at(0), -$P0->at(1)*$p0->at(1)], [$p1->at(0), $p1->at(1), 1, 0, 0, 0, -$P1->at(0)*$p1->at(0), -$P1->at(0)*$p1->at(1)], [ 0, 0, 0, $p1->at(0), $p1->at(1), 1, -$P1->at(1)*$p1->at(0), -$P1->at(1)*$p1->at(1)], [$p2->at(0), $p2->at(1), 1, 0, 0, 0, -$P2->at(0)*$p2->at(0), -$P2->at(0)*$p2->at(1)], [ 0, 0, 0, $p2->at(0), $p2->at(1), 1, -$P2->at(1)*$p2->at(0), -$P2->at(1)*$p2->at(1)], [$p3->at(0), $p3->at(1), 1, 0, 0, 0, -$P3->at(0)*$p3->at(0), -$P3->at(0)*$p3->at(1)], [ 0, 0, 0, $p3->at(0), $p3->at(1), 1, -$P3->at(1)*$p3->at(0), -$P3->at(1)*$p3->at(1)] ] ); #print "ok. Finding inverse...\n"; my $h = ($M->inv x $p->slice(":,(1),:")->flat->slice("*1"))->slice("(0)"); # print "ok\n"; my $matrix = ones(3,3); my $tmp; # work around perl -d "feature" ($tmp = $matrix->flat->slice("0:7")) .= $h; $me->{params}->{matrix} = $matrix; $me->{params}->{matinv} = $matrix->inv; } $me->{params}->{idim} = 2 unless defined $me->{params}->{idim}; $me->{params}->{odim} = $me->{params}->{idim}; $me->{idim} = $me->{params}->{idim}; $me->{odim} = $me->{params}->{odim}; $me->{func} = sub { my($data,$o) = @_; my($id) = $data->dim(0); my($d) = $data->glue(0,ones($data->slice("0"))); my($out) = ($o->{matrix} x $d->slice("*1"))->slice("(0)"); return ($out->slice("0:".($id-1))/$out->slice("$id")); }; $me->{inv} = sub { my($data,$o) = @_; my($id) = $data->dim(0); my($d) = $data->glue(0,ones($data->slice("0"))); my($out) = ($o->{matinv} x $d->slice("*1"))->slice("(0)"); return ($out->slice("0:".($id-1))/$out->slice("$id")); }; $me; } ; =head1 AUTHOR Copyright 2002, 2003 Craig DeForest. There is no warranty. You are allowed to redistribute this software under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Transform; use Carp; use overload '""' => \&_strval; use overload 'x' => \&_compose_op; use overload '**' => \&_pow_op; use overload '!' => \&t_inverse; use PDL; use PDL::MatrixOps; our $PI = 3.1415926535897932384626; our $DEG2RAD = $PI / 180; our $RAD2DEG = 180/$PI; our $E = exp(1); #### little helper kludge parses a list of synonyms sub _opt { my($hash) = shift; my($synonyms) = shift; my($alt) = shift; # default is undef -- ok. local($_); foreach $_(@$synonyms){ return (UNIVERSAL::isa($alt,'PDL')) ? PDL->pdl($hash->{$_}) : $hash->{$_} if defined($hash->{$_}) ; } return $alt; } ###################################################################### # # Stringification hack. _strval just does a method search on stringify # for the object itself. This gets around the fact that stringification # overload is a subroutine call, not a method search. # sub _strval { my($me) = shift; $me->stringify(); } ###################################################################### # # PDL::Transform overall stringifier. Subclassed stringifiers should # call this routine first then append auxiliary information. # sub stringify { my($me) = shift; my($mestr) = (ref $me); $mestr =~ s/PDL::Transform:://; my $out = $mestr . " (" . $me->{name} . "): "; $out .= "fwd ". ((defined ($me->{func})) ? ( (ref($me->{func}) eq 'CODE') ? "ok" : "non-CODE(!!)" ): "missing")."; "; $out .= "inv ". ((defined ($me->{inv})) ? ( (ref($me->{inv}) eq 'CODE') ? "ok" : "non-CODE(!!)" ):"missing").".\n"; } # Exit with OK status 1; ������������������������������������������������������������������PDL-2.018/GENERATED/PDL/Ufunc.pm��������������������������������������������������������������������0000644�0601750�0601001�00000076617�13110402056�013740� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # GENERATED WITH PDL::PP! Don't modify! # package PDL::Ufunc; @EXPORT_OK = qw( PDL::PP prodover PDL::PP dprodover PDL::PP cumuprodover PDL::PP dcumuprodover PDL::PP sumover PDL::PP dsumover PDL::PP cumusumover PDL::PP dcumusumover PDL::PP andover PDL::PP bandover PDL::PP borover PDL::PP orover PDL::PP zcover PDL::PP intover PDL::PP average PDL::PP avgover PDL::PP daverage PDL::PP davgover PDL::PP medover PDL::PP oddmedover PDL::PP modeover PDL::PP pctover PDL::PP oddpctover pct oddpct avg sum prod davg dsum dprod zcheck and band or bor min max median mode oddmedian any all minmax PDL::PP qsort PDL::PP qsorti PDL::PP qsortvec PDL::PP qsortveci PDL::PP minimum PDL::PP minimum_ind PDL::PP minimum_n_ind PDL::PP maximum PDL::PP maximum_ind PDL::PP maximum_n_ind PDL::PP maxover PDL::PP maxover_ind PDL::PP maxover_n_ind PDL::PP minover PDL::PP minover_ind PDL::PP minover_n_ind PDL::PP minmaximum PDL::PP minmaxover ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Ufunc ; =head1 NAME PDL::Ufunc - primitive ufunc operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP based on functionality of what are sometimes called I<ufuncs> (for example NumPY and Mathematica talk about these). It collects all the functions generally used to C<reduce> or C<accumulate> along a dimension. These all do their job across the first dimension but by using the slicing functions you can do it on any dimension. The L<PDL::Reduce|PDL::Reduce> module provides an alternative interface to many of the functions in this module. =head1 SYNOPSIS use PDL::Ufunc; =cut use PDL::Slices; use Carp; =head1 FUNCTIONS =cut =head2 prodover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via product to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the product along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = prodover($a); =for example $spectrum = prodover $image->xchg(0,1) =for bad prodover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *prodover = \&PDL::prodover; =head2 dprodover =for sig Signature: (a(n); double [o]b()) =for ref Project via product to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the product along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = dprodover($a); =for example $spectrum = dprodover $image->xchg(0,1) Unlike L<prodover|/prodover>, the calculations are performed in double precision. =for bad dprodover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *dprodover = \&PDL::dprodover; =head2 cumuprodover =for sig Signature: (a(n); int+ [o]b(n)) =for ref Cumulative product This function calculates the cumulative product along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. The sum is started so that the first element in the cumulative product is the first element of the parameter. =for usage $b = cumuprodover($a); =for example $spectrum = cumuprodover $image->xchg(0,1) =for bad cumuprodover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cumuprodover = \&PDL::cumuprodover; =head2 dcumuprodover =for sig Signature: (a(n); double [o]b(n)) =for ref Cumulative product This function calculates the cumulative product along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. The sum is started so that the first element in the cumulative product is the first element of the parameter. =for usage $b = cumuprodover($a); =for example $spectrum = cumuprodover $image->xchg(0,1) Unlike L<cumuprodover|/cumuprodover>, the calculations are performed in double precision. =for bad dcumuprodover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *dcumuprodover = \&PDL::dcumuprodover; =head2 sumover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via sum to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the sum along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = sumover($a); =for example $spectrum = sumover $image->xchg(0,1) =for bad sumover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *sumover = \&PDL::sumover; =head2 dsumover =for sig Signature: (a(n); double [o]b()) =for ref Project via sum to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the sum along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = dsumover($a); =for example $spectrum = dsumover $image->xchg(0,1) Unlike L<sumover|/sumover>, the calculations are performed in double precision. =for bad dsumover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *dsumover = \&PDL::dsumover; =head2 cumusumover =for sig Signature: (a(n); int+ [o]b(n)) =for ref Cumulative sum This function calculates the cumulative sum along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. The sum is started so that the first element in the cumulative sum is the first element of the parameter. =for usage $b = cumusumover($a); =for example $spectrum = cumusumover $image->xchg(0,1) =for bad cumusumover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *cumusumover = \&PDL::cumusumover; =head2 dcumusumover =for sig Signature: (a(n); double [o]b(n)) =for ref Cumulative sum This function calculates the cumulative sum along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. The sum is started so that the first element in the cumulative sum is the first element of the parameter. =for usage $b = cumusumover($a); =for example $spectrum = cumusumover $image->xchg(0,1) Unlike L<cumusumover|/cumusumover>, the calculations are performed in double precision. =for bad dcumusumover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *dcumusumover = \&PDL::dcumusumover; =head2 andover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via and to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the and along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = andover($a); =for example $spectrum = andover $image->xchg(0,1) =for bad If C<a()> contains only bad data (and its bad flag is set), C<b()> is set bad. Otherwise C<b()> will have its bad flag cleared, as it will not contain any bad values. =cut *andover = \&PDL::andover; =head2 bandover =for sig Signature: (a(n); [o]b()) =for ref Project via bitwise and to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the bitwise and along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = bandover($a); =for example $spectrum = bandover $image->xchg(0,1) =for bad If C<a()> contains only bad data (and its bad flag is set), C<b()> is set bad. Otherwise C<b()> will have its bad flag cleared, as it will not contain any bad values. =cut *bandover = \&PDL::bandover; =head2 borover =for sig Signature: (a(n); [o]b()) =for ref Project via bitwise or to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the bitwise or along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = borover($a); =for example $spectrum = borover $image->xchg(0,1) =for bad If C<a()> contains only bad data (and its bad flag is set), C<b()> is set bad. Otherwise C<b()> will have its bad flag cleared, as it will not contain any bad values. =cut *borover = \&PDL::borover; =head2 orover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via or to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the or along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = orover($a); =for example $spectrum = orover $image->xchg(0,1) =for bad If C<a()> contains only bad data (and its bad flag is set), C<b()> is set bad. Otherwise C<b()> will have its bad flag cleared, as it will not contain any bad values. =cut *orover = \&PDL::orover; =head2 zcover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via == 0 to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the == 0 along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = zcover($a); =for example $spectrum = zcover $image->xchg(0,1) =for bad If C<a()> contains only bad data (and its bad flag is set), C<b()> is set bad. Otherwise C<b()> will have its bad flag cleared, as it will not contain any bad values. =cut *zcover = \&PDL::zcover; =head2 intover =for sig Signature: (a(n); float+ [o]b()) =for ref Project via integral to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the integral along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = intover($a); =for example $spectrum = intover $image->xchg(0,1) Notes: C<intover> uses a point spacing of one (i.e., delta-h==1). You will need to scale the result to correct for the true point delta). For C<n E<gt> 3>, these are all C<O(h^4)> (like Simpson's rule), but are integrals between the end points assuming the pdl gives values just at these centres: for such `functions', sumover is correct to C<O(h)>, but is the natural (and correct) choice for binned data, of course. =for bad intover ignores the bad-value flag of the input piddles. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *intover = \&PDL::intover; =head2 average =for sig Signature: (a(n); int+ [o]b()) =for ref Project via average to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the average along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = average($a); =for example $spectrum = average $image->xchg(0,1) =for bad average processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *average = \&PDL::average; *PDL::avgover = \&PDL::average; *avgover = \&PDL::average; =head2 avgover =for ref Synonym for average. =cut =head2 daverage =for sig Signature: (a(n); double [o]b()) =for ref Project via average to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the average along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = daverage($a); =for example $spectrum = daverage $image->xchg(0,1) Unlike L<average|/average>, the calculation is performed in double precision. =for bad daverage processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *daverage = \&PDL::daverage; *PDL::davgover = \&PDL::daverage; *davgover = \&PDL::daverage; =head2 davgover =for ref Synonym for daverage. =cut =head2 medover =for sig Signature: (a(n); [o]b(); [t]tmp(n)) =for ref Project via median to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the median along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = medover($a); =for example $spectrum = medover $image->xchg(0,1) =for bad medover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *medover = \&PDL::medover; =head2 oddmedover =for sig Signature: (a(n); [o]b(); [t]tmp(n)) =for ref Project via oddmedian to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the oddmedian along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = oddmedover($a); =for example $spectrum = oddmedover $image->xchg(0,1) The median is sometimes not a good choice as if the array has an even number of elements it lies half-way between the two middle values - thus it does not always correspond to a data value. The lower-odd median is just the lower of these two values and so it ALWAYS sits on an actual data value which is useful in some circumstances. =for bad oddmedover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *oddmedover = \&PDL::oddmedover; =head2 modeover =for sig Signature: (data(n); [o]out(); [t]sorted(n)) =for ref Project via mode to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the mode along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = modeover($a); =for example $spectrum = modeover $image->xchg(0,1) The mode is the single element most frequently found in a discrete data set. It I<only> makes sense for integer data types, since floating-point types are demoted to integer before the mode is calculated. C<modeover> treats BAD the same as any other value: if BAD is the most common element, the returned value is also BAD. =for bad modeover does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *modeover = \&PDL::modeover; =head2 pctover =for sig Signature: (a(n); p(); [o]b(); [t]tmp(n)) =for ref Project via percentile to N-1 dimensions This function reduces the dimensionality of a piddle by one by finding the specified percentile (p) along the 1st dimension. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. Values outside the allowed range are clipped to 0.0 or 1.0 respectively. The algorithm implemented here is based on the interpolation variant described at L<http://en.wikipedia.org/wiki/Percentile> as used by Microsoft Excel and recommended by NIST. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = pctover($a, $p); =for example $spectrum = pctover $image->xchg(0,1), $p =for bad pctover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *pctover = \&PDL::pctover; =head2 oddpctover =for sig Signature: (a(n); p(); [o]b(); [t]tmp(n)) Project via percentile to N-1 dimensions This function reduces the dimensionality of a piddle by one by finding the specified percentile along the 1st dimension. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. The algorithm implemented is from the textbook version described first at L<http://en.wikipedia.org/wiki/Percentile>. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = oddpctover($a, $p); =for example $spectrum = oddpctover $image->xchg(0,1), $p =for bad oddpctover processes bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *oddpctover = \&PDL::oddpctover; =head2 pct =for ref Return the specified percentile of all elements in a piddle. The specified percentile (p) must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. =for usage $x = pct($data, $pct); =cut *pct = \&PDL::pct; sub PDL::pct { my($x, $p) = @_; my $tmp; $x->clump(-1)->pctover($p, $tmp=PDL->nullcreate($x)); return $tmp->at(); } =head2 oddpct =for ref Return the specified percentile of all elements in a piddle. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. =for usage $x = oddpct($data, $pct); =cut *oddpct = \&PDL::oddpct; sub PDL::oddpct { my($x, $p) = @_; my $tmp; $x->clump(-1)->oddpctover($p, $tmp=PDL->nullcreate($x)); return $tmp->at(); } =head2 avg =for ref Return the average of all elements in a piddle. See the documentation for L<average|/average> for more information. =for usage $x = avg($data); =cut =for bad This routine handles bad values. =cut *avg = \&PDL::avg; sub PDL::avg { my($x) = @_; my $tmp; $x->clump(-1)->average( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 sum =for ref Return the sum of all elements in a piddle. See the documentation for L<sumover|/sumover> for more information. =for usage $x = sum($data); =cut =for bad This routine handles bad values. =cut *sum = \&PDL::sum; sub PDL::sum { my($x) = @_; my $tmp; $x->clump(-1)->sumover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 prod =for ref Return the product of all elements in a piddle. See the documentation for L<prodover|/prodover> for more information. =for usage $x = prod($data); =cut =for bad This routine handles bad values. =cut *prod = \&PDL::prod; sub PDL::prod { my($x) = @_; my $tmp; $x->clump(-1)->prodover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 davg =for ref Return the average (in double precision) of all elements in a piddle. See the documentation for L<daverage|/daverage> for more information. =for usage $x = davg($data); =cut =for bad This routine handles bad values. =cut *davg = \&PDL::davg; sub PDL::davg { my($x) = @_; my $tmp; $x->clump(-1)->daverage( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 dsum =for ref Return the sum (in double precision) of all elements in a piddle. See the documentation for L<dsumover|/dsumover> for more information. =for usage $x = dsum($data); =cut =for bad This routine handles bad values. =cut *dsum = \&PDL::dsum; sub PDL::dsum { my($x) = @_; my $tmp; $x->clump(-1)->dsumover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 dprod =for ref Return the product (in double precision) of all elements in a piddle. See the documentation for L<dprodover|/dprodover> for more information. =for usage $x = dprod($data); =cut =for bad This routine handles bad values. =cut *dprod = \&PDL::dprod; sub PDL::dprod { my($x) = @_; my $tmp; $x->clump(-1)->dprodover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 zcheck =for ref Return the check for zero of all elements in a piddle. See the documentation for L<zcover|/zcover> for more information. =for usage $x = zcheck($data); =cut =for bad This routine handles bad values. =cut *zcheck = \&PDL::zcheck; sub PDL::zcheck { my($x) = @_; my $tmp; $x->clump(-1)->zcover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 and =for ref Return the logical and of all elements in a piddle. See the documentation for L<andover|/andover> for more information. =for usage $x = and($data); =cut =for bad This routine handles bad values. =cut *and = \&PDL::and; sub PDL::and { my($x) = @_; my $tmp; $x->clump(-1)->andover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 band =for ref Return the bitwise and of all elements in a piddle. See the documentation for L<bandover|/bandover> for more information. =for usage $x = band($data); =cut =for bad This routine handles bad values. =cut *band = \&PDL::band; sub PDL::band { my($x) = @_; my $tmp; $x->clump(-1)->bandover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 or =for ref Return the logical or of all elements in a piddle. See the documentation for L<orover|/orover> for more information. =for usage $x = or($data); =cut =for bad This routine handles bad values. =cut *or = \&PDL::or; sub PDL::or { my($x) = @_; my $tmp; $x->clump(-1)->orover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 bor =for ref Return the bitwise or of all elements in a piddle. See the documentation for L<borover|/borover> for more information. =for usage $x = bor($data); =cut =for bad This routine handles bad values. =cut *bor = \&PDL::bor; sub PDL::bor { my($x) = @_; my $tmp; $x->clump(-1)->borover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 min =for ref Return the minimum of all elements in a piddle. See the documentation for L<minimum|/minimum> for more information. =for usage $x = min($data); =cut =for bad This routine handles bad values. =cut *min = \&PDL::min; sub PDL::min { my($x) = @_; my $tmp; $x->clump(-1)->minimum( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 max =for ref Return the maximum of all elements in a piddle. See the documentation for L<maximum|/maximum> for more information. =for usage $x = max($data); =cut =for bad This routine handles bad values. =cut *max = \&PDL::max; sub PDL::max { my($x) = @_; my $tmp; $x->clump(-1)->maximum( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 median =for ref Return the median of all elements in a piddle. See the documentation for L<medover|/medover> for more information. =for usage $x = median($data); =cut =for bad This routine handles bad values. =cut *median = \&PDL::median; sub PDL::median { my($x) = @_; my $tmp; $x->clump(-1)->medover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 mode =for ref Return the mode of all elements in a piddle. See the documentation for L<modeover|/modeover> for more information. =for usage $x = mode($data); =cut =for bad This routine handles bad values. =cut *mode = \&PDL::mode; sub PDL::mode { my($x) = @_; my $tmp; $x->clump(-1)->modeover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 oddmedian =for ref Return the oddmedian of all elements in a piddle. See the documentation for L<oddmedover|/oddmedover> for more information. =for usage $x = oddmedian($data); =cut =for bad This routine handles bad values. =cut *oddmedian = \&PDL::oddmedian; sub PDL::oddmedian { my($x) = @_; my $tmp; $x->clump(-1)->oddmedover( $tmp=PDL->nullcreate($x) ); return $tmp->at(); } =head2 any =for ref Return true if any element in piddle set Useful in conditional expressions: =for example if (any $a>15) { print "some values are greater than 15\n" } =cut =for bad See L<or|/or> for comments on what happens when all elements in the check are bad. =cut *any = \∨ *PDL::any = \&PDL::or; =head2 all =for ref Return true if all elements in piddle set Useful in conditional expressions: =for example if (all $a>15) { print "all values are greater than 15\n" } =cut =for bad See L<and|/and> for comments on what happens when all elements in the check are bad. =cut *all = \∧ *PDL::all = \&PDL::and; =head2 minmax =for ref Returns an array with minimum and maximum values of a piddle. =for usage ($mn, $mx) = minmax($pdl); This routine does I<not> thread over the dimensions of C<$pdl>; it returns the minimum and maximum values of the whole array. See L<minmaximum|/minmaximum> if this is not what is required. The two values are returned as Perl scalars similar to min/max. =for example pdl> $x = pdl [1,-2,3,5,0] pdl> ($min, $max) = minmax($x); pdl> p "$min $max\n"; -2 5 =cut *minmax = \&PDL::minmax; sub PDL::minmax { my ($x)=@_; my $tmp; my @arr = $x->clump(-1)->minmaximum; return map {$_->sclr} @arr[0,1]; # return as scalars ! } =head2 qsort =for sig Signature: (a(n); [o]b(n)) =for ref Quicksort a vector into ascending order. =for example print qsort random(10); =for bad Bad values are moved to the end of the array: pdl> p $b [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p qsort($b) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] =cut *qsort = \&PDL::qsort; =head2 qsorti =for sig Signature: (a(n); indx [o]indx(n)) =for ref Quicksort a vector and return index of elements in ascending order. =for example $ix = qsorti $a; print $a->index($ix); # Sorted list =for bad Bad elements are moved to the end of the array: pdl> p $b [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p $b->index( qsorti($b) ) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] =cut *qsorti = \&PDL::qsorti; =head2 qsortvec =for sig Signature: (a(n,m); [o]b(n,m)) =for ref Sort a list of vectors lexicographically. The 0th dimension of the source piddle is dimension in the vector; the 1st dimension is list order. Higher dimensions are threaded over. =for example print qsortvec pdl([[1,2],[0,500],[2,3],[4,2],[3,4],[3,5]]); [ [ 0 500] [ 1 2] [ 2 3] [ 3 4] [ 3 5] [ 4 2] ] =for bad Vectors with bad components should be moved to the end of the array: =cut *qsortvec = \&PDL::qsortvec; =head2 qsortveci =for sig Signature: (a(n,m); indx [o]indx(m)) =for ref Sort a list of vectors lexicographically, returning the indices of the sorted vectors rather than the sorted list itself. As with C<qsortvec>, the input PDL should be an NxM array containing M separate N-dimensional vectors. The return value is an integer M-PDL containing the M-indices of original array rows, in sorted order. As with C<qsortvec>, the zeroth element of the vectors runs slowest in the sorted list. Additional dimensions are threaded over: each plane is sorted separately, so qsortveci may be thought of as a collapse operator of sorts (groan). =for bad Vectors with bad components should be moved to the end of the array: =cut *qsortveci = \&PDL::qsortveci; =head2 minimum =for sig Signature: (a(n); [o]c()) =for ref Project via minimum to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the minimum along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = minimum($a); =for example $spectrum = minimum $image->xchg(0,1) =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output piddle. Note that C<NaNs> are considered to be valid values; see L<isfinite|PDL::Math/isfinite> and L<badmask|PDL::Math/badmask> for ways of masking NaNs. =cut *minimum = \&PDL::minimum; =head2 minimum_ind =for sig Signature: (a(n); indx [o] c()) =for ref Like minimum but returns the index rather than the value =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output piddle. =cut *minimum_ind = \&PDL::minimum_ind; =head2 minimum_n_ind =for sig Signature: (a(n); indx [o]c(m)) =for ref Returns the index of C<m> minimum elements =for bad Not yet been converted to ignore bad values =cut *minimum_n_ind = \&PDL::minimum_n_ind; =head2 maximum =for sig Signature: (a(n); [o]c()) =for ref Project via maximum to N-1 dimensions This function reduces the dimensionality of a piddle by one by taking the maximum along the 1st dimension. By using L<xchg|PDL::Slices/xchg> etc. it is possible to use I<any> dimension. =for usage $b = maximum($a); =for example $spectrum = maximum $image->xchg(0,1) =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output piddle. Note that C<NaNs> are considered to be valid values; see L<isfinite|PDL::Math/isfinite> and L<badmask|PDL::Math/badmask> for ways of masking NaNs. =cut *maximum = \&PDL::maximum; =head2 maximum_ind =for sig Signature: (a(n); indx [o] c()) =for ref Like maximum but returns the index rather than the value =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output piddle. =cut *maximum_ind = \&PDL::maximum_ind; =head2 maximum_n_ind =for sig Signature: (a(n); indx [o]c(m)) =for ref Returns the index of C<m> maximum elements =for bad Not yet been converted to ignore bad values =cut *maximum_n_ind = \&PDL::maximum_n_ind; *PDL::maxover = \&PDL::maximum; *maxover = \&PDL::maximum; =head2 maxover =for ref Synonym for maximum. =cut *PDL::maxover_ind = \&PDL::maximum_ind; *maxover_ind = \&PDL::maximum_ind; =head2 maxover_ind =for ref Synonym for maximum_ind. =cut *PDL::maxover_n_ind = \&PDL::maximum_n_ind; *maxover_n_ind = \&PDL::maximum_n_ind; =head2 maxover_n_ind =for ref Synonym for maximum_n_ind. =cut *PDL::minover = \&PDL::minimum; *minover = \&PDL::minimum; =head2 minover =for ref Synonym for minimum. =cut *PDL::minover_ind = \&PDL::minimum_ind; *minover_ind = \&PDL::minimum_ind; =head2 minover_ind =for ref Synonym for minimum_ind. =cut *PDL::minover_n_ind = \&PDL::minimum_n_ind; *minover_n_ind = \&PDL::minimum_n_ind; =head2 minover_n_ind =for ref Synonym for minimum_n_ind =cut =head2 minmaximum =for sig Signature: (a(n); [o]cmin(); [o] cmax(); indx [o]cmin_ind(); indx [o]cmax_ind()) =for ref Find minimum and maximum and their indices for a given piddle; =for usage pdl> $a=pdl [[-2,3,4],[1,0,3]] pdl> ($min, $max, $min_ind, $max_ind)=minmaximum($a) pdl> p $min, $max, $min_ind, $max_ind [-2 0] [4 3] [0 1] [2 2] See also L<minmax|/minmax>, which clumps the piddle together. =for bad If C<a()> contains only bad data, then the output piddles will be set bad, along with their bad flag. Otherwise they will have their bad flags cleared, since they will not contain any bad values. =cut *minmaximum = \&PDL::minmaximum; *PDL::minmaxover = \&PDL::minmaximum; *minmaxover = \&PDL::minmaximum; =head2 minmaxover =for ref Synonym for minmaximum. =cut ; =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz) and Karl Glazebrook (kgb@aaoepp.aao.gov.au). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; �����������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/���������������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402045�012122� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/Graphics2D.pm��������������������������������������������������������������������0000644�0601750�0601001�00000070510�13036512174�014425� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package PDL::Graphics2D; use Exporter 'import'; # gives you Exporter's import() method directly @EXPORT = qw(imag2d imag2d_update twiddle); # symbols to export on request @EXPORT_OK = qw(imag2d imag2d_update twiddle); # symbols to export on request =head1 NAME PDL::Graphics2D - An object oriented interface to PDL graphics =head1 SYNOPSIS use PDL::Graphics2D; $win = PDL::Graphics2D->new(<Interface>, <Options>); $w = imag2d( $image, 'Title Here', ... ); =head1 DESCRIPTION This is an umbrella class allowing for a simple interface to all plotting routines in PDL. On its own it does not do any work it merely passes information to the appropriate class. Ideally this should probably offer a uniform interface to a variety of packages. This requires a lot more work before it is useful I feel, but it can be used already. =head1 CONSTRUCTORS =head2 new =for ref Create a 2-D graphics object with the requested interface type =cut { my %lookup=( 'PGPLOT' => 'PDL::Graphics::PGPLOT::Window' ); sub new { my $type=shift; my $interface=shift; # # Translate the interface name to the appropriate class name. # $interface=uc($interface); die "Interface $interface is not known!\n" if !exists($lookup{$interface}); my $class = $lookup{$interface}; eval "require $class;"; return $class->new(@_); } } use strict; my $debug = 0; use PDL::Lite; use PDL::NiceSlice; #------------------------------------------------------------------------ # PDL constants used by imag2d #------------------------------------------------------------------------ # # PDL_B # PDL_D # PDL_F # PDL_L # PDL_S # PDL_US # #------------------------------------------------------------------------ #------------------------------------------------------------------------ # PDL methods used by imag2d #------------------------------------------------------------------------ # # .= # dim # float # get_dataref # ndims # sever # type->symbol # #------------------------------------------------------------------------ use OpenGL qw( :all ); #------------------------------------------------------------------------ # opengl/glut constants used by imag2d #------------------------------------------------------------------------ # # GLUT_ACTION_CONTINUE_EXECUTION # GLUT_ACTION_ON_WINDOW_CLOSE # GLUT_DOUBLE # GLUT_RGBA # GLUT_WINDOW_HEIGHT # GLUT_WINDOW_WIDTH # # GL_COLOR_BUFFER_BIT # GL_FLOAT # GL_INT # GL_LUMINANCE # GL_LUMINANCE_ALPHA # GL_MODELVIEW # GL_PROJECTION # GL_RGB # GL_RGBA # GL_SHORT # GL_UNPACK_ALIGNMENT # GL_UNSIGNED_BYTE # GL_UNSIGNED_INT_8_8_8_8 # GL_UNSIGNED_SHORT # #------------------------------------------------------------------------ #------------------------------------------------------------------------ # opengl/glu/glut routines used by imag2d #------------------------------------------------------------------------ # # OpenGL::done_glutInit # # glutAddMenuEntry # glutAttachMenu # glutCreateMenu # glutCreateWindow # glutDestroyWindow # glutDisplayFunc # glutGet # glutGetWindow # glutInit # glutInitDisplayMode # glutInitWindowPosition # glutInitWindowSize # glutKeyboardFunc # glutLeaveMainLoop # glutMouseFunc # glutPostRedisplay # glutReshapeFunc # glutReshapeWindow # glutSetOption # glutSwapBuffers # # glClear # glClearColor # glDrawPixels_s # glFlush # glLoadIdentity # glMatrixMode # glPixelStorei # glPixelZoom # glRasterPos2i # glViewport # # gluOrtho2D # #------------------------------------------------------------------------ our $draw_overlay; my $finished_glutInit = 0; my $cur_fig_num = 0; my $imag2d_keep_twiddling; my $imag2d_is_twiddling; my $show_overlay = 1; our $is_paused = 0; our $do_step = 0; our $step_count = 1; our $go_forward = 1; our $go_backward = 0; our @imag2d_list = (); #------------------------------------------------------------------------ # glutMouseFunc callback #------------------------------------------------------------------------ sub mouse_click { my ($button, $state, $x, $y) = @_; my $window_id = glutGetWindow(); my $width = glutGet(GLUT_WINDOW_WIDTH); my $height = glutGet(GLUT_WINDOW_HEIGHT); my $img; # search for image corresponding to window foreach my $entry ( @imag2d_list ) { if ( $entry->{window_id} == $window_id ) { $img = $entry->{img}; # 2D piddle for now last; } } die "mouse_click: callback could not find image window\n" unless defined $img; # calculate zoom/aspect ratio factors my $glds = 0; $glds = 1 if $img->dim(0) < 5; # hack, need verify consistency my $zoom_x = $width / $img->dim($glds+0); my $zoom_y = $height / $img->dim($glds+1); my $zoom = ($zoom_x < $zoom_y) ? $zoom_x : $zoom_y; # calculate the offset to the image use for centering my ($hshift, $vshift) = (0,0); if ( $zoom == $zoom_x ) { # shift down $vshift = ($height - $zoom * $img->dim($glds+1)) / 2.0; } else { # shift right $hshift = ($width - $zoom * $img->dim($glds+0)) / 2.0; } my ($im_x, $im_y); $im_x = sprintf "%.1f", ($x - $hshift) / $zoom; $im_y = sprintf "%.1f", ($y - $vshift) / $zoom; if ( $state and (-1 < $im_x) and (-1 < $im_y) and ($im_x < $img->dim($glds+0)+1) and ($im_y < $img->dim($glds+1)+1) ) { printf STDERR "b_%01d: pixel=(%d,%d), im pt=(%.1f,%.1f),", $button, $x, $y, $im_x, $im_y; printf STDERR " im val=%s, glds=$glds, winID=$window_id\n", $glds ? $img->(:,(int($im_x)),(int($im_y))) : $img->((int($im_x)),(int($im_y))); } }; #------------------------------------------------------------------------ # glutReshapeFunc callback #------------------------------------------------------------------------ sub resize_window { my ($width, $height) = @_; print STDERR "resize_window: call with new dims ($width, $height)\n" if $debug; my $window_id = glutGetWindow(); my $img; return unless scalar(@imag2d_list); # search for image corresponding to window foreach my $entry ( @imag2d_list ) { if ( $entry->{window_id} == $window_id ) { $img = $entry->{img}; # 2D piddle for now last; } } die "resize_window: callback could not find image window\n" unless defined $img; # calculate zoom/aspect ratio factors my $glds = 0; $glds = 1 if $img->dim(0) < 5; # hack, need verify consistency my $zoom_x = $width / $img->dim($glds+0); my $zoom_y = $height / $img->dim($glds+1); my $zoom = ($zoom_x < $zoom_y) ? $zoom_x : $zoom_y; glViewport( 0, 0, $width, $height ); # set coordinate frame for graphics in window glMatrixMode( GL_PROJECTION ); glLoadIdentity(); gluOrtho2D( 0, $width, $height, 0 ); glMatrixMode( GL_MODELVIEW ); glLoadIdentity(); # set zoom factors for image display glPixelZoom( $zoom, -$zoom ); ## glutReshapeWindow($zoom*$img->dim($glds+0), $zoom*$img->dim($glds+1)); # offset the image in the window to keep centered my ($hshift, $vshift) = (0,0); if ( $zoom == $zoom_x ) { # shift down $vshift = ($height - $zoom * $img->dim($glds+1)) / 2.0; } else { # shift right $hshift = ($width - $zoom * $img->dim($glds+0)) / 2.0; } glRasterPos2i( int($hshift), int($vshift) ); my ($do_reshape) = 0; my ($new_width, $new_height) = ($zoom*$img->dim($glds+0), $zoom*$img->dim($glds+1)); # handle integer rounding problems in resize if (abs($new_width - $width ) <= 2) { $new_width = $width; } else { $do_reshape++; } if (abs($new_height - $height ) <= 2) { $new_height = $height; } else { $do_reshape++; } glutReshapeWindow($new_width, $new_height) if $do_reshape; }; #------------------------------------------------------------------------ # glutDisplayFunc callback #------------------------------------------------------------------------ sub display_image { my $window_id = glutGetWindow(); my $img; my ($gldrawformat, $gldrawtype, $glds); return unless scalar(@imag2d_list); # search for image corresponding to window foreach my $entry ( @imag2d_list ) { if ( $entry->{window_id} == $window_id ) { $img = $entry->{img}; # 2D piddle for now last; } } die "display_window: callback could not find image window\n" unless defined $img; # determine display pixel format to use if ($img->ndims > 2 && $img->dim(0) == 4) { $gldrawformat = GL_RGBA; $glds = 1; } elsif ($img->ndims > 2 && $img->dim(0) == 3) { $gldrawformat = GL_RGB; $glds = 1; } elsif ($img->ndims > 2 && $img->dim(0) == 2) { $gldrawformat = GL_LUMINANCE_ALPHA; $glds = 1; } elsif ($img->ndims > 2 && $img->dim(0) == 1) { $gldrawformat = GL_LUMINANCE; $glds = 1; } else { $gldrawformat = GL_LUMINANCE; $glds = 0; }; # convert to float if double for display if ($img->type->symbol eq 'PDL_D') { # clean up code $img = $img->float; } # determine display pixel type to use if ($img->type->symbol eq 'PDL_F') { $gldrawtype = GL_FLOAT; } elsif ($img->type->symbol eq 'PDL_B') { $gldrawtype = GL_UNSIGNED_BYTE; } elsif ($img->type->symbol eq 'PDL_S') { $gldrawtype = GL_SHORT; } elsif ($img->type->symbol eq 'PDL_US') { $gldrawtype = GL_UNSIGNED_SHORT; } elsif ($img->type->symbol eq 'PDL_L') { $gldrawtype = ( $gldrawformat == GL_RGBA ) ? GL_UNSIGNED_INT_8_8_8_8 : GL_INT; } else { die "display_image: unsupported data type '", $img->type->symbol, "' for image display\n"; } my ($sizeX, $sizeY) = ($img->dim($glds+0), $img->dim($glds+1)); # print STDERR "... calculated image size is ($sizeX, $sizeY)\n"; # display image glClear(GL_COLOR_BUFFER_BIT); # glRasterPos2i( 0, 0 ); glDrawPixels_s( $sizeX, $sizeY, $gldrawformat, $gldrawtype, $img->get_dataref ); &{$draw_overlay}($img, $sizeX, $sizeY) if $show_overlay and defined($draw_overlay); #draw_hough_lines($img, $sizeX, $sizeY); glutSwapBuffers(); glFlush(); } my $RELEASE=99; #------------------------------------------------------------------------ # glutCreateMenu callback #------------------------------------------------------------------------ sub ModeMenu { my $entry = shift; my $img; if ($entry == $RELEASE) { my ($window_id) = glutGetWindow(); # search for image corresponding to window foreach my $listentry ( @imag2d_list ) { if ( $listentry->{window_id} == $window_id ) { $img = $listentry->{img}; # 2D piddle for now last; } } die "ModeMenu: callback could not find image window\n" unless defined $img; glutLeaveMainLoop(); # glutDestroyWindow($window_id); } else { die "ModeMenu: illegal menu entry '$entry'\n"; } } #------------------------------------------------------------------------ # glutKeyboardFunc callback #------------------------------------------------------------------------ sub key_ops { my ($key, $x, $y) = @_; my $win_id = glutGetWindow(); # handle keypress events (defaults first) # print STDERR "Got keypress for keypress=$key\n"; # stop twiddling if ($key == ord('Q') or $key == ord('q')) { $imag2d_is_twiddling = 0; warn "Stop twiddling command, key '" . chr($key) . "', detected.\n"; return; } # exit program if ($key == 27 or $key == 3) { # ESC or Ctrl-C warn "Exit program command, key '" . (($key == 27) ? 'ESC' : 'Ctrl-C') . "', detected.\n"; if (defined $PERLDL::TERM) { # don't exit if in the perldl or pdl2 shell $imag2d_is_twiddling = 0; warn "PDL shell in use, stop twiddling instead of exit...\n"; return; } else { exit; } } # toggle overlay if ($key == ord('O') or $key == ord('o')) { $show_overlay = (($show_overlay) ? 0 : 1); warn "Toggle overlay command, key '" . chr($key) . "', detected.\n"; return; } # lock windows sizes together if ($key == ord('L') or $key == ord('l')) { ## $lock_sizes = (($lock_sizes) ? 0 : 1); ## warn "Setting \$lock_sizes to $lock_sizes, (window=$win_id)\n"; warn "Lock window sizes command, key '" . chr($key) . "', not implemented.\n"; return; } # toggle image histogram equalization if ($key == ord('H') or $key == ord('h')) { ## $hist_equalize = (($hist_equalize) ? 0 : 1); ## warn "Setting \$hist_equalize to $hist_equalize\n"; warn "Toggle image histogram equalization command, key '" . chr($key) . "', not implemented.\n"; return; } # resize current window (last clicked?) to 1:1 if ($key == ord('1')) { ## resize_window(-1,-1); # Special (w,h) args mean set zoom to 1 ## glutPostRedisplay(); warn "Resize current window to 1:1 scale command, key '" . chr($key) . "', not implemented.\n"; return; } # resize other image windows to this one if ($key == ord('=')) { ## warn "Resize other images to this one not yet implemented, (window=$win_id)\n"; warn "Resize other windows to this one command, key '" . chr($key) . "', not implemented.\n"; return; } # pause/run with space bar if ($key == 32) { # SPACE if ($is_paused) { $is_paused = 0; } else { $is_paused = 1; $step_count = 1; $do_step = 1; } # warn "Pause/Run command, key 'SPACE', detected\n"; return; } # toggle verbose output if ($key == ord('v') or $key == ord('V')) { ## $be_verbose = (($be_verbose) ? 0 : 1); warn "Toggle verbose output command, key '" . chr($key) . "', not implemented.\n"; return; } # change direction or step in direction if ($key == 46 or $key == 62) { # . or > $go_forward = 1; $go_backward = 0; if ($is_paused) { $do_step = 1; $step_count = 1; } else { $step_count++; $step_count = 1 if $step_count == 0; } # warn "Change Direction/Step forward command, key '" . (($key == 46) ? '.' : '>') . "', detected.\n"; return; }; if ($key == 44 or $key == 60) { ; # , or < $go_forward = 0; $go_backward = 1; if ($is_paused) { $do_step = 1; $step_count = -1; } else { $step_count--; $step_count = -1 if $step_count == 0; } # warn "Change Direction/Step backward command, key '" . (($key == 44) ? ',' : '<') . "', detected.\n"; return; } warn "No handler for key " . chr($key) . ", (window=$win_id)\n"; } #------------------------------------------------------------------------ # Create a new OpenGL context window for image display #------------------------------------------------------------------------ sub display_new_window { my ($height, $width, $zoom, $name, $off_r, $off_c, $window_id) = @_; my ($window_width, $window_height); my ($zoom_x, $zoom_y); if ( $width <= 0 || $height <= 0 || $zoom == 0.0 ) { die "display_new_window: invalid arguments!\n"; } $window_width = int($zoom*$width + 0.5); $window_height = int($zoom*$height + 0.5); # compute zoom factors to make graphics overlay the image precisely $zoom_x = $window_width/$width; $zoom_y = $window_height/$height; # create display window if (! $finished_glutInit ) { glutInit() unless OpenGL::done_glutInit(); glutInitDisplayMode(GLUT_RGBA|GLUT_DOUBLE); glutSetOption(GLUT_ACTION_ON_WINDOW_CLOSE,GLUT_ACTION_CONTINUE_EXECUTION) if OpenGL::_have_freeglut(); $finished_glutInit = 1; } glutInitWindowSize( $window_width, $window_height ); glutInitWindowPosition( $off_r, $off_c ); $window_id = glutCreateWindow( $name ); # set some standard defaults glPixelStorei( GL_UNPACK_ALIGNMENT, 1 ); glClearColor( 0.0, 0.0, 0.0, 0.0 ); glViewport( 0, 0, $window_width, $window_height ); # set coordinate frame for graphics in window glMatrixMode( GL_PROJECTION ); glLoadIdentity(); gluOrtho2D( 0, $width, $height, 0 ); glMatrixMode( GL_MODELVIEW ); glLoadIdentity(); # set zoom factors for image display glPixelZoom( $zoom_x, -$zoom_y ); # set origin for drawing images as the top-left corner of the window glRasterPos2i( 0, 0 ); # success return $window_id; }; #------------------------------------------------------------------------ # Display piddle as 2-D image in window using OpenGL #------------------------------------------------------------------------ =head1 FUNCTIONS =head2 imag2d =for ref Display a 2-D image in a figure window imag2d() creates a plain FreeGLUT OpenGL window and displays the input image with 1:1 aspect ratio for pixels. The window resize is constrained to the actual ratio of the image dimensions. The initial display size is currently a 200x200 window to prevent things from being too small by default. The image to display can have dimensions ($c,$M,$N) where for $c==4 the display is in GL_RGBA, for $c==3 the display is GL_RGB, for $c==2 the display is GL_LUMINANCE_ALPHA, and for $c==1 or for for dimensions ($M,$N) then the display is GL_LUMINANCE. This routine does not yet thread but multiple images may be viewed at the same time in separate windows by multiple calls to imag2d(). TriD graphics visualization windows and the imag2d() windows may be created and used independently. NOTE: If you are twiddling a TriD window, the imag2d() windows are active as well. If you call twiddle() the sub, only the imag2d() windows will update correctly. =for usage $window_id = imag2d($image, $name, $zoom, $x_off, $y_off); creates a new image figure window from the input piddle with the given title, zoom factor, and position (if possible) $window_id - may be used to refer to the figure window $image - 2D image piddle with at least 2 or 3 dimensions e.g. [M,N], [1,M,N], [2,M,N], [3,M,N], [4,M,N] $name - the name to use for the figure window (optional) $zoom - desired (float) pixel zoom factor (optional) ($x_off, $y_off) - desired window pixel position (optional) with (0,0) as the top left pixel of the display =for example use PDL::Graphics2D; # imports imag2d() and twiddle() $a = sequence(64,48,3); # make test RGB image $a = $a->mv(2,0); # color must be dim(0) with size [0..4] $a /= $a->max; # pixel values in [0.0,1.0] $a = sin(10*$a); $w1 = imag2d($a); # with parens... $w2 = imag2d $a->sqrt; # or without $w3 = imag2d $a**2; =head2 imag2d_update =for ref Update an existing imag2d window with new piddle data =for usage $image = random(3,64,48)/2 + 0.25; # random pixel image $win = imag2d($image); # create original image display imag2d_update($win, $image->sequence/$image->nelem); # update data C<imag2d_update> allows one to update an C<imag2d> display window by replacing the associated image data with new contents. The new image data must be the same type and shape as the previous. Eventually, we would like to implement this via some sort of dataflow that would be transparent to the user. =cut =head2 twiddle =for ref Enable GUI interaction with a FreeGLUT display window. With an argument, it sets the default value for the auto-twiddling state. C< 0 > will disable the automatic twiddling and C< 1 >, or true, will enable twiddling. =for usage twiddle(); # same as twiddle(undef) Runs the FreeGLUT event loop so window GUI operations such as resize, expose, mouse click,.. work twiddle(0); # disables twiddle looping for next twiddle() call twiddle(1); # re-enables default twiddle looping for next twiddle() call =cut sub imag2d { my ($img, $name, $zoom, $off_r, $off_c) = (undef,"Figure $cur_fig_num", undef, 0, 0); # need to add error checking here $img = (shift)->copy; $name = shift if scalar(@_); $zoom = shift if scalar(@_); $off_r = shift if scalar(@_); $off_c = shift if scalar(@_); my $window_id; my ($gldrawformat, $gldrawtype, $glds); # determine display pixel format and type to use if ($img->ndims > 2 && $img->dim(0) == 4) { $gldrawformat = GL_RGBA; $glds = 1; } elsif ($img->ndims > 2 && $img->dim(0) == 3) { $gldrawformat = GL_RGB; $glds = 1; } elsif ($img->ndims > 2 && $img->dim(0) == 2) { $gldrawformat = GL_LUMINANCE_ALPHA; $glds = 1; } elsif ($img->ndims > 2 && $img->dim(0) == 1) { $gldrawformat = GL_LUMINANCE; $glds = 1; } else { $gldrawformat = GL_LUMINANCE; $glds = 0; }; # convert to float if double for display if ($img->type->symbol eq 'PDL_D') { # clean up code $img = $img->float; } # determine display pixel type to use if ($img->type->symbol eq 'PDL_F') { $gldrawtype = GL_FLOAT; } elsif ($img->type->symbol eq 'PDL_B') { $gldrawtype = GL_UNSIGNED_BYTE; } elsif ($img->type->symbol eq 'PDL_S') { $gldrawtype = GL_SHORT; } elsif ($img->type->symbol eq 'PDL_US') { $gldrawtype = GL_UNSIGNED_SHORT; } elsif ($img->type->symbol eq 'PDL_L') { $gldrawtype = ( $gldrawformat == GL_RGBA ) ? GL_UNSIGNED_INT_8_8_8_8 : GL_INT; } else { die "display_image: unsupported data type '", $img->type->symbol, "' for image display\n"; } # create display window my ($im_height, $im_width); $im_height = $img->dim($glds+1); $im_width = $img->dim($glds+0); if ( !defined($zoom) and ( $im_width < 200 or $im_height < 200 ) ) { # adjust zoom to make initial window bigger than 200px my $mindim = ($im_width < $im_height) ? $im_width : $im_height; my $zoomest = int( 200 / $mindim ); $zoomest += 1 unless $zoomest == 200/$mindim; print STDERR "imag2d: estimated zoom factor is $zoomest\n" if $debug; $zoom = $zoomest; } $zoom = defined($zoom) ? $zoom : 1.0; print STDERR "imag2d: calling display_new_window( " . $img->dim($glds+1) . ", " . $img->dim($glds+0) . ", $zoom, $name, $off_r, $off_c )" if $debug; if ( ! defined( $window_id = display_new_window( $img->dim($glds+1), $img->dim($glds+0), $zoom, $name, $off_r, $off_c ) ) ) { print STDERR "imag2d: failure\n"; return; } # add GLUT window id to title glutSetWindowTitle($name . ": WinID $window_id"); $cur_fig_num++; # set callback function for image display glutDisplayFunc ( \&display_image ); # set callback function for keypress events glutKeyboardFunc ( \&key_ops ); # set callback for mouse clicks glutMouseFunc( \&mouse_click ); # set callback for image window resize glutReshapeFunc( \&resize_window ); glutCreateMenu( \&ModeMenu ); glutAddMenuEntry( "End MainLoop", $RELEASE ); glutAttachMenu(GLUT_RIGHT_BUTTON); # add image and window to list push @imag2d_list, { window_id => $window_id, img => $img }; # set callback for image window close glutCloseFunc( \&close_imag2d_window ); # success glRasterPos2i( 0, 0 ); glDrawPixels_s( $img->dim($glds+0), $img->dim($glds+1), $gldrawformat, $gldrawtype, $img->get_dataref ); glFlush(); # we don't twiddle if in PDL shell and glutRunning is on { no warnings 'once'; twiddle() unless defined $PERLDL::TERM and ref $Term::ReadLine::toloop; } return $window_id; } #------------------------------------------------------------------------ # Update imag2d() window image data #------------------------------------------------------------------------ sub imag2d_update { my ($win_id, $image) = @_; my $img; return unless scalar(@imag2d_list); # search for image corresponding to window foreach my $entry ( @imag2d_list ) { if ( $entry->{window_id} == $win_id ) { $img = $entry->{img}; # 2D piddle for now last; } } die "imag2d_update: callback could not find image window\n" unless defined $img; # update display window # TODO: do we need to save and restore the current window? # For now: calling imag2d_update makes that window current glutSetWindow($win_id); $img .= $image->sever; glutPostRedisplay(); # update display but don't force twiddle() glutMainLoopEvent(); return $win_id; } #------------------------------------------------------------------------ # Close a specific imag2d window #------------------------------------------------------------------------ sub close_imag2d_window { my $win_id = glutGetWindow(); if ( ! scalar(@imag2d_list) ) { $imag2d_is_twiddling = 0; return; } # search for image corresponding to window my ($entry, $found_it); foreach $entry ( @imag2d_list ) { if ($entry->{window_id} == $win_id) { $found_it = 1; last; } } print STDERR "close_imag2d_window: started with " . scalar(@imag2d_list) . " windows.\n" if $debug; if ($found_it) { @imag2d_list = grep { $_->{window_id} != $win_id } @imag2d_list; } else { warn "close_imag2d_window: could not find open window\n"; } print STDERR "close_imag2d_window: finished with " . scalar(@imag2d_list) . " windows.\n" if $debug; } #------------------------------------------------------------------------ # Close all imag2d windows #------------------------------------------------------------------------ sub close_imag2d { return unless scalar(@imag2d_list); # process all image windows foreach my $entry ( @imag2d_list ) { glutDestroyWindow($entry->{window_id}); } @imag2d_list = (); } #------------------------------------------------------------------------ # Simple twiddle for perldl (use [qQ] to exit) #------------------------------------------------------------------------ sub twiddle { my ($keeptwiddling) = @_; if (defined $keeptwiddling) { $imag2d_keep_twiddling = $keeptwiddling; return; } $imag2d_is_twiddling = (defined $imag2d_keep_twiddling) ? $imag2d_keep_twiddling : 1; if ( $imag2d_is_twiddling ) { print STDERR "Type Q or q to stop twiddling...\n"; while ($imag2d_is_twiddling && scalar(@imag2d_list)) { glutMainLoopEvent(); } print STDERR "Stopped twiddle-ing!\n"; } glutMainLoopEvent(); } #------------------------------------------------------------------------ # Threaded image display as tiles (code from PDL::Graphics::TriD::Image) #------------------------------------------------------------------------ # N-D piddle -> 2-D sub flatten { my ($this,$bin_align) = @_; my @dims = $this->dims; my $imdim0 = shift @dims; # get rid of the '3' my $xd = $dims[0]; my $yd = $dims[1]; my $xdr = $xd; my $ydr = $yd; # Calculate the whole width of the image. my $ind = 0; my $xm = 0; my $ym = 0; for (@dims[2..$#dims]) { if ($ind % 2 == 0) { $xd ++; # = $dims[$ind-2]; $xd *= $_; $xdr ++; $xdr *= $_; $xm++; } else { $yd ++; # = $dims[$ind-2]; $yd *= $_; $ydr ++; $ydr *= $_; $ym++; } $ind++; } $xd -= $xm; $yd -= $ym; # R because the final texture must be 2**x-aligned ;( my ($txd ,$tyd, $xxd, $yyd); if ($bin_align) { for ($txd = 0; $txd < 12 and 2**$txd < $xdr; $txd++) {}; for ($tyd = 0; $tyd < 12 and 2**$tyd < $ydr; $tyd++) {}; $txd = 2**$txd; $tyd = 2**$tyd; $xxd = ($xdr > $txd ? $xdr : $txd); $yyd = ($ydr > $tyd ? $ydr : $tyd); } else { $xxd=$txd=$xdr; $yyd=$tyd=$ydr; } my $p = PDL->zeroes(PDL::float(),$imdim0,$xxd,$yyd); # # object is PDL not PDL::Graphics::TriD::Image # if(defined $this->{Opts}{Bg}) { # $p .= $this->{Opts}{Bg}; # } # print "MKFOOP\n"; my $foop = $p->slice(":,0:".($xdr-1).",0:".($ydr-1)); $ind = $#dims; my $firstx = 1; my $firsty = 1; my $spi; for (@dims[reverse(2..$#dims)]) { $foop->make_physdims(); # print "FOOP: \n"; $foop->dump; if ($ind % 2 == 0) { $spi = $foop->getdim(1)/$_; $foop = $foop->splitdim(1,$spi)->slice(":,0:-2")->mv(2,3); } else { $spi = $foop->getdim(2)/$_; $foop = $foop->splitdim(2,$spi)->slice(":,:,0:-2"); } # print "IND+\n"; $ind++; # Just to keep even/odd correct } # $foop->dump; print "ASSGNFOOP!\n" if $PDL::debug; $foop .= $this->{Im}; # print "P: $p\n"; return wantarray() ? ($p,$xd,$yd,$txd,$tyd) : $p; } sub toimage { # initially very simple implementation my ($this) = @_; return $this->flatten(0); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/IIS/�����������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�012547� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/IIS/iis.pd�����������������������������������������������������������������������0000644�0601750�0601001�00000042704�12562522364�013707� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::Graphics::IIS - Display PDL images on IIS devices (saoimage/ximtool) =head1 SYNOPSIS use PDL::Graphics::IIS; saoimage ( -geometry => '800x800' ); iis rvals(100,100); =head1 DESCRIPTION This module provides an interface to any image display 'device' which support the 'IIS protocol' - viz the SAOimage and Ximtool X-windows programs, the old SunView imtool program and presumably even the original IIS CRT itself if they aren't all in museums! These programs should be familiar to astronomer's - they are used by the common IRAF system. The programs and their HTML documentation can be obtained from the following URLs: SAOimage: http://tdc-www.harvard.edu/software/saoimage.html Ximtool: http://iraf.noao.edu/iraf/web/projects/x11iraf/x11iraf.html Non-astronomer's may find they quite nifty for displaying 2D data. The Perl variable C<$stdimage> is exported from the module and controls the frame buffer configuration currently in use. The default value is C<imt1024> which specifies a C<1024x1024> frame buffer. Other values supported by the module are: imt512, imt800, imt1024, imt1600, imt2048, and imt4096. If you have a F<$HOME/.imtoolrc> you can use it to specify other frame buffer names and configurations in exactly the same way you can in IRAF. Here is a sample file: -------------------snip------------------------- # Format: configno nframes width height 1 2 512 512 # imt1|imt512 2 2 800 800 # imt2|imt800 3 2 1024 1024 # imt3|imt1024 4 1 1600 1600 # imt4|imt1600 5 1 2048 2048 # imt5|imt2048 6 1 4096 4096 # imt6|imt4096 7 1 8192 8192 # imt7|imt8192 8 1 1024 4096 # imt8|imt1x4 9 2 1144 880 # imt9|imtfs full screen (1152x900 minus frame) 10 2 1144 764 # imt10|imtfs35 full screen at 35mm film aspect ratio -------------------snip------------------------- (Note: some versions of SAOimage may not even work if this file is not present. If you get funny error messages about 'imtoolrc' try copying the above to F<$HOME/.imtoolrc> or F</usr/local/lib/imtoolrc>) The Perl variable C<$iisframe> is also exported from the module and controls which display frame number to use in programs such as Ximtool which supports multiple frames. This allows you to do useful things such as blink between images. The module communicates with the IIS device down FIFO pipes (special UNIX files) - unlike IRAF this module does a pretty decent job of intelligently guessing which file names to use for the pipes and will prompt for their creating if absent. Also if SAOimage or Ximtool are started from within Perl using the module this will guarantee correct file names! =head1 FUNCTIONS =cut EOD use Config; pp_add_exported('','iis iiscur iiscirc $stdimage $iisframe saoimage ximtool'); ############################## PM CODE ######################################## pp_addpm(<<'ENDOFPM'); use PDL::Core ''; use PDL::Basic ''; use Carp; $iisframe = 1; # Starting defaults $stdimage = "imt1024"; $last_stdimage = ""; $HOME = $ENV{'HOME'}; # Used a lot so shorten ################ Public routines ################# # Display =head2 iis =for ref Displays an image on a IIS device (e.g. SAOimage/Ximtool) =for usage iis $image, [ { MIN => $min, MAX => $max, TITLE => 'pretty picture', FRAME => 2 } ] iis $image, [$min,$max] =for sig (image(m,n),[\%options]) or (image(m,n),[min(),max()]) Displays image on a IIS device. If C<min()> or C<max()> are omitted they are autoscaled. A good demonstration of PDL threading can be had by giving C<iis()> a data *cube* - C<iis()> will be repeatedly called for each plane of the cube resulting in a poor man's movie! If supplied, C<TITLE> is used to label the frame, if no title is supplied, either the C<OBJECT> value stored in the image header or a default string is used (the title is restricted to a maximum length of 32 characters). To specify which frame to draw to, either use the package variable C<$iisframe>, or the C<FRAME> option. =cut sub iis { my $usage = 'Usage: iis ( $image, [\%hash | $min, $max] )'; barf $usage if $#_<0 || $#_>2; my $image = shift; my ( $min, $max ); my $title = 'perlDL rules !'; my $header = $image->gethdr(); if ( defined $header and defined $$header{OBJECT} ) { $title = $$header{OBJECT}; $title =~ s/^'(.*)'$/$1/; } my $frame = $iisframe; if ( $#_ == 1 ) { $min = $_[0]; $max = $_[1]; } elsif ( $#_ == 0 ) { barf $usage unless ref($_[0]) eq "HASH"; my $opt = new PDL::Options( { MIN => undef, MAX => undef, TITLE => $title, FRAME => $frame } ); $opt->options( shift ); my $options = $opt->current; $min = $$options{MIN}; $max = $$options{MAX}; $title = $$options{TITLE}; $iisframe = $$options{FRAME}; } my($nx,$ny) = dims($image); fbconfig($stdimage) if $stdimage ne $last_stdimage; $min = $image->min unless defined $min; $max = $image->max unless defined $max; print "Displaying $nx x $ny image in frame $iisframe from $min to $max ...\n" if $PDL::verbose; PDL::_iis($image,$min,$max,$title); $iisframe = $frame; # restore value 1; } =head2 iiscur =for ref Return cursor position from an IIS device (e.g. SAOimage/Ximtool) =for usage ($x,$y) = iiscur($ch) This function puts up an interactive cursor on the IIS device and returns the C<($x,$y)> position and the character typed (C<$ch>) by the user. =cut sub iiscur { barf 'Usage: ($x,$y) = iiscur($ch)' if $#_>=1; my ($x,$y,$ch) = _iiscur_int(); $_[0] = $ch; # Pass this back in args return ($x,$y); } =head2 iiscirc =for ref Draws a circle on a IIS device (e.g. SAOimage/Ximtool) =for sig (x(),y(),radius(),colour()) =for usage iiscirc $x, $y, [$radius, $colour] Draws circles on the IIS device with specied points and colours. Because this module uses L<PDL::PP|PDL::PP> threading you can supply lists of points via 1D arrays, etc. An amusing PDL idiom is: pdl> iiscirc iiscur Note the colours are the same as IRAF, viz: 201 = cursor color (white) 202 = black 203 = white 204 = red 205 = green 206 = blue 207 = yellow 208 = cyan 209 = magenta 210 = coral 211 = maroon 212 = orange 213 = khaki 214 = orchid 215 = turquoise 216 = violet 217 = wheat =cut sub iiscirc { barf 'Usage: iiscirc( $x, $y, [$radius, $colour] )' if $#_<1 || $#_>3; my($x, $y, $radius, $colour)=@_; fbconfig($stdimage) if $stdimage ne $last_stdimage; $radius = 10 unless defined $radius; $colour = 204 unless defined $colour; PDL::_iiscirc($x, $y, $radius, $colour); 1; } =head2 saoimage =for ref Starts the SAOimage external program =for usage saoimage[(command line options)] Starts up the SAOimage external program. Default FIFO devices are chosen so as to be compatible with other IIS module functions. If no suitable FIFOs are found it will offer to create them. e.g.: =for example pdl> saoimage pdl> saoimage( -geometry => '800x800' ) =cut sub saoimage { # Start SAOimage fbconfig($stdimage) if $stdimage ne $last_stdimage; if( !($pid = fork)) { # error or child exec("saoimage", -idev => $fifo, -odev => $fifi, @_) if defined $pid; die "Can't start saoimage: $!\n"; } return $pid; } =head2 ximtool =for ref Starts the Ximtool external program =for usage ximtool[(command line options)] Starts up the Ximtool external program. Default FIFO devices are chosen so as to be compatible with other IIS module functions. If no suitable FIFOs are found it will offer to create them. e.g. =for example pdl> ximtool pdl> ximtool (-maxColors => 64) =cut sub ximtool { # Start Ximtool fbconfig($stdimage) if $stdimage ne $last_stdimage; if( !($pid = fork)) { # error or child exec("ximtool", -xrm => "ximtool*input_fifo: $fifi", -xrm => "ximtool*output_fifo: $fifo", @_) if defined $pid; die "Can't start ximtool: $!\n"; } return $pid; } ################ Private routines ################# # Change the frame buffer configuration sub fbconfig { my $name = shift; parseimtoolrc() unless $parsed++; findfifo() unless $foundfifo++; barf 'No frame buffer configuration "'.$name.'" found'."\n" unless defined $imtoolrc{$name}; ($fbconfig, $fb_x, $fb_y ) = @{ $imtoolrc{$name} }; print "Using $stdimage - fbconfig=$fbconfig (${fb_x}x$fb_y)\n" if $PDL::verbose;; $last_stdimage = $stdimage; 1;} # Try and find user/system imtoolrc definitions sub parseimtoolrc { # assoc array holds imtool configuations - init with some standard # ones in case imtoolrc goes missing %imtoolrc = ( 'imt512' => [1,512,512], 'imt800' => [2,800,800], 'imt1024' => [3,1024,1024], 'imt1600' => [4,1600,1600], 'imt2048' => [5,2048,2048], 'imt4096' => [6,4096,4096], ); # Look for imtoolrc file $imtoolrc = "/usr/local/lib/imtoolrc"; $imtoolrc = "$HOME/.imtoolrc" if -e "$HOME/.imtoolrc"; if (!-e $imtoolrc) { warn "WARNING: unable to find an imtoolrc file in $HOME/.imtoolrc\n". "or /usr/local/lib/imtoolrc. Will try \$stdimage = imt1024.\n"; return 1; } # Load frame buffer configuartions from imtoolrc file and # store in assoc array open(IMTOOLRC, $imtoolrc) || die "File $imtoolrc not found"; while(<IMTOOLRC>) { if ( /^\s*(\d+)\s+\d+\s+(\d+)\s+(\d+)\s+\#\s*(\S+)\s/ ) { foreach $name (split(/\|/,$4)) { $imtoolrc{$name} = [$1,$2,$3]; } } }close(IMTOOLRC); 1;} # Try a few obvious places for the FIFO pipe and create if necessary sub findfifo { $fifi = ""; $fifo = ""; if (-e "/dev/imt1i" && -e "/dev/imt1o") { $fifi = "/dev/imt1i"; $fifo = "/dev/imt1o"; } if (-e "$HOME/dev/imt1i" && -e "$HOME/dev/imt1o") { $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o"; } if (-e "$HOME/iraf/dev/imt1i" && -e "$HOME/iraf/dev/imt1o") { $fifi = "$HOME/iraf/dev/imt1i"; $fifo = "$HOME/iraf/dev/imt1o"; } if (defined $ENV{'IMTDEV'} && $ENV{'IMTDEV'} =~ /^fifo:(.*):(.*)$/) { $fifi = $1; $fifo = $2; } if ($fifi eq "" && $fifo eq "") { # Still not found use this default warn "WARNING: cannot locate FIFO pipes in /dev/, $HOME/dev, ". "$HOME/iraf/dev or environment variable \$IMTDEV\n"; $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o"; } print "Using FIFO devices in: $fifi\n". " out: $fifo\n" if $PDL::verbose; for $pipe ($fifi, $fifo) { if (!-p $pipe) { print "FIFO $pipe does not exist - try and create now? "; my $ans = <STDIN>; system "/usr/etc/mknod $pipe p" if $ans =~ /^y/i; if ($ans =~ /^y/i) { unlink $pipe if -e $pipe; my $path = $ENV{PATH}; $ENV{PATH} .= ":/etc:/usr/etc"; # Note system return value is backwards - hence 'and' if ( system('mknod', $pipe, 'p') and system('mkfifo',$pipe) ) { die "Failed to create named pipe $pipe\n"; } $ENV{PATH} = $path; } } } 1;} ENDOFPM ################################ XS CODE ###################################### pp_addhdr(<<"EOD"); #include "libiis.h" EOD # Non-blocking I/O pp_addhdr(<<"EOD") if defined $Config{'o_nonblock'} && $Config{'o_nonblock'} ne 'O_NONBLOCK'; #define O_NONBLOCK $Config{'o_nonblock'} EOD pp_addhdr(<<"EOD"); #include "pdliisdisp.c" EOD pp_addxs('',<<'EOD'); MODULE = PDL::Graphics::IIS PACKAGE = PDL::Graphics::IIS void _iiscur_int() PPCODE: STRLEN n_a; STRLEN n_b; float x,y; char ch; int frame = (int)SvIV( perl_get_sv("iisframe", FALSE) ); iis_open(SvPV(perl_get_sv("fifi",FALSE),n_a),SvPV(perl_get_sv("fifo",FALSE),n_b), (int)SvIV( perl_get_sv("fbconfig", FALSE) ), (int)SvIV( perl_get_sv("fb_x", FALSE) ), (int)SvIV( perl_get_sv("fb_y", FALSE) ) ); iis_cur(&x,&y,&ch); iis_close(); EXTEND(sp,3); PUSHs(sv_2mortal(newSVnv((float)x))); PUSHs(sv_2mortal(newSVnv((float)y))); PUSHs(sv_2mortal(newSVpv(&ch,1))); EOD # Internal routine for iis() pp_bless('PDL::Graphics::IIS'); pp_def('_iis', Pars => 'image(m,n); min(); max();', OtherPars => 'char *perl_title', Doc => undef, Code => ' int frame = (int)SvIV( perl_get_sv("iisframe", FALSE) ); unsigned short hdr[8]; unsigned char *data; int j,nlines, x,y, offx, offy, nx, ny, nx2, ny2, baseX, baseY, m1, n1; int ntrans; float xx, yx, xy, yy, xo, yo; int w_type; /* WCS */ float fmin, fmax; char wcsbuf[SZ_WCSTEXT]; char title[33]; /* 32 chars + null terminator */ int chan; STRLEN n_a; STRLEN n_b; /* Open pipes etc */ if (frame<1 || frame>4) barf("$iisframe must be in range 1--4"); iis_open(SvPV(perl_get_sv("fifi",FALSE),n_a),SvPV(perl_get_sv("fifo",FALSE),n_b), (int)SvIV( perl_get_sv("fbconfig", FALSE) ), (int)SvIV( perl_get_sv("fb_x", FALSE) ), (int)SvIV( perl_get_sv("fb_y", FALSE) ) ); /* Convenience variables */ nx = $PRIV(__m_size); ny = $PRIV(__n_size); fmin = (float) $min(); fmax = (float) $max(); chan = iis_chan(frame); /* Work out how many lines to transfer at a go */ ntrans = BUFFSZ/frameX; if (ntrans<1) ntrans = 1; /* Allocate buffer for data transfers */ data = (unsigned char*) calloc(ntrans*frameX, sizeof(unsigned char)); if (data==NULL) iis_error("iis_display: out of memory for buffer",""); threadloop %{ /* Send WCS info */ hdr[TRANSFER_ID] = PDL_IIS_IWRITE | PACKED; hdr[THING_COUNT] = -SZ_WCSTEXT; hdr[SUB_UNIT] = WCS; hdr[CHECK_SUM] = 0; hdr[X_REGISTER] = 0; hdr[Y_REGISTER] = 0; hdr[Z_REGISTER] = chan; hdr[T_REGISTER] = fbconfig-1; /* fbconfig number */ iis_checksum(hdr); iis_write((char*)hdr, 8*sizeof(short)); offx = 0; offy = 0; /* Centre image in frame if small */ if (nx<frameX) offx = (frameX-nx)/2; if (ny<frameY) offy = (frameY-ny)/2; nx2 = nx; ny2 = ny; baseX=0; baseY=0; /* Truncate image if too big */ if (nx>frameX) { nx2=frameX; baseX = (nx-frameX)/2; } if (ny>frameY) { ny2=frameY; baseY = (ny-frameY)/2; } /* Note my WCS is zero offset! */ xx=1; yx=0; xy=0; yy=-1; xo=baseX-offx; yo=baseY+frameY-offy-1; w_type=1; strncpy( title, $COMP(perl_title), 32 ); title[32] = ' . "'" . '\0' . "'" . '; sprintf (wcsbuf, "%-33s\n%f %f %f %f %f %f %f %f %d", title, /*** was "perlDL rules!", ***/ xx, yx, xy, yy, xo, yo, fmin, fmax, w_type); iis_write((char*)wcsbuf, SZ_WCSTEXT*sizeof(char)); /* Reset the frame buffer */ hdr[TRANSFER_ID] = fbconfig-1; /* fbconfig number */ hdr[THING_COUNT] = 0; hdr[SUB_UNIT] = FEEDBACK; hdr[CHECK_SUM] = 0; hdr[X_REGISTER] = 0; hdr[Y_REGISTER] = 0; hdr[Z_REGISTER] = chan; hdr[T_REGISTER] = 0; iis_checksum(hdr); iis_write((char*)hdr, 8*sizeof(short)); { $GENERIC() val,sval; for (y = 0; y < ny2; y+=ntrans) { nlines = ntrans; /* Number of lines to transfer */ if (y+ntrans>ny2) nlines = ny2 - y; /* create header */ hdr[TRANSFER_ID] = PDL_IIS_IWRITE | PACKED | BLOCKXFER; hdr[THING_COUNT] = -nlines*frameX; hdr[SUB_UNIT] = REFRESH; hdr[CHECK_SUM] = 0; hdr[X_REGISTER] = ADVXONTC; hdr[Y_REGISTER] = ADVYONXOV+frameY-y-nlines-offy; hdr[Z_REGISTER] = chan; hdr[T_REGISTER] = ALLBITPL; iis_checksum(hdr); iis_write((char*)hdr, 8*sizeof(short)); for (j=0; j<nlines; j++) { n1 = baseY+y+nlines-j-1; for (x = 0; x < nx2; x++) { m1 = x + baseX; val = $image(m=>m1, n=>n1); sval = FMIN+(val-fmin)*(FMAX-FMIN)/(fmax-fmin); if (sval<FMIN) sval = FMIN; if (sval>FMAX) sval = FMAX; data[j*frameX+x+offx] = (unsigned char) sval; } } iis_write((char*)data, nlines*frameX*sizeof(char) ); } } %} free(data); iis_close(); '); # End of iis_c pp_def pp_def( '_iiscirc', Pars => 'x(); y(); r(); colour();', Doc => undef, Code => ' int frame = (int)SvIV( perl_get_sv("iisframe", FALSE) ); STRLEN n_a; /* Open pipes etc */ if (frame<1 || frame>4) barf("$iisframe must be in range 1--4"); iis_open(SvPV(perl_get_sv("fifi",FALSE),n_a),SvPV(perl_get_sv("fifo",FALSE),n_a), (int)SvIV( perl_get_sv("fbconfig", FALSE) ), (int)SvIV( perl_get_sv("fb_x", FALSE) ), (int)SvIV( perl_get_sv("fb_y", FALSE) ) ); threadloop %{ iis_drawcirc( (float) $x(), (float) $y(), (float) $r(), (int) $colour(), frame); %} iis_close(); '); # End of iiscirc_c pp_def pp_addpm({At=>Bot},<<'EOD'); =head1 BUGS None known =head1 AUTHOR Copyright (C) Karl Glazebrook 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); ������������������������������������������������������������PDL-2.018/Graphics/IIS/libiis.h���������������������������������������������������������������������0000644�0601750�0601001�00000007232�12562522364�014217� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� /* Note: libiis.h in PDL distribution has iis_display redefined */ /* libiis.h - IIS constants for IIS C library v1.0 Loosely based on code from various sources Karl Glazebrook, Anglo-Australian Observatory 30/May/1996 email: kgb@aaoepp.aao.gov.au */ #include <stdio.h> #include <math.h> #include <stdlib.h> #include <fcntl.h> #include <unistd.h> #include <string.h> #define TRANSFER_ID 0 #define THING_COUNT 1 #define SUB_UNIT 2 #define CHECK_SUM 3 #define X_REGISTER 4 #define Y_REGISTER 5 #define Z_REGISTER 6 #define T_REGISTER 7 /* Transfer ID definitions */ #define PDL_IIS_IREAD 0100000 #define PDL_IIS_IWRITE 00 #define PACKED 040000 #define BYPASSIFM 020000 #define BYTE 010000 #define ADDWRITE 04000 #define ACCUM 02000 #define BLOCKXFER 01000 #define VRETRACE 0400 #define MUX32 0200 #define IMT800 0100 /* Subunits */ #define REFRESH 01 #define LUT 02 #define OFM 03 #define IFM 04 #define FEEDBACK 05 #define SCROLL 06 #define VIDEOM 07 #define SUMPROC 010 #define GRAPHICS 011 #define CURSOR 012 #define ALU 013 #define ZOOM 014 #define IPB 017 /* following from iraf "iis.h" */ #define IMCURSOR 020 #define WCS 021 /* checksum */ #define CHECKSUMVAL 0177777 /* Command definitions from iraf iis.h */ #define COMMAND 100000B /* X-register */ #define ADVXONTC 0100000 #define ADVXONYOV 040000 /* Y-register */ #define ADVYONXOV 0100000 #define ADVYONTC 040000 /* Z-register */ #define CHAN1 01 #define CHAN2 02 #define CHAN3 04 #define CHAN4 010 #define GRCHAN 0100000 /* T-register */ #define BITPL0 01 #define BITPL1 02 #define BITPL2 04 #define BITPL3 010 #define BITPL4 020 #define BITPL5 040 #define BITPL6 0100 #define BITPL7 0200 #define ALLBITPL 0377 /* IIS WCS buffer */ /* Imtool colour numbers */ #define FMIN 1 #define FMAX 200 #define IIS_GREEN 201 #define IIS_BLACK 202 #define IIS_WHITE 203 #define IIS_RED 204 #define IIS_BLUE 206 #define IIS_YELLOW 207 /* Buffer sizes */ #define BUFFSZ 16384 /* Approx number of bytes to transfer per record */ #define RBUFFSZ 2048 /* Approx number of bytes to transfer when reading */ #define STRSIZE 1024 /* Useful string size */ #define SZ_WCSTEXT 320 /* WCS text */ /* Global variables */ static int iispipe_i; /* FIFO pipe handles */ static int iispipe_o; static int fbconfig; /* Frame buffer configaration */ static int frameX; static int frameY; /* Public functions prototypes */ int iis_display(void *f, int datatype, int N1, int N2, float fmin, float fmax, int frame); void iis_cur(float*x, float*y, char* ch); void iis_drawcirc(float xcen, float ycen, float radius, int colour, int frame); void iis_open(char* inpipe, char* outpipe, int fb, int fbx, int fby); void iis_close(); /* Private functions prototypes */ void iis_write(char* buf, int size); void iis_read (char* buf, int size); void iis_checksum(unsigned short *hdr); void iis_error(char* error1, char* error2); int iis_chan(int frame); int iis_round ( float i ); float iis_abs (float x); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/IIS/Makefile.PL������������������������������������������������������������������0000644�0601750�0601001�00000000600�12562522364�014535� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; if ($^O =~ /win32/i) { write_dummy_make(unsupported('PDL::Graphics::IIS','win32')); return; } my @pack = (["iis.pd", qw(IIS PDL::Graphics::IIS)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS} = ['-lm']; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); ��������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/IIS/pdliisdisp.c�����������������������������������������������������������������0000644�0601750�0601001�00000024272�12562522364�015106� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/*************************************************************** pdliisdisplay.c ****************************************************************/ /* Redefine iis_error to use Perl's croak() */ void iis_error( char* error1, char*error2 ) { croak (error1,error2); } /*****************************************************/ /* Rest of the subroutines are identical to libiis.c v1.0 */ /******************* iis_cur ************************/ /* Return cursor position and character typed */ void iis_cur(float*x, float*y, char* ch) { unsigned short hdr[8]; short buf[SZ_WCSTEXT]; int nbytes,wcs; /* Send read request */ hdr[TRANSFER_ID] = PDL_IIS_IREAD; hdr[THING_COUNT] = 0; hdr[SUB_UNIT] = IMCURSOR; hdr[CHECK_SUM] = 0; hdr[X_REGISTER] = 0; hdr[Y_REGISTER] = 0; hdr[Z_REGISTER] = 0; hdr[T_REGISTER] = 0; iis_checksum(hdr); iis_write((char*)hdr, 8*sizeof(short)); /* Read however many bytes it send in this case */ if ((nbytes = read (iispipe_i, buf, SZ_WCSTEXT)) <= 0) iis_error ("iis_cur: cannot read IIS pipe\n",""); if (sscanf ((char*)buf, "%f %f %d %c", x, y, &wcs, ch) != 4) iis_error ("iis_cur: can't parse '%s'\n", (char*)buf); } /******************* iis_drawcirc *******************/ /* Draw a circle on the image display at a given position */ void iis_drawcirc(float xcen, float ycen, float radius, int colour, int frame) { unsigned short hdr[8]; unsigned char *data; int i,j,y; int ymin,ymax,ntrans,nlines,nbytes; float xcen2,ycen2,dd; char wcsbuf[SZ_WCSTEXT]; float xx, yx, xy, yy, xo, yo; /* wcs matrix values */ float xx2, yx2, xy2, yy2, xo2, yo2; /* wcs inverse matrix values */ char label[1024]; /* wcs file title */ int w_type; /* wcs scaling code */ float low, high; /* wcs scaling limits */ int chan; float rr; chan = iis_chan(frame); /* Send WCS read request */ hdr[TRANSFER_ID] = -PDL_IIS_IREAD; hdr[THING_COUNT] = 0; hdr[SUB_UNIT] = WCS; hdr[CHECK_SUM] = 0; hdr[X_REGISTER] = 0; hdr[Y_REGISTER] = 0; hdr[Z_REGISTER] = chan; hdr[T_REGISTER] = 0; iis_checksum(hdr); iis_write((char*)hdr, 8*sizeof(short)); iis_read ((char*)wcsbuf, SZ_WCSTEXT); /* Get WCS data */ sscanf(wcsbuf, "%[^\n]\n%f%f%f%f%f%f%f%f%d", label, &xx, &yx, &xy, &yy, &xo, &yo, &low, &high, &w_type); /* Invert transform (I don't care about non-square coord systems! */ xcen2 = (xcen-xo)/xx; ycen2 = frameY - (ycen-yo)/yy - 1; /* Correct scale factor - OK for square images don't want to draw ellipses for non-square ones so take geometric mean */ rr = radius / sqrt(iis_abs(xx*yy)); /* Transfer limits (with buffer to allow for edge effects) */ ymin = ycen2-rr-2; if (ymin<0) ymin=0; ymax = ycen2+rr+2; if (ymax>=frameY) ymax=frameY-1; /* Work out how many lines to transfer at a go */ ntrans = RBUFFSZ/frameX; if (ntrans<1) ntrans = 1; /* Allocate buffer for data transfers */ data = (unsigned char*) calloc(ntrans*frameX, sizeof(unsigned char)); if (data==NULL) iis_error("iis_drawcirc: out of memory for buffer",""); /* Loop over blocks */ for (y = ymin; y < ymax; y+=ntrans) { nlines = ntrans; /* Number of lines to transfer */ if (y+ntrans>ymax) nlines = ymax - y; /* Read data */ hdr[TRANSFER_ID] = -PDL_IIS_IREAD | PACKED | BLOCKXFER; hdr[THING_COUNT] = -nlines*frameX; hdr[SUB_UNIT] = REFRESH; hdr[CHECK_SUM] = 0; hdr[X_REGISTER] = ADVXONTC; hdr[Y_REGISTER] = ADVYONXOV+frameY-y-nlines; hdr[Z_REGISTER] = chan; hdr[T_REGISTER] = ALLBITPL; iis_checksum(hdr); iis_write((char*)hdr, 8*sizeof(short)); iis_read((char*)data, nlines*frameX*sizeof(char)); /* Write data */ hdr[TRANSFER_ID] = PDL_IIS_IWRITE | PACKED | BLOCKXFER; hdr[THING_COUNT] = -nlines*frameX; hdr[SUB_UNIT] = REFRESH; hdr[CHECK_SUM] = 0; hdr[X_REGISTER] = ADVXONTC; hdr[Y_REGISTER] = ADVYONXOV+frameY-y-nlines; hdr[Z_REGISTER] = chan; hdr[T_REGISTER] = ALLBITPL; iis_checksum(hdr); iis_write((char*)hdr, 8*sizeof(short)); /* Change Data - draw in i and j to fill circle gaps via symmetry */ for (j=0; j<nlines; j++) { dd = rr*rr - (y+j-ycen2)*(y+j-ycen2); if (dd>=0) { dd = sqrt(dd); i = iis_round( (float)xcen2 - dd ); if (i>=0 && i<frameX) data[ (nlines-j-1)*frameX + i ] = colour; i = iis_round( (float)xcen2 + dd ); if (i>=0 && i<frameX) data[ (nlines-j-1)*frameX + i ] = colour; } } for (i=0; i<frameX; i++) { dd = rr*rr - (i-xcen2)*(i-xcen2); if (dd>=0) { dd = sqrt(dd); j = iis_round( (float)ycen2 - (float)y - dd ); if (j>=0 && j<nlines) data[ (nlines-j-1)*frameX + i ] = colour; j = iis_round( (float)ycen2 - (float)y + dd ); if (j>=0 && j<nlines) data[ (nlines-j-1)*frameX + i ] = colour; } } iis_write((char*)data, nlines*frameX*sizeof(char)); } free(data); } /******************* iis_open ****************/ /* Open IIS connection - if inpipe or outpipe are "" default pipes are searched for in the environment variable $IMTDEV, then in the directories (with the usual filenames) $HOME/iraf/dev, $HOME/dev, and finally /dev. Note the frame buffer configuration number and dimensions must be suppled by hand - life is too short to write imtoolrc parsing code in C! If these don't match those in the appropriate imtoolrc file problems will occur. */ void iis_open(char* inpipe, char* outpipe, int fb, int fbx, int fby) { FILE *syspipe; char *home, *imtdev, *tok=NULL; char iname[STRSIZE],oname[STRSIZE]; int i,j; home = getenv("HOME"); imtdev = getenv("IMTDEV"); if (imtdev != NULL) /* Start parsing IMTDEV environment variable */ tok = strtok(imtdev,":"); if (tok!=NULL && strcmp(tok,"fifo")!=0) /* Ignore if not fifo */ tok = NULL; /* Get input fifo name */ if (strcmp(inpipe,"")==0) { if (tok!=NULL) { /* Check next bit of IMTDEV */ tok = strtok(NULL,":"); if (tok != NULL) { strncpy(iname,tok,STRSIZE); goto gotin; } } /* Else look in standard places */ strncpy(iname,home,STRSIZE); strncat(iname,"/iraf/dev/imt1i",STRSIZE); if (!access(iname,F_OK)) goto gotin; strncpy(iname,home,STRSIZE); strncat(iname,"/dev/imt1i",STRSIZE); if (!access(iname,F_OK)) goto gotin; strncpy(iname,"/dev/imt1i",STRSIZE); if (!access(iname,F_OK)) goto gotin; } else { strncpy(iname,inpipe,STRSIZE); /* Use supplied arg */ goto gotin; } iis_error("Unable to locate input FIFO in any of $HOME/dev/imt1i or %s", "$HOME/dev/imt1i or /dev/imt1i\n"); gotin: if (strcmp(outpipe,"")==0) { /* Get output fifo name */ if (tok!=NULL) { /* Check next bit of IMTDEV */ tok = strtok(NULL,":"); if (tok != NULL) { strncpy(oname,tok,STRSIZE); goto gotout; } } /* Else look in standard places */ strncpy(oname,home,STRSIZE); strncat(oname,"/iraf/dev/imt1o",STRSIZE); if (!access(oname,F_OK)) goto gotout; strncpy(oname,home,STRSIZE); strncat(oname,"/dev/imt1o",STRSIZE); if (!access(oname,F_OK)) goto gotout; strncpy(oname,"/dev/imt1o",STRSIZE); if (!access(oname,F_OK)) goto gotout; } else { strncpy(oname,outpipe,STRSIZE); /* Use supplied arg */ goto gotout; } iis_error("Unable to locate output FIFO in any of $HOME/iraf/dev/imt1o or %s", "$HOME/dev/imt1o or /dev/imt1o\n"); gotout: /* Open the output fifo. We have to open it ourselves first as a client to get around the fifo open-no-client error. */ if ((iispipe_i = open (oname, O_RDONLY | O_NONBLOCK)) != -1) { if ((iispipe_o = open (oname, O_WRONLY | O_NONBLOCK)) != -1) { fcntl (iispipe_o, F_SETFL, O_WRONLY); } else iis_error("iis_open: cannot open IIS output pipe %s\n",oname); close (iispipe_i); } else iis_error("iis_open: cannot open IIS output pipe %s\n",oname); /* Open the input fifo */ if ((iispipe_i = open (iname, O_RDONLY | O_NONBLOCK)) != -1) { /* Clear input for reading. */ fcntl (iispipe_i, F_SETFL, O_RDONLY); } else iis_error("iis_open: cannot open IIS input pipe %s\n",iname); fbconfig = fb; frameX = fbx; frameY = fby; /* Frame buffer globals */ } /******************* iis_close ****************/ /* Close the IIS connection */ void iis_close() { close(iispipe_o); close(iispipe_i); } /******************* Private routines ****************/ /* write to pipe */ void iis_write (char* buf, int size) { int n = 0; int total = 0; while (total < size) { n = write (iispipe_o, buf, size - total); if (n <= 0) iis_error ("iis_write: can't write to pipe\n",""); total += n; } } /* read from pipe */ void iis_read (char* buf, int size) { int n = 0; int total = 0; while (total < size) { n = read (iispipe_i, buf, size - total); if (n <= 0) iis_error ("iis_read: can't read from pipe\n",""); total += n; } } void iis_checksum ( unsigned short *hdr ) { int indx; int checksum = 0; for (indx = 0; indx < 8; indx++) { checksum += hdr[indx]; } hdr[CHECK_SUM] = CHECKSUMVAL - (unsigned short) checksum; } /* Return the channel number associated with a display frame */ int iis_chan(int frame) { int chan[5]; chan[1]=CHAN1; chan[2]=CHAN2; chan[3]=CHAN3; chan[4]=CHAN4; if (frame>0 && frame<5) return chan[frame]; else { iis_error("iis_display: invalid frame number, must be 1-4\n",""); return -1; } } /* Round to nearest int symmetrically about zero */ int iis_round ( float i ) { if (i>=0) return (int) (i+0.5); else return -( (int)(0.5-i) ); } float iis_abs(float x) { if (x<0) return (-x); else return x; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/Limits/��������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402044�013362� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/Limits/Limits.pm�����������������������������������������������������������������0000644�0601750�0601001�00000107752�12562522364�015217� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package PDL::Graphics::Limits; use strict; use warnings; require Exporter; our @ISA = qw(Exporter); our %EXPORT_TAGS = ( 'all' => [ qw( limits ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( limits ); our $VERSION = '0.01'; $VERSION = eval $VERSION; # Preloaded methods go here. use PDL::Core qw( cat pdl ); use PDL::Primitive qw( append ); use PDL::Fit::Polynomial; use PDL::Options; use PDL::Bad; use Carp; use POSIX qw( log10 ); use strict; use warnings; ################################################################################ # figure out what's good in a piddle after a possible transformation which could # generate Infs or NaN's. If only everyone used PDL::Bad::UseNaN... sub set_mask { my ( $mask, $data ) = @_; if ( $PDL::Bad::Status ) { my $badflag = $data->badflag(); $data->badflag(1); $mask .= $PDL::Bad::UseNaN ? (! $data->isbad ) : ( $data->isfinite & ! $data->isbad ); $data->badflag($badflag); } else { $mask .= $data->isfinite; } } { package PDL::Graphics::Limits::DSet; use PDL::Core qw( cat pdl ); *set_mask = \*PDL::Graphics::Limits::set_mask; sub new { my $class = shift; my $self = bless {}, $class; my ( $min, $max ) = splice( @_, 0, 2 ); $self->{Vectors} = [ @_ ]; $self->{MinMax} = [ map{ [ $min, $max ] } 1..@{$self->{Vectors}} ]; $self; } sub ndim { scalar @{$_[0]->{Vectors}} } sub validate { my ( $self, $attr) = @_; my $ivec = 0; my $n; foreach my $vec ( @{$self->{Vectors}} ) { die( 'vector ', $ivec+1, ": no data?\n" ) unless defined $vec->{data}; $n = $vec->{data}->nelem unless defined $n; # if a data set vector has no transformation function, use the # default in $attr{Trans} $vec->{trans} = $attr->{Trans}[$ivec] if ! exists $vec->{trans} && exists $attr->{Trans}[$ivec]; # remove explicitly undefined trans delete $vec->{trans} if exists $vec->{trans} && ! defined $vec->{trans}; # ensure that data and errors have the same length. die( 'vector ', $ivec+1, ": attribute $_: ", "inconsistent number of elements", "expected $n, got ", $vec->{$_}->nelem, "\n" ) foreach grep { exists $vec->{$_} && defined $vec->{$_} && $vec->{$_}->nelem != $n } qw( data en ep ); } continue { $ivec++; } } sub vector { $_[0]->{Vectors}[$_[1]]; } sub set_minmax { my ( $dset, $min, $max, $axis ) = @_; my $mm = $dset->{MinMax}[$axis]; $mm->[0] = $min if defined $min; $mm->[1] = $max if defined $max; } sub upd_minmax { my ( $dset, $min, $max, $axis ) = @_; my $mm = $dset->{MinMax}[$axis]; $mm->[0] = $min if $mm->[0] > $min; $mm->[1] = $max if $mm->[1] < $max; } sub get_minmax { my ( $dset ) = @_; cat( map { pdl( $dset->{MinMax}[$_] ) } 0..$dset->ndim-1 ); } sub calc_minmax { my $dset = shift; my @axes = @_ ? ( $_[0] ) : ( 0 ..$dset->ndims-1 ); $dset->calc_minmax_axis( $_ ) foreach @axes; } ##################################################################### # determine the limits for a dataset. sub calc_minmax_axis { my ( $dset, $axis ) = @_; my $vec = $dset->{Vectors}[$axis]; my $data = $vec->{data}; my $xfrm = defined $vec->{trans}; # we need the transformed data point min max in case # a transformed data + error is out of range of the transform # function (e.g. log(0)). my @minmax; # reuse these as much as possible to reduce memory hit my $tmp; my $mask = PDL::null; # i know of no way of determining whether a function can be applied inplace. # assume not. # if xfrm is true, $tmp will be an independent piddle, else its an alias for data # no need to create a new piddle unless necessary. $tmp = $xfrm ? $vec->{trans}->($data) : $data; set_mask( $mask, $tmp ); push @minmax, $tmp->where($mask)->minmax; if ( defined $vec->{errn} ) { # worry about not overwriting the original data! if ( $xfrm ) { $tmp .= $vec->{trans}->($data - $vec->{errn}) } else { $tmp = $data - $vec->{errn} } set_mask( $mask, $tmp ); push @minmax, $tmp->where($mask)->minmax; } if ( defined $vec->{errp} ) { # worry about not overwriting the original data! if ( $xfrm ) { $tmp .= $vec->{trans}->($data + $vec->{errp}) } else { $tmp = $data + $vec->{errp} } set_mask( $mask, $tmp ); push @minmax, $tmp->where($mask)->minmax; } my ( $min, $max ) = PDL::Core::pdl( @minmax )->minmax; $dset->set_minmax( $min, $max, $axis ); } } ##################################################################### # based upon PGPLOT's pgrnge routine. sub range_frac { my ( $axis, $frac, $zerofix ) = @_; my $expand = $frac * ( $axis->[1] - $axis->[0] ); my $min = $axis->[0] - $expand; my $max = $axis->[1] + $expand; if ( $zerofix ) { $min = 0.0 if $min < 0 && $axis->[0] >= 0.0; $max = 0.0 if $max > 0 && $axis->[1] <= 0.0; } @{$axis} = ( $min, $max ); } ##################################################################### # based upon PGPLOT's pgrnd routine # routine to find the closest "round" number to X, a "round" number # being 1, 2 or 5 times a power of 10. # If X is negative, round_pow(X) = -round_pow(abs(X)). # If X is zero, the value returned is zero. # round_pow( direction, $x ) # where direction is up, down, or both i.e. # $ub = round ( up => $x ); # $lb = round ( down => $x ); our @nice = ( 1, 2, 5, 10 ); our %flip = ( 'up' => 'down', 'down' => 'up' ); sub round_pow { my ( $what, $x ) = @_; croak( "incorrect number of arguments" ) unless 2 == @_; if ( $x != 0.0 ) { my $xx = abs($x); my $xlog = log10($xx); my $ilog = int($xlog); $what = $flip{$what} if $x < 0 ; $ilog-- if ( $xlog <= 0 && ( 'down' eq $what || $xlog != $ilog ) ) || ( $xlog > 0 && 'down' eq $what && $xlog == $ilog ) ; my $pwr = 10 ** $ilog; my $frac = $xx / $pwr; my $i; if ( 'up' eq $what ) { $i = 3; $i = 2 if $frac < $nice[2]; $i = 1 if $frac < $nice[1]; $i = 0 if $frac < $nice[0]; my $t = ( $x < 0 ? -1 : 1 ) * $pwr * $nice[$i]; if(abs($t - $x) < 0.0000001) {$i++} } elsif ( 'down' eq $what ) { $i = 0; $i = 1 if $frac > $nice[1]; $i = 2 if $frac > $nice[2]; $i = 3 if $frac > $nice[3]; } $x = ( $x < 0 ? -1 : 1 ) * $pwr * $nice[$i]; } $x; } ##################################################################### sub setup_multi { my ( $common, $dim, $keys ) = @_; my @arr; if ( 'ARRAY' eq ref $common ) { return $common; } elsif ( 'HASH' eq ref $common ) { @arr[ 0..($dim-1)] = map { $common->{$_->{data}} } @{$keys}; } else { my $value = $common; @arr = ($value) x $dim; } \@arr; } ##################################################################### # normalize_dsets # # transform the user's heterogeneous list of data sets into a regular # list of data sets, each with the form # { Vectors => \@vectors } # where each vector is a hashref with the following keys: # { data => $data, # en => $err_n, # ep => $err_p, # trans => $trans } sub normalize_dsets { my ( $attr, @udsets ) = @_; my @dsets; while ( @udsets ) { my $ds = shift @udsets; my $ref = ref $ds; # peek inside the array to see what's there. we can have the following # [ scalar|piddle, scalar|piddle, ... ] -> a zero dimensional data set # [ \@a, \@b, \@c, \%d, ... ] -> a bunch of data sets # [ \%h, @keys ] -> a hash with its keys # scalar or piddle, turn it into its own data set if ( ! $ref || UNIVERSAL::isa($ds, 'PDL') ) { push @dsets, PDL::Graphics::Limits::DSet->new( $attr->{Min}, $attr->{Max}, { data => PDL::Core::topdl( $ds ) } ); } elsif ( 'ARRAY' eq $ref ) { normalize_array( \@dsets, $attr, $ds ); } else { die( "data set: ", scalar @dsets + 1, "illegal type in data set list: not an arrayref, scalar, or piddle\n" ); } } # ensure data sets have the same dimensions my %dim; $dim{$_->ndim}++ foreach @dsets; # whoops. only one allowed die( "data sets do not all have the same dimensionality\n" ) if keys %dim > 1; ( $attr->{dims} ) = keys %dim; # clean up datasets. my $idset = -1; foreach my $dset ( @dsets ) { $idset++; eval { $dset->validate( $attr ) }; if ( $@ ) { chomp $@; die( "data set $idset: $@\n" ); } } @dsets; } ##################################################################### # array refs in data set lists may be just a plain ol' data set, or # it may contain a bunch of other stuff. here we deal with a single # array ref. we tear it apart and (re)build data sets. sub normalize_array { my ( $dsets, $attr, $aref ) = @_; # if the first element is a hash, it's either a hash based data set # with a bunch of attributes specific to that hash: # [ \%h, @keys ] -> a hash with its keys # in which case the rest of the elements are scalars, or its # all hashes. eval { if ( 'HASH' eq ref $aref->[0] ) { # all hashes? if ( @$aref == grep { 'HASH' eq ref $_ } @$aref ) { # can't do anything unless we've been told which hash keys # we should use, as this format doesn't allow local specification die( "must specify hash keys for hash based data set spec\n" ) unless defined $attr->{KeySpec} && scalar @{$attr->{KeySpec}}; foreach ( @{$aref} ) { push @$dsets, normalize_hash_dset($attr, $_, @{$attr->{Keys}} ); } } # hash + scalars? elsif ( @$aref > 1 && 1 == grep { ref $_ } @$aref ) { push @$dsets, normalize_hash_dset( $attr, @{$aref} ) } # something wrong else { die( "hash based data specification has an unexpected element" ); } } # must be a list of vectors as either scalars, piddles, or array # refs (vectors with attributes) else { # for array based data sets, we have to accumulate vectors as we iterate # through the array. they are stored here my @vecs; for my $vec ( @$aref ) { my $ref = ref $vec; eval { # naked scalar or piddle: data vector with no attributes if ( ! $ref || UNIVERSAL::isa($vec, 'PDL') ) { push @vecs, { data => PDL::Core::topdl( $vec ) }; } # array: data vector with attributes elsif ( 'ARRAY' eq $ref ) { push @vecs, normalize_array_vec( $vec ); } else { die( 'vector ', @vecs+1, ": unexpected data type ($ref) in list of data sets\n" ); } }; if ( $@ ) { chomp $@; die( 'vector ', @vecs+1, ": $@\n" ); } } push @$dsets, PDL::Graphics::Limits::DSet->new( $attr->{Min}, $attr->{Max}, @vecs ) if @vecs; } }; if ( $@ ) { chomp $@; die( 'data set ', @$dsets+1, ": $@\n" ); } } ##################################################################### # parse an array based vector sub normalize_array_vec { my ( $vec ) = @_; # we should have # [ $data, [ $err | $err_n, $err_p ], [ \&func ] ] my @el = @$vec; die( "too few or too many entries in array based data set spec\n" ) if @el < 1 || @el > 4; my %vec; $vec{data} = PDL::Core::topdl( shift @el); # if last value is CODE, it's a trans $vec{trans} = pop @el if 'CODE' eq ref $el[-1]; if ( exists $el[2] ) { # if we have 3 elements and the last isn't undef, it's an error. # it can't be CODE as we'd have stripped it off in the last statement die( "illegal value for trans func: $el[2]\n" ) if defined $el[2]; # we need to turn off trans for this element $vec{trans} = undef; pop @el; } # two values? asymmetric errors if ( @el == 2 ) { $vec{errn} = PDL::Core::topdl($el[0]) if defined $el[0]; $vec{errp} = PDL::Core::topdl($el[1]) if defined $el[1]; } # one value? symmetric errors elsif ( @el == 1 ) { $vec{errn} = PDL::Core::topdl($el[0]) if defined $el[0]; $vec{errp} = $vec{errn} if defined $vec{errn}; } \%vec; } ##################################################################### # this takes a hash and a hash key spec and generates a regularized # data set array of the form # [ { data => $data, ep => ..., en => ..., trans => }, ... ] sub normalize_hash_dset { my ( $attr, $ds, @keys ) = @_; my $KeySpec = $attr->{KeySpec}; my @dset; die( "too many local VecKeys (", scalar @keys, ") and global VecKeys (", scalar @{$KeySpec}, ")\n" ) if @keys && @{$KeySpec} && @{$KeySpec} <= @keys; my @spec; # handle local keys if ( @keys ) { my $nvec = 0; for my $key ( @keys ) { my %spec; # parse the specs for this vector eval { %spec = parse_vecspec( $key ) }; do { chomp $@; die( "vector $nvec: $@" ) } if $@; # now, merge it with the global KeySpecs if ( @{$KeySpec} ) { my $Spec = $KeySpec->[$nvec]; foreach ( keys %{$Spec} ) { # only copy from Spec if not present in spec $spec{$_} = $Spec->{$_} if ! exists $spec{$_}; } } push @spec, \%spec; } continue { $nvec++; } # handle case where local VecKeys are a subst of global VecKeys while ( @{$KeySpec} > @spec ) { push @spec, $KeySpec->[$nvec++]; } } # no local keys; use global KeySpec else { @spec = @{$KeySpec}; } my $nvec = 0; for my $spec ( @spec ) { $nvec++; my %vec; die( "vector $nvec: no data spec?\n" ) unless exists $spec->{data}; for my $el ( qw( data errn errp trans ) ) { if ( exists $spec->{$el} ) { # if not defined, don't bother looking for it in the data set unless ( defined $spec->{$el} ) { # trans is different from the others in that we need to pass # it as undef if $spec->{trans} is undef (as full handling of # trans is done elsewhere. $vec{trans} = undef if 'trans' eq $el; } elsif ( exists $ds->{$spec->{$el}} ) { $vec{$el} = $ds->{$spec->{$el}}; } elsif ( $attr->{KeyCroak} ) { die( "vector $nvec: missing key in data set hash: ", $spec->{$el}, "\n" ) } } } # missing data; certainly a fatal error. die( "vector $nvec: no data for key $spec->{data}\n" ) unless defined $vec{data}; push @dset, \%vec; } PDL::Graphics::Limits::DSet->new( $attr->{Min}, $attr->{Max}, @dset ); } ##################################################################### # parse specifications for a hash based data set. These are the elements # in the VecKeys attribute. See the docs for more details. # Returns a hashref with keys data, en, ep, trans my $colre = qr/[^&<>=]/; # these are the different specs available. my %keyre = ( data => qr/^($colre+)/, errn => qr/<($colre*)/, errp => qr/>($colre*)/, err => qr/=($colre*)/, trans => qr/\&($colre*)/ ); my %vecspeckeys = ( data => 1, err => 1, errn => 1, errp => 1, trans => 1 ); sub parse_vecspec { my ( $ukeys ) = @_; my %k; # do we get a hash? if ( 'HASH' eq ref $ukeys ) { # complain about keys we don't use my @badkeys = grep { ! defined $vecspeckeys{$_} } keys %$ukeys; die( "illegal keys: ", join(' ,', @badkeys), "\n" ) if @badkeys; # copy keys we need do { $k{$_} = $ukeys->{$_} if exists $ukeys->{$_} } foreach keys %vecspeckeys; } # parse the string. else { # make a local copy, as we modify it in place. my $keys = $ukeys; # deal with a "default" spec if ( ! defined $keys ) { $keys = ''; } else { # spaces and commas are there for human use only $keys =~ s/[\s,]//g; } # extract the known specs. my ( $what, $re ); $keys =~ s/$re// and $k{$what} = $1 while( ($what, $re) = each %keyre); # if there's anything left, it's bogus die( "illegal key specification: $ukeys\n" ) unless $keys eq ''; } # check for consistent error bar specs die( "can't specify `=' with `<' or `>'\n" ) if exists $k{err} && ( exists $k{errn} || exists $k{errp} ); # error bars are always specified as positive and negative; turn a symmetric # spec into that $k{errn} = $k{errp} = $k{err} if exists $k{err}; delete $k{err}; # set empty values to undefined ones do { $k{$_} = undef if $k{$_} eq '' } foreach keys %k; %k; } sub parse_vecspecs { my $keys = shift; my @specs; push @specs, { parse_vecspec($_) } foreach @$keys; \@specs; } ##################################################################### # normalize user supplied limits sub parse_limits { my ( $ndim, $spec, $KeySpec ) = @_; $spec = [] unless defined $spec; my @limits; # array containing limits (as arrays or scalars) if ( 'ARRAY' eq ref $spec ) { # no limits; just move on unless ( @$spec ) { } # multi-dimensional data sets elsif ( 'ARRAY' eq ref $spec->[0] ) { my $ilim = 0; for my $vlim ( @$spec ) { $ilim++; die( "Limit spec element $ilim: expected array ref\n" ) if 'ARRAY' ne ref $vlim; die( "Limit spec element $ilim: too many values\n" ) if @$vlim > 2; die( "Limit spec element $vlim: values must be scalars\n" ) if grep { ref $_ } @$vlim; my @lims = @$vlim; $lims[0] = undef unless defined $lims[0]; $lims[1] = undef unless defined $lims[1]; push @limits, \@lims; } } # one-dimensional data sets elsif ( ! ref $spec->[0] ) { die( "unexpected non-scalar element in Limits spec\n" ) if grep { ref $_ } @$spec; my @lims = @$spec; $lims[0] = undef unless defined $lims[0]; $lims[1] = undef unless defined $lims[1]; push @limits, \@lims; } push @limits, [ undef, undef ] while ( @limits != $ndim ); } # hash containing vector names and limits elsif ( 'HASH' eq ref $spec ) { # first ensure that VecKeys has been specified die( "cannot use Limits without VecKeys\n" ) unless @$KeySpec; # make sure that we've got common keys. my %vecs = map { ( $_->{data} => 1) } @$KeySpec; # identify unknown vectors my @badvecs = grep { ! defined $vecs{$_} } keys %$spec; die( 'unknown vector(s): ', join(', ', @badvecs), "\n" ) if @badvecs; # work our way through the KeySpec's, filling in values from # $spec as appropriate. for my $kspec ( @$KeySpec ) { my @lims = ( undef, undef ); if ( exists $spec->{$kspec->{data}} ) { my $lspec = $spec->{$kspec->{data}}; $lims[0] = $lspec->{min} if exists $lspec->{min}; $lims[1] = $lspec->{max} if exists $lspec->{max}; } push @limits, \@lims; } } # say what? else { die( "Limits attribute value must be a hashref or arrayref\n" ); } map { { calc => scalar ( grep { !defined $_ } @{$_} ), range => $_ } } @limits; } ##################################################################### sub limits { my $attr = 'HASH' eq ref $_[-1] ? pop @_ : {}; my @udsets = @_; my %attr = iparse( { Min => -1.8e308, Max => +1.8e308, Bounds => 'minmax', Clean => 'RangeFrac', RangeFrac => 0.05, ZeroFix => 0, VecKeys => [], KeyCroak => 1, Limits => [], Trans => [], }, $attr ); # turn Trans and VecKeys into arrays if necessary; may be scalars for 1D # data sets $attr{$_} = [ $attr{$_} ] foreach grep { defined $attr{$_} && 'ARRAY' ne ref $attr{$_} } qw( VecKeys Trans ); # parse vector key specs $attr{KeySpec} = parse_vecspecs( $attr{VecKeys} ); # normalize data sets to make life easier later. also # counts up the number of dimensions and sets $attr{dims} my @dsets = normalize_dsets( \%attr, @udsets ); # set up the Limits my @limits = parse_limits( $attr{dims}, $attr{Limits}, $attr{KeySpec} ); if ( 'minmax' eq lc $attr{Bounds} ) { for my $dim ( 0..$attr{dims}-1 ) { # only calculate minmax values for those dims which need them. my $limits = $limits[$dim]; foreach ( @dsets ) { # calculate min & max $_->calc_minmax( $dim ) if $limits->{calc}; # make sure we pay attention to user specified limits $_->set_minmax( @{$limits->{range}}, $dim ); } } } elsif ( 'zscale' eq lc $attr{Bounds} ) { croak( "zscale only good for dim = 2\n" ) unless $attr{dims} == 2; foreach my $dset ( @dsets ) { $dset->calc_minmax( 0 ) if $limits[0]{calc}; if ( $limits[1]{calc} ) { my $y = $dset->vector(1)->{data}; # this is a waste, as we don't care about the evaluated # fit values, just the min and max values. since we # get them all anyway, we'll use them. my $mask = PDL::null; set_mask( $mask, $y ); my $fit = fitpoly1d( $y->where($mask)->qsort, 2 ); $dset->set_minmax( $fit->minmax, 1 ); } $dset->set_minmax( @{$limits[$_]{range}}, $_ ) for 0,1; } } else { die( "unknown Bounds type: $attr{Bounds}\n" ); } # derive union of minmax limits from data sets my $minmax = PDL::Core::null; $minmax = append( $minmax, $_->get_minmax ) foreach @dsets; # get overall minmax limits $minmax = cat(($minmax->minmaximum)[0,1])->transpose; my @minmax = map{ [ $minmax->slice(":,$_")->list ] } 0..$attr{dims}-1; if ( 'rangefrac' eq lc $attr{Clean} ) { my $RangeFrac = setup_multi( $attr{RangeFrac}, $attr{dims}, $attr{KeySpec} ); my $ZeroFix = setup_multi( $attr{ZeroFix}, $attr{dims}, $attr{KeySpec} ); range_frac( $minmax[$_], $RangeFrac->[$_], $ZeroFix->[$_] ) for 0..$attr{dims}-1; } elsif ( 'roundpow' eq lc $attr{Clean} ) { $_ = [ round_pow( down => $_->[0] ), round_pow( up => $_->[1] ) ] foreach @minmax; } elsif ( 'none' eq lc $attr{Clean} ) { # do nothing } else { die( "unknown Clean type: $attr{Clean}\n" ); } if ( wantarray ) { return map { ( @{$_} ) } @minmax; } else { my @key; if ( @{$attr{KeySpec}} ) { @key = map { $_->{data} } @{$attr{KeySpec}}; } else { @key = map { 'q' . $_ } ( 1 .. $attr{dims} ); } return { map { ( $key[$_] => { min => $minmax[$_][0], max => $minmax[$_][1] } ) } 0.. ( @minmax - 1 ) }; } } 1; __END__ =pod =head1 NAME PDL::Graphics::Limits - derive limits for display purposes =head1 DESCRIPTION Functions to derive limits for data for display purposes =head1 SYNOPSIS use PDL::Graphics::Limits; =head1 FUNCTIONS =head2 limits =for ref B<limits> derives global limits for one or more multi-dimensional sets of data for display purposes. It obtains minimum and maximum limits for each dimension based upon one of several algorithms. =for usage @limits = limits( @datasets ); @limits = limits( @datasets, \%attr ); $limits = limits( @datasets ); $limits = limits( @datasets, \%attr ); =head3 Data Sets A data set is represented as a set of one dimensional vectors, one per dimension. All data sets must have the same dimensions. Multi-dimensional data sets are packaged as arrays or hashs; one dimensional data sets need not be. The different representations may be mixed, as long as the dimensions are presented in the same order. Vectors may be either scalars or piddles. =over 8 =item One dimensional data sets One dimensional data sets may be passed directly, with no additional packaging: limits( $scalar, $piddle ); =item Data sets as arrays If the data sets are represented by arrays, each vectors in each array must have the same order: @ds1 = ( $x1_pdl, $y1_pdl ); @ds2 = ( $x2_pdl, $y2_pdl ); They are passed by reference: limits( \@ds1, \@ds2 ); =item Data sets as hashes Hashes are passed by reference as well, but I<must> be further embedded in arrays (also passed by reference), in order that the last one is not confused with the optional trailing attribute hash. For example: limits( [ \%ds4, \%ds5 ], \%attr ); If each hash uses the same keys to identify the data, the keys should be passed as an ordered array via the C<VecKeys> attribute: limits( [ \%h1, \%h2 ], { VecKeys => [ 'x', 'y' ] } ); If the hashes use different keys, each hash must be accompanied by an ordered listing of the keys, embedded in their own anonymous array: [ \%h1 => ( 'x', 'y' ) ], [ \%h2 => ( 'u', 'v' ) ] Keys which are not explicitly identified are ignored. =back =head3 Errors Error bars must be taken into account when determining limits; care is especially needed if the data are to be transformed before plotting (for logarithmic plots, for example). Errors may be symmetric (a single value indicates the negative and positive going errors for a data point) or asymmetric (two values are required to specify the errors). If the data set is specified as an array of vectors, vectors with errors should be embedded in an array. For symmetric errors, the error is given as a single vector (piddle or scalar); for asymmetric errors, there should be two values (one of which may be C<undef> to indicate a one-sided error bar): @ds1 = ( $x, # no errors [ $y, $yerr ], # symmetric errors [ $z, $zn, $zp ], # asymmetric errors [ $u, undef, $up ], # one-sided error bar [ $v, $vn, undef ], # one-sided error bar ); If the data set is specified as a hash of vectors, the names of the error bar keys are appended to the names of the data keys in the C<VecKeys> designations. The error bar key names are always prefixed with a character indicating what kind of error they represent: < negative going errors > positive going errors = symmetric errors (Column names may be separated by commas or white space.) For example, %ds1 = ( x => $x, xerr => $xerr, y => $y, yerr => $yerr ); limits( [ \%ds1 ], { VecKeys => [ 'x =xerr', 'y =yerr' ] } ); To specify asymmetric errors, specify both the negative and positive going errors: %ds1 = ( x => $x, xnerr => $xn, xperr => $xp, y => $y ); limits( [ \%ds1 ], { VecKeys => [ 'x <xnerr >xperr', 'y' ] } ); For one-sided error bars, specify a column just for the side to be plotted: %ds1 = ( x => $x, xnerr => $xn, y => $y, yperr => $yp ); limits( [ \%ds1 ], { VecKeys => [ 'x <xnerr', 'y >yperr' ] } ); Data in hashes with different keys follow the same paradigm: [ \%h1 => ( 'x =xerr', 'y =yerr' ) ], [ \%h2 => ( 'u =uerr', 'v =verr' ) ] In this case, the column names specific to a single data set override those specified via the C<VecKeys> option. limits( [ \%h1 => 'x =xerr' ], { VecKeys => [ 'x <xn >xp' ] } ) In the case of a multi-dimensional data set, one must specify all of the keys: limits( [ \%h1 => ( 'x =xerr', 'y =yerr' ) ], { VecKeys => [ 'x <xn >xp', 'y <yp >yp' ] } ) One can override only parts of the specifications: limits( [ \%h1 => ( '=xerr', '=yerr' ) ], { VecKeys => [ 'x <xn >xp', 'y <yp >yp' ] } ) Use C<undef> as a placeholder for those keys for which nothing need by overridden: limits( [ \%h1 => undef, 'y =yerr' ], { VecKeys => [ 'x <xn >xp', 'y <yp >yp' ] } ) =head3 Data Transformation Normally the data passed to B<limits> should be in their final, transformed, form. For example, if the data will be displayed on a logarithmic scale, the logarithm of the data should be passed to B<limits>. However, if error bars are also to be displayed, the I<untransformed> data must be passed, as log(data) + log(error) != log(data + error) Since the ranges must be calculated for the transformed values, B<range> must be given the transformation function. If all of the data sets will undergo the same transformation, this may be done with the B<Trans> attribute, which is given a list of subroutine references, one for each element of a data set. An C<undef> value may be used to indicate no transformation is to be performed. For example, @ds1 = ( $x, $y ); # take log of $x limits( \@ds1, { trans => [ \&log10 ] } ); # take log of $y limits( \@ds1, { trans => [ undef, \&log10 ] } ); If each data set has a different transformation, things are a bit more complicated. If the data sets are specified as arrays of vectors, vectors with transformations should be embedded in an array, with the I<last> element the subroutine reference: @ds1 = ( [ $x, \&log10 ], $y ); With error bars, this looks like this: @ds1 = ( [ $x, $xerr, \&log10 ], $y ); @ds1 = ( [ $x, $xn, $xp, \&log10 ], $y ); If the C<Trans> attribute is used in conjunction with individual data set transformations, the latter will override it. To explicitly indicate that a specific data set element has no transformation (normally only needed if C<Trans> is used to specify a default) set the transformation subroutine reference to C<undef>. In this case, the entire quad of data element, negative error, positive error, and transformation subroutine must be specified to avoid confusion: [ $x, $xn, $xp, undef ] Note that $xn and $xp may be undef. For symmetric errors, simply set both C<$xn> and C<$xp> to the same value. For data sets passed as hashes, the subroutine reference is an element in the hashes; the name of the corresponding key is added to the list of keys, preceded by the C<&> character: %ds1 = ( x => $x, xerr => $xerr, xtrans => \&log10, y => $y, yerr => $yerr ); limits( [ \%ds1, \%ds2 ], { VecKeys => [ 'x =xerr &xtrans', 'y =yerr' ] }); limits( [ \%ds1 => 'x =xerr &xtrans', 'y =yerr' ] ); If the C<Trans> attribute is specified, and a key name is also specified via the C<VecKeys> attribute or individually for a data set element, the latter will take precedence. For example, $ds1{trans1} = \&log10; $ds1{trans2} = \&sqrt; # resolves to exp limits( [ \%ds1 ], { Trans => [ \&exp ] }); # resolves to sqrt limits( [ \%ds1 ], { Trans => [ \&exp ], VecKeys => [ 'x =xerr &trans2' ] }); # resolves to log10 limits( [ \%ds1 => '&trans1' ], { Trans => [ \&exp ], VecKeys => [ 'x =xerr &trans2' ] }); To indicate that a particular vector should have no transformation, use a blank key: limits( [ \%ds1 => ( 'x =xerr &', 'y =yerr' ) ], [\%ds2], { Trans => [ \&log10 ] } ); or set the hash element to C<undef>: $ds1{xtrans} = undef; =head3 Range Algorithms Sometimes all you want is to find the minimum and maximum values. However, for display purposes, it's often nice to have "clean" range bounds. To that end, B<limits> produces a range in two steps. First it determines the bounds, then it cleans them up. To specify the bounding algorithm, set the value of the C<Bounds> key in the C<%attr> hash to one of the following values: =over 8 =item MinMax This indicates the raw minima and maxima should be used. This is the default. =item Zscale This is valid for two dimensional data only. The C<Y> values are sorted, then fit to a line. The minimum and maximum values of the evaluated line are used for the C<Y> bounds; the raw minimum and maximum values of the C<X> data are used for the C<X> bounds. This method is good in situations where there are "spurious" spikes in the C<Y> data which would generate too large a dynamic range in the bounds. (Note that the C<Zscale> algorithm is found in IRAF and DS9; its true origin is unknown to the author). =back To specify the cleaning algorithm, set the value of the C<Clean> key in the C<%attr> hash to one of the following values: =over 8 =item None Perform no cleaning of the bounds. =item RangeFrac This is based upon the C<PGPLOT> B<pgrnge> function. It symmetrically expands the bounds (determined above) by a fractional amount: $expand = $frac * ( $axis->{max} - $axis->{min} ); $min = $axis->{min} - $expand; $max = $axis->{max} + $expand; The fraction may be specified in the C<%attr> hash with the C<RangeFrac> key. It defaults to C<0.05>. Because this is a symmetric expansion, a limit of C<0.0> may be transformed into a negative number, which may be inappropriate. If the C<ZeroFix> key is set to a non-zero value in the C<%attr> hash, the cleaned boundary is set to C<0.0> if it is on the other side of C<0.0> from the above determined bounds. For example, If the minimum boundary value is C<0.1>, and the cleaned boundary value is C<-0.1>, the cleaned value will be set to C<0.0>. Similarly, if the maximum value is C<-0.1> and the cleaned value is C<0.1>, it will be set to C<0.0>. This is the default clean algorithm. =item RoundPow This is based upon the C<PGPLOT> B<pgrnd> routine. It determines a "nice" value, where "nice" is the closest round number to the boundary value, where a round number is 1, 2, or 5 times a power of 10. =back =head3 User Specified Limits To fully or partially override the automatically determined limits, use the B<Limits> attribute. These values are used as input to the range algorithms. The B<Limits> attribute value may be either an array of arrayrefs, or a hash. =over =item Arrays The B<Limits> value may be a reference to an array of arrayrefs, one per dimension, which contain the requested limits. The dimensions should be ordered in the same way as the datasets. Each arrayref should contain two ordered values, the minimum and maximum limits for that dimension. The limits may have the undefined value if that limit is to be automatically determined. The limits should be transformed (or not) in the same fashion as the data. For example, to specify that the second dimension's maximum limit should be fixed at a specified value: Limits => [ [ undef, undef ], [ undef, $max ] ] Note that placeholder values are required for leading dimensions which are to be handled automatically. For convenience, if limits for a dimension are to be fully automatically determined, the placeholder arrayref may be empty. Also, trailing undefined limits may be omitted. The above example may be rewritten as: Limits => [ [], [ undef, $max ] ] If the minimum value was specified instead of the maximum, the following would be acceptable: Limits => [ [], [ $min ] ] If the data has but a single dimension, nested arrayrefs are not required: Limits => [ $min, $max ] =item Hashes Th B<Limits> attribute value may be a hash; this can only be used in conjunction with the B<VecKeys> attribute. If the data sets are represented by hashes which do not have common keys, then the user defined limits should be specified with arrays. The keys in the B<Limits> hash should be the names of the data vectors in the B<VecKeys>. Their values should be hashes with keys C<min> and C<max>, representing the minimum and maximum limits. Limits which have the value C<undef> or which are not specified will be determined from the data. For example, Limits => { x => { min => 30 }, y => { max => 22 } } =back =head3 Return Values When called in a list context, it returns the minimum and maximum bounds for each axis: @limits = ( $min_1, $max_1, $min_2, $max_2, ... ); which makes life easier when using the B<env> method: $window->env( @limits ); When called in a scalar context, it returns a hashref with the keys axis1, ... axisN where C<axisN> is the name of the Nth axis. If axis names have not been specified via the C<VecKeys> element of C<%attr>, names are concocted as C<q1>, C<q2>, etc. The values are hashes with keys C<min> and C<max>. For example: { q1 => { min => 1, max => 2}, q2 => { min => -33, max => 33 } } =head3 Miscellaneous Normally B<limits> complains if hash data sets don't contain specific keys for error bars or transformation functions. If, however, you'd like to specify default values using the C<%attr> argument, but there are data sets which don't have the data and you'd rather not have to explicitly indicate that, set the C<KeyCroak> attribute to zero. For example, limits( [ { x => $x }, { x => $x1, xerr => $xerr } ], { VecKeys => [ 'x =xerr' ] } ); will generate an error because the first data set does not have an C<xerr> key. Resetting C<KeyCroak> will fix this: limits( [ { x => $x }, { x => $x1, xerr => $xerr } ], { VecKeys => [ 'x =xerr' ], KeyCroak => 0 } ); =head1 AUTHOR Diab Jerius, E<lt>djerius@cpan.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright (C) 2004 by the Smithsonian Astrophysical Observatory This software is released under the GNU General Public License. You may find a copy at L<http://www.fsf.org/copyleft/gpl.html>. =cut ����������������������PDL-2.018/Graphics/Limits/Makefile.PL���������������������������������������������������������������0000644�0601750�0601001�00000000373�12562522364�015361� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Graphics::Limits', 'VERSION_FROM' => '../../Basic/Core/Version.pm', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/�����������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�012567� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/LUT.pm�����������������������������������������������������������������������0000644�0601750�0601001�00000013461�12562522364�013616� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� =head1 NAME PDL::Graphics::LUT - provides access to a number of look-up tables =head1 SYNOPSIS use PDL::Graphics::PGPLOT; use PDL::Graphics::LUT; # what tables are available my @tables = lut_names(); # get the reversed colour table 'smooth', # with the gamma intensity ramp my ( $l, $r, $g, $b ) = lut_data( 'smooth', 1, 'gamma' ); # use the table idl5 in ctab ctab( lut_data('idl5') ); =head1 DESCRIPTION PDL::Graphics::LUT contains a number of colour look-up tables (in rgb format) and intensity ramps, and provides routines to access this data. The format of the data is suitable for use by L<ctab|PDL::Graphics::PGPLOT::Window/ctab>. Unlike the initial release of the package, the data tables are now stored within the PDL distribution as FITS files (see L<$tabledir|/$tabledir> and L<$rampdir|/$rampdir>), rather than in the module itself. Changes to these directories will be picked up on the next call to one of the package functions. =head1 FUNCTIONS =head2 lut_names() =for ref Return, as a list, the names of the available colour tables. =for usage @tables = lut_names(); =head2 lut_ramps() =for ref Return, as a list, the names of the available intensity ramps. =for usage @ramps = lut_ramps(); =head2 lut_data() =for ref Load in the requested colour table and intensity ramp. =for usage ( $l, $r, $g, $b ) = lut_data( $table, [ $reverse, [ $ramp ] ] ); Returns the levels and r, g, b components of the colour table C<$table>. If C<$reverse> is 1 (defaults to B<0> if not supplied), then the r, g, and b components are reversed before being returned. If not supplied, C<$ramp> defaults to B<"ramp"> (this is a linear intensity ramp). The returned values are piddles containing values in the range 0 to 1 inclusive, and are floats. =head1 VARIABLES =head2 $tabledir =for ref The directory in which the colour tables (in rgb format) are stored. =head2 $rampdir =for ref The directory in which the intensity ramps are stored. =head2 $suffix =for ref The suffix for the data files in C<$tabledir> and C<$rampdir>. =head1 FURTHER INFORMATION The colour tables were taken from the STARLINK GAIA package, and are provided under the GNU copyleft. See http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/ for more details. =head1 AUTHOR Doug Burke (djburke@cpan.org), with thanks to Peter Draper/STARLINK for providing the colour-table data, and Christian Soeller and Karl Glazebrook for their help. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Graphics::LUT; # Just a plain function exporting package use Exporter; # attempt to avoid Unix-specific file/directory names use File::Spec; use File::Basename; use autodie; use PDL::Core qw/:Func :Internal/; # Grab the Core names use PDL::Basic; use PDL::Types; use PDL::Slices; use PDL::IO::Misc; use PDL::IO::FITS; # should be careful that $suffix is a valid length on non-Unix systems $suffix = ".fits"; use vars qw( $tabledir $rampdir $suffix ); # should really use EXPORT_OK @EXPORT = qw( lut_names lut_ramps lut_data ); @EXPORT_OK = qw( $tabledir $rampdir $suffix ); @ISA = qw( Exporter ); use strict; ############################################################################ # can we find the data? BEGIN { my $d = File::Spec->catdir( "PDL", "Graphics", "LUT" ); my $lutdir = undef; foreach my $path ( @INC ) { my $check = File::Spec->catdir( $path, $d ); if ( -d $check ) { $lutdir = $check; last; } } barf "Unable to find directory ${d} within the perl libraries.\n" unless defined $lutdir; $tabledir = File::Spec->catdir( $lutdir, "tables" ); $rampdir = File::Spec->catdir( $lutdir, "ramps" ); barf "Unable to find directory ${tabledir} within the perl libraries.\n" unless -d $tabledir; barf "Unable to find directory ${rampdir} within the perl libraries.\n" unless -d $rampdir; } ############################################################################ sub _lsdir_basename { my ($dir, $suffix) = @_; opendir my $fh, $dir; map basename($_, $suffix), grep /\Q$suffix\E\z/, readdir $fh; } # exported functions # Return the list of available tables sub lut_names () { _lsdir_basename $tabledir, $suffix } # Return the list of available ramps sub lut_ramps () { _lsdir_basename $rampdir, $suffix } # Return the requested colour table sub lut_data ($;$$) { my $table = shift; my $reverse = $#_ != -1 ? shift : 0; my $ramp = $#_ != -1 ? shift : "ramp"; my $lfile = File::Spec->catfile( $tabledir, "${table}${suffix}" ); my $rfile = File::Spec->catfile( $rampdir, "${ramp}${suffix}" ); print "Reading colour table and intensity ramp from:\n $lfile\n $rfile\n" if $PDL::verbose; # unknown table? unless ( -e $lfile ) { my @names = lut_names(); barf <<"EOD"; Unknown colour table $table Available tables: @names EOD } # unknown ramp? unless ( -e $rfile ) { my @names = lut_ramps(); barf <<"EOD"; Unknown intensity ramp $ramp Available ramps: @names EOD } # read in rgb data my $rgb = rfits $lfile; $rgb = float($rgb) if $rgb->get_datatype != $PDL_F; my ( @ldims ) = $rgb->dims; barf "LUT file $lfile is not the correct format (ie n by 3)\n" unless $#ldims == 1 and $ldims[1] == 3; # read in intensity data my $l = rfits $rfile; $l = float($l) if $l->get_datatype != $PDL_F; barf "Ramp file $rfile does not match the colour table size.\n" unless $l->nelem == $ldims[0]; my $s = $reverse ? "-1:0" : ""; return ( $l, $rgb->slice("${s},(0)"), $rgb->slice("${s},(1)"), $rgb->slice("${s},(2)") ); } # sub: lut_data() # Exit with OK status 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/Makefile.PL������������������������������������������������������������������0000644�0601750�0601001�00000000431�12562522364�014557� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Graphics::LUT', 'VERSION_FROM' => '../../Basic/Core/Version.pm', 'DIR' => [ 'tables', 'ramps' ], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/�����������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013711� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/equa.fits��������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�015547� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'equa ' / Name of ramp HISTORY intensity ramp converted from: equa.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:16 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END =€ƒ> ‹D>dĺ >šš€>¸¸(>ŇŇ5>ěí‘?Z? ‹Ź?“Š?š€?  ?%Ľš?)Šü?.Ž}?1ąŮ?4´?7ˇé?:ş?<źj?>žŕ?AÁ”?CÄ ?DÄđ?FĆ˝?GǤ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?[ŰĄ?\Ý/?]Ţ?]Ţ?^Ţü?_ßă?_ßă?`ŕĘ?`ŕĘ?aáą?aáą?bâ—?bâ—?cä&?cä&?dĺ ?dĺ ?eĺó?eĺó?fćÚ?fćÚ?gçŔ?gçŔ?hč§?hč§?ię6?ię6?jë?jë?kě?kě?lěę?lěę?míĐ?míĐ?nîˇ?nîˇ?oďž?oďž?oďž?pń,?pń,?qň?qň?qň?rňú?rňú?sóŕ?sóŕ?sóŕ?tôÇ?tôÇ?tôÇ?uőŽ?uőŽ?uőŽ?v÷<?v÷<?v÷<?v÷<?wř#?wř#?wř#?wř#?xů ?xů ?xů ?xů ?xů ?xů ?yůđ?yůđ?yůđ?yůđ?yůđ?yůđ?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/expo.fits��������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�015567� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'expo ' / Name of ramp HISTORY intensity ramp converted from: expo.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ;–Ó;áł<ť™<<žb<c<„ľÝ<—ö+<ŤKs<žľł<Ňó<ĺ´$<ů]O=š=lĘ=`Ô=$TŢ=.]á=8fä=Bzc=L˘Ű=VËS=`ţH=k;¸=uŽ"=ŕ‹=…¸=ŠRi=—=”ÎÄ=š0=ŸZŮ=¤Ž�=Ş&=ŻYŠ=´ˇ,=şK=ż‡j=Äú=Ęl =Ďé¸=ŐfĎ=Úîc=ŕu÷=ć=ëŸV=ń;â=öÝ­=ü„ś>~>ńA>ĚŁ> ­C> ă>sÁ>\>>GZ>2v>%p>j>!>$Ů>'°>*Ĺ>-y>0 Ě>3ž>6 ď>9.><@Ž>?U›>BmH>E‡”>H§>Kƨ>Nëp>R×>U<Ţ>Xl">[ž>^҉>b Ť>eCl>h‚k>kÄ >oF>rO">u›=>xé÷>|;O>G>t?>ƒ")>„Ňł>†ƒ<>ˆ6e>‰ęÝ>‹Ąő>Z\>>Ď>’Œ˝>”K˛>– E>—Đ)>™”[>›YŢ>!˙>žëp> ˇ€>˘„ŕ>¤S>Ś$Ý>§÷{>ŠĚ¸>ŤŁD>­{ >ŻU›>ą1f>łĐ>´ď‰>śŃá>¸ľ‰>şš€>ź‚>žjý>ŔV‚>ÂCW>Ä2Ę>Ć#Ž>Čđ>Ę ˘>Ěó>Íű”>ĎöÓ>Ńób>Óň‘>Őô^>×ö+>Ůűç>Üó>Ţ N>ŕH>â#â>ä2Ę>ćDR>čW*>ęl >섶>îž>đş>ň×s>ô÷f>÷ř>ů=Ů>űdZ>ýz>˙ˇé?�ň|? R?"Ń?<Ÿ?Wź?s‚?—?Žű? Î? îc? ? 3 ?VŹ?{ž?Ąŕ?Éq?ńŞ?Ú?F˛?r2?ŸŠ?ÍČ?ýß?.?`Ş?“`?Č ?ýa?!4?"l ?#Ľă?$ßÎ?&°?'Xâ?(–ź?)֌?+?,XÍ?-œ?.ŕô?0&Ť?1mą?2ś?3˙Ź?5JĄ?6–ć?7äz?93]?:‚č?;Ôk?='=?>{_??ĐĐ?A'‘?B€I?CŮŠ?E4Y?FX?GîN?ILě?J­‚?Lg?Mr›?N×?P<ó?Q¤?S 0?Tvó?UâŹ?WOľ?Xž?Z-ś?[ŸV?]E?^†ƒ?_ü?arď?bëÄ?deé?eá]?g^Č?h݃?j]?kŢč?mb9?nćÚ?plĘ?qô˛?s}é?up?v”î?x"ź?y˛?{C–?|Őú?~jU?śš?€��?€�� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/gamma.fits�������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�015676� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'gamma ' / Name of ramp HISTORY intensity ramp converted from: gamma.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END =çç> °É>Ü>.Šr>=uâ>KÇ>W¤č>cc˛>nmœ>xßz>hs>†'|>Šłh>>“JË>—^ >›Oa>Ÿ"}>˘Ú>Śwp>Šý7>­lľ>°Ĺë>´>ˇBš>şf>˝yŃ>Ŕ}Ô>Ăr>ĆZ›>É4­>Ěó>ÎĹm>Ń|>Ô(N>ÖËS>Ůb>Űđ™>Ţuy>ŕň|>ăfQ>ĺŇJ>č5>ę‘S>ěç>ď4×>ń|>óť„>őőŽ>ř)J>úVX>ü~(>ţ ş?�^_?iÂ?s.?yS?}€?~g?}ţ?zö?uO? mą? d? XŽ? Jb? :ç?(Ě?b?��?č§?Ď˙?´ˇ?˜Č?z:?[?9.?ą?ň=?ËŃ?¤ž?{ł?QY?%Ż?řś?Ęm?šÔ?iě? 7 ?!†?!ÎŻ?"™1?#ať?$)ž?$đ0?%ľt?&yh?'<´?'ţ°?(Ŕ?)€ ?*>Ŕ?*üÎ?+šŒ?,uŁ?-0j?-ę‰?.ŁY?/[?0Z?0É2?1~?22ô?2ć†?3™p?4K ?4űü?5ŹG?6[ę?7 ĺ?7¸‘?8e•?9ń?9˝Ľ?:h ?;o?;ť„?<d™?= _?=ł}?>Yó?>˙Á??¤č?@If?@ě–?AĹ?B2M?BÔ,?Cud?Dô?DľÝ?EU?Eóś?F‘§?G.ń?GĚ:?Hh4?I.?IŸ€?J9‚?Jӄ?Km‡?L:?LžE?M6P?MÍł?Ndo?Núƒ?Oď?P%[?Pş?QN<?Qáą?Ru%?Sň?Sš?T+•?T˝?UMč?UŢ?VnD?Vý"?WŒ�?Xß?XŠ?Y6¤?YË?ZPr?ZÜą?[hI?[óŕ?\~Đ?] Ŕ?]“`?^¨?^Ś ?_/˜?_¸‘?`@:?`Ȋ?aO‹?a֌?b]?bă??ci˜?cî˘?dsŹ?dřś?e}?f�Ň?f„Œ?gž?gŠą?h ?h†?iI?i“ ?j'?j•B?kľ?k•?lô?l•?m<?m“`?nÜ?nX?o,?o‹Y?p…?p…˛?q6?q~ť?qú˜?rvu?rňR?slß?sč?tb˘?t܇?uW?uĐS?vI?vÂÎ?w< ?w´˘?x,‘?x¤?ym?y“´?z ú?z™?zř8?{nÖ?{äÍ?|ZÄ?|Đ?}Ec?}ş˛?~/Z?~¤??Œ�?€��?€��?€�� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/jigsaw.fits������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�016100� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'jigsaw ' / Name of ramp HISTORY intensity ramp converted from: jigsaw.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����<€ˆQ=�}Ô=@Áý=€ƒ= Ÿč=ŔÁý=ŕŢÓ>�€s>‘}> Ÿč>0°ň>@Áý>PĐh>`ár>pďÝ>€€s>ˆˆř>.>˜˜ł> Ą8>ŞŞ;>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ŇŇ5>ÚÚş>âă?>ęęt>ňňú>úű?Z?…? ‰7? z?‘ź?•W?™š?Ü?!Ąw?%Ľš?*Şă?.Ž}?2˛Ŕ?6ˇ?:ş?>žŕ?BÂz?FĆ˝?JĘ˙?NΚ?RŇÝ?V×?ZÚş?^Ţü?bâ—?fćÚ?jë?nîˇ?rňú?v÷<?zú×?~˙����<€ˆQ=�}Ô=@Áý=€ƒ= Ÿč=ŔÁý=ŕŢÓ>�€s>‘}> Ÿč>0°ň>@Áý>PĐh>`ár>pďÝ>€€s>ˆˆř>.>˜˜ł> Ą8>ŞŞ;>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ŇŇ5>ÚÚş>âă?>ęęt>ňňú>úű?Z?…? ‰7? z?‘ź?•W?™š?Ü?!Ąw?%Ľš?*Şă?.Ž}?2˛Ŕ?6ˇ?:ş?>žŕ?BÂz?FĆ˝?JĘ˙?NΚ?RŇÝ?V×?ZÚş?^Ţü?bâ—?fćÚ?jë?nîˇ?rňú?v÷<?zú×?~˙����<€ˆQ=�}Ô=@Áý=€ƒ= Ÿč=ŔÁý=ŕŢÓ>�€s>‘}> Ÿč>0°ň>@Áý>PĐh>`ár>pďÝ>€€s>ˆˆř>.>˜˜ł> Ą8>ŞŞ;>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ŇŇ5>ÚÚş>âă?>ęęt>ňňú>úű?Z?…? ‰7? z?‘ź?•W?™š?Ü?!Ąw?%Ľš?*Şă?.Ž}?2˛Ŕ?6ˇ?:ş?>žŕ?BÂz?FĆ˝?JĘ˙?NΚ?RŇÝ?V×?ZÚş?^Ţü?bâ—?fćÚ?jë?nîˇ?rňú?v÷<?zú×?~˙����<€ˆQ=�}Ô=@Áý=€ƒ= Ÿč=ŔÁý=ŕŢÓ>�€s>‘}> Ÿč>0°ň>@Áý>PĐh>`ár>pďÝ>€€s>ˆˆř>.>˜˜ł> Ą8>ŞŞ;>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ŇŇ5>ÚÚş>âă?>ęęt>ňňú>úű?Z?…? ‰7? z?‘ź?•W?™š?Ü?!Ąw?%Ľš?*Şă?.Ž}?2˛Ŕ?6ˇ?:ş?>žŕ?BÂz?FĆ˝?JĘ˙?NΚ?RŇÝ?V×?ZÚş?^Ţü?bâ—?fćÚ?jë?nîˇ?rňú?v÷<?zú×?~˙ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/lasritt.fits�����������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�016276� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'lasritt ' / Name of ramp HISTORY intensity ramp converted from: lasritt.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END =pí>=řůą><ťĂ>|ýL>žž>žžŕ>ŢŢU>ţ˙?G?ŸŠ?/Żd??żĆ?Oρ?_ßă?oďž?€��=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=řůą=řůą=řůą=řůą=řůą=řůą=řůą=řůą><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ>|ýL>|ýL>|ýL>|ýL>|ýL>|ýL>|ýL>|ýL>žž>žž>žž>žž>žž>žž>žž>žž>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙?G?G?G?G?G?G?G?G?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?/Żd?/Żd?/Żd?/Żd?/Żd?/Żd?/Żd?/Żd??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?_ßă?_ßă?_ßă?_ßă?_ßă?_ßă?_ßă?_ßă?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?€��?€��?€��?€��?€��?€��?€��?€��=pí>=pí>=pí>=pí>=pí>=pí>=pí>=řůą=řůą=řůą=řůą=řůą=řůą=řůą><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ>|ýL>|ýL>|ýL>|ýL>|ýL>|ýL>|ýL>žž>žž>žž>žž>žž>žž>žž>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ŢŢU>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙?G?G?G?G?G?G?G?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?/Żd?/Żd?/Żd?/Żd?/Żd?/Żd?/Żd??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?_ßă?_ßă?_ßă?_ßă?_ßă?_ßă?_ßă?oďž?oďž?oďž?oďž?oďž?oďž?oďž?€��?€��?€��?€��?€��?€��?€�� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/log.fits���������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�015375� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'log ' / Name of ramp HISTORY intensity ramp converted from: log.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����< Ľ'=`ŢÓ=°ŽS=ŕŢÓ> ‹D> Ÿč>8¸(>LĚÍ>\Ý×>pďÝ>€€s>†‡+>.>––ć>œœN>˘Ł>ŞŞ;>ŽŻ%>´´>¸¸(>žžŕ>ÄÄH>ČÉ2>ĚĚÍ>ŇŇ5>Ö×>Ü܇>ŢŢU>âă?>ććÚ>ęęt>îď_>đń,>öö”>řřb>üýL?�€s?Z?‚A?„ś?…?ˆQ? ‰7? ŠĆ? Œ“? z?Ža?G?Ö?’Ł?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?'§‡?(¨m?)Šü?*Şă?+ŤÉ?-­—?-­—?.Ž}?/Żd?0°ň?0°ň?1ąŮ?2˛Ŕ?3ł§?3ł§?4´?5ľt?6ˇ?6ˇ?7ˇé?8¸Đ?8¸Đ?:ş?;ť„?;ť„?<źj?=˝ů?=˝ů?>žŕ?>žŕ??żĆ?@Ŕ­?@Ŕ­?AÁ”?BÂz?BÂz?CÄ ?CÄ ?DÄđ?DÄđ?EĹÖ?GǤ?GǤ?HȊ?HȊ?IĘ?IĘ?JĘ˙?JĘ˙?KËć?KËć?LĚÍ?LĚÍ?MÍł?MÍł?NΚ?NΚ?Oρ?Oρ?PŃ?PŃ?QŃö?QŃö?SÓĂ?SÓĂ?TÔŞ?TÔŞ?UՑ?UՑ?V×?V×?V×?WŘ?WŘ?XŘí?XŘí?YŮÓ?YŮÓ?ZÚş?ZÚş?ZÚş?[ŰĄ?[ŰĄ?\Ý/?\Ý/?\Ý/?]Ţ?]Ţ?^Ţü?^Ţü?^Ţü?`ŕĘ?`ŕĘ?aáą?aáą?aáą?bâ—?bâ—?cä&?cä&?cä&?dĺ ?dĺ ?dĺ ?eĺó?eĺó?eĺó?fćÚ?fćÚ?gçŔ?gçŔ?gçŔ?hč§?hč§?hč§?ię6?ię6?ię6?jë?jë?jë?kě?kě?kě?míĐ?míĐ?míĐ?nîˇ?nîˇ?nîˇ?oďž?oďž?oďž?pń,?pń,?pń,?pń,?qň?qň?qň?rňú?rňú?rňú?sóŕ?sóŕ?sóŕ?tôÇ?tôÇ?tôÇ?tôÇ?uőŽ?uőŽ?uőŽ?v÷<?v÷<?v÷<?v÷<?wř#?wř#?wř#?xů ?xů ?xů ?xů ?zú×?zú×?zú×?zú×?{ű˝?{ű˝?{ű˝?|ýL?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?€��?€��?€�� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/Makefile.PL������������������������������������������������������������0000644�0601750�0601001�00000000652�12562522364�015706� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # files ending in .fits will end up in # PDL/Graphics/LUT/ramps/ use ExtUtils::MakeMaker; my @tables = glob( "*.fits" ); WriteMakefile( 'NAME' => 'PDL::Graphics::LUT::ramps::DATA', 'VERSION_FROM' => '../../../Basic/Core/Version.pm', 'PM' => { (map {($_,'$(INST_LIBDIR)/'.$_)} @tables) }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); ��������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/neg.fits���������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�015365� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'neg ' / Name of ramp HISTORY intensity ramp converted from: neg.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ?€��?~˙?}ţ3?|ýL?{ű˝?zú×?yůđ?xů ?wř#?v÷<?uőŽ?tôÇ?sóŕ?rňú?qň?pń,?oďž?nîˇ?míĐ?lěę?kě?jë?ię6?hč§?gçŔ?fćÚ?eĺó?dĺ ?cä&?bâ—?aáą?`ŕĘ?_ßă?^Ţü?]Ţ?\Ý/?[ŰĄ?ZÚş?YŮÓ?XŘí?WŘ?V×?UՑ?TÔŞ?SÓĂ?RŇÝ?QŃö?PŃ?Oρ?NΚ?MÍł?LĚÍ?KËć?JĘ˙?IĘ?HȊ?GǤ?FĆ˝?EĹÖ?DÄđ?CÄ ?BÂz?AÁ”?@Ŕ­??żĆ?>žŕ?=˝ů?<źj?;ť„?:ş?9šś?8¸Đ?7ˇé?6ˇ?5ľt?4´?3ł§?2˛Ŕ?1ąŮ?0°ň?/Żd?.Ž}?-­—?,Ź°?+ŤÉ?*Şă?)Šü?(¨m?'§‡?&Ś ?%Ľš?$¤Ó?#Łě?"˘^?!Ąw?  ?ŸŠ?žĂ?Ü?œN?›g?š€?™š?˜ł?—Ě?–ć?•W?”p?“Š?’Ł?‘ź?Ö?G?Ža? z? Œ“? ‹Ź? ŠĆ? ‰7?ˆQ?‡j?†ƒ?…?„ś?ƒĎ?‚A?Z?�€s>ţ˙>üýL>úű>řřb>öö”>ôôÇ>ňňú>đń,>îď_>ěí‘>ęęt>čč§>ććÚ>äĺ >âă?>ŕár>ŢŢU>Ü܇>ÚÚş>ŘŘí>Ö×>ÔŐR>ŇŇ5>ĐĐh>ÎΚ>ĚĚÍ>ĘĘ˙>ČÉ2>ĆÇe>ÄÄH>ÂÂz>ŔŔ­>žžŕ>ź˝>şťE>¸¸(>śś[>´´>˛˛Ŕ>°°ň>ŽŻ%>ŹŹ>ŞŞ;>¨¨m>ŚŚ >¤¤Ó>˘Ł> Ą8>žž>œœN>šš€>˜˜ł>––ć>”•>’‘ű>.>ŽŽa>ŒŒ“>ŠŠĆ>ˆˆř>†‡+>„„>‚‚A>€€s>|ýL>xůą>tö>pďÝ>lěB>hč§>dĺ >`ár>\Ý×>Xם>TÔ>PĐh>LĚÍ>HÉ2>Dŗ>@Áý><ťĂ>8¸(>4´>0°ň>,­X>(Š˝>$Łƒ> Ÿč>œN>˜ł>•>‘}> ‹D>‡Š>„>�€s=řůą=đň|=čëF=ŕŢÓ=Řם=ĐĐh=ČÉ2=ŔÁý=¸şÇ=°ŽS=¨§= Ÿč=˜˜ł=‘}=ˆŠH=€ƒ=pí>=`ŢÓ=PĐh=@Áý=0ł’= Ľ'=Œ?=�}Ô<ŕŢÓ<ŔÁý< Ľ'<€ˆQ<@­<�sX;€sX���� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/neglog.fits������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�016067� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'neglog ' / Name of ramp HISTORY intensity ramp converted from: neglog.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ?€��?zú×?qň?ię6?cä&?\Ý/?WŘ?QŃö?LĚÍ?HȊ?CÄ ??żĆ?<źj?7ˇé?4´?1ąŮ?.Ž}?*Şă?(¨m?%Ľš?#Łě?  ?Ü?›g?™š?–ć?”p?‘ź?Ö?Ža? Œ“? ŠĆ?ˆQ?‡j?„ś?ƒĎ?Z>ţ˙>üýL>úű>öö”>ôôÇ>îď_>ěí‘>ęęt>ććÚ>äĺ >âă?>ŕár>ŢŢU>ÚÚş>Ö×>ÔŐR>ŇŇ5>ĐĐh>ÎΚ>ĚĚÍ>ĘĘ˙>ČÉ2>ĆÇe>ÄÄH>ÂÂz>žžŕ>ź˝>şťE>¸¸(>śś[>´´>˛˛Ŕ>°°ň>°°ň>ŽŻ%>ŹŹ>ŞŞ;>¨¨m>¤¤Ó>¤¤Ó>˘Ł> Ą8>žž>žž>œœN>šš€>˜˜ł>˜˜ł>––ć>”•>’‘ű>’‘ű>.>ŽŽa>ŽŽa>ŠŠĆ>ˆˆř>ˆˆř>†‡+>„„>„„>‚‚A>‚‚A>€€s>|ýL>|ýL>xůą>tö>tö>pďÝ>pďÝ>lěB>lěB>hč§>`ár>`ár>\Ý×>\Ý×>Xם>Xם>TÔ>TÔ>PĐh>PĐh>LĚÍ>LĚÍ>HÉ2>HÉ2>Dŗ>Dŗ>@Áý>@Áý><ťĂ><ťĂ>8¸(>8¸(>0°ň>0°ň>,­X>,­X>(Š˝>(Š˝>$Łƒ>$Łƒ>$Łƒ> Ÿč> Ÿč>œN>œN>˜ł>˜ł>•>•>•>‘}>‘}> ‹D> ‹D> ‹D>‡Š>‡Š>„>„>„=řůą=řůą=đň|=đň|=đň|=čëF=čëF=ŕŢÓ=ŕŢÓ=ŕŢÓ=Řם=Řם=Řם=ĐĐh=ĐĐh=ĐĐh=ČÉ2=ČÉ2=ŔÁý=ŔÁý=ŔÁý=¸şÇ=¸şÇ=¸şÇ=°ŽS=°ŽS=°ŽS=¨§=¨§=¨§= Ÿč= Ÿč= Ÿč=‘}=‘}=‘}=ˆŠH=ˆŠH=ˆŠH=€ƒ=€ƒ=€ƒ=pí>=pí>=pí>=pí>=`ŢÓ=`ŢÓ=`ŢÓ=PĐh=PĐh=PĐh=@Áý=@Áý=@Áý=0ł’=0ł’=0ł’=0ł’= Ľ'= Ľ'= Ľ'=Œ?=Œ?=Œ?=Œ?=�}Ô=�}Ô=�}Ô<ŕŢÓ<ŕŢÓ<ŕŢÓ<ŕŢÓ< Ľ'< Ľ'< Ľ'< Ľ'<€ˆQ<€ˆQ<€ˆQ<@­<@­<@­<@­<�sX<�sX<�sX<�sX;€sX;€sX;€sX;€sX������������ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/null.fits��������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�015566� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'null ' / Name of ramp HISTORY intensity ramp converted from: null.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:17 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/ramp.fits��������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�015553� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'ramp ' / Name of ramp HISTORY intensity ramp converted from: ramp.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:18 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?˜ł?™š?˜ł?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€�� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/ramps/stairs.fits������������������������������������������������������������0000644�0601750�0601001�00000013200�12562522364�016121� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 1 / Number of axes NAXIS1 = 256 / Value BUNIT = 'Data Value ' OBJECT = 'stairs ' / Name of ramp HISTORY intensity ramp converted from: stairs.iasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:20:18 2000 HISTORY Data is stored as a 1D image, as a float (BITPIX=-32), HISTORY in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������������������������������=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=pí>=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|>4´>4´>4´>4´>4´>4´>4´>4´>4´>4´>4´>4´>4´>4´>4´>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>––ć>´´>´´>´´>´´>´´>´´>´´>´´>´´>´´>´´>´´>´´>´´>´´>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?‡j?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?%Ľš?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?€��?€�� ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/README�����������������������������������������������������������������������0000644�0601750�0601001�00000000342�12562522364�013466� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� The colour tables were taken from STARLINK's GAIA distribution, where they have the GNU copyleft. Further information on STARLINK and GAIA can be found via http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/. ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/����������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�014041� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/aips0.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015763� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'aips0 ' / Name of colour table HISTORY (r,g,b) colour table converted from: aips0.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:57 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú����������������������������������������������������������������������������������������������������������������>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ��������������������������������������������������������������������������������������������������������������������>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/backgr.fits�����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016200� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'backgr ' / Name of colour table HISTORY (r,g,b) colour table converted from: backgr.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:57 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����<‚Í=Í=C´=‚Í=˘‚A=Ă´=ăƒ'>Í>B>"‚A>2Âz>C´>SBî>cƒ'>sĂa>‚Í>Š!ę>’B>šb$>˘‚A>Ş˘^>˛Âz>şâ—>Ă´>Ë"Ń>ÓBî>Űc >ăƒ'>ëŁD>óĂa>űă~?Í?Ü? !ę?1ů?B?R?b$?r2?"‚A?&’O?*˘^?.˛l?2Âz?6҉?:â—?>ňŚ?C´?GÂ?K"Ń?O2ß?SBî?WRü?[c ?_s?cƒ'?g“6?kŁD?ołS?sĂa?wÓo?{ă~?óŒ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<‚Í=Í=C´=‚Í=˘‚A=Ă´=ăƒ'>Í>B>"‚A>2Âz>C´>SBî>cƒ'>sĂa>‚Í>Š!ę>’B>šb$>˘‚A>Ş˘^>˛Âz>şâ—>Ă´>Ë"Ń>ÓBî>Űc >ăƒ'>ëŁD>óĂa>űă~?Í?Ü? !ę?1ů?B?R?b$?r2?"‚A?&’O?*˘^?.˛l?2Âz?6҉?:â—?>ňŚ?C´?GÂ?K"Ń?O2ß?SBî?WRü?[c ?_s?cƒ'?g“6?kŁD?ołS?sĂa?wÓo?{ă~?óŒ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������<‚Í=Í=C´=‚Í=˘‚A=Ă´=ăƒ'>Í>B>"‚A>2Âz>C´>SBî>cƒ'>sĂa>‚Í>Š!ę>’B>šb$>˘‚A>Ş˘^>˛Âz>şâ—>Ă´>Ë"Ń>ÓBî>Űc >ăƒ'>ëŁD>óĂa>űă~?Í?Ü? !ę?1ů?B?R?b$?r2?"‚A?&’O?*˘^?.˛l?2Âz?6҉?:â—?>ňŚ?C´?GÂ?K"Ń?O2ß?SBî?WRü?[c ?_s?cƒ'?g“6?kŁD?ołS?sĂa?wÓo?{ă~?óŒ����<‚Í=Í=C´=‚Í=˘‚A=Ă´=ăƒ'>Í>B>"‚A>2Âz>C´>SBî>cƒ'>sĂa>‚Í>Š!ę>’B>šb$>˘‚A>Ş˘^>˛Âz>şâ—>Ă´>Ë"Ń>ÓBî>Űc >ăƒ'>ëŁD>óĂa>űă~?Í?Ü? !ę?1ů?B?R?b$?r2?"‚A?&’O?*˘^?.˛l?2Âz?6҉?:â—?>ňŚ?C´?GÂ?K"Ń?O2ß?SBî?WRü?[c ?_s?cƒ'?g“6?kŁD?ołS?sĂa?wÓo?{ă~?óŒ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?óŒ?{ă~?wÓo?sĂa?ołS?kŁD?g“6?cƒ'?_s?[c ?WRü?SBî?O2ß?K"Ń?GÂ?C´?>ňŚ?:â—?6҉?2Âz?.˛l?*˘^?&’O?"‚A?r2?b$?R?B?1ů? !ę?Ü?Í>űă~>óĂa>ëŁD>ăƒ'>Űc >ÓBî>Ë"Ń>Ă´>şâ—>˛Âz>Ş˘^>˘‚A>šb$>’B>Š!ę>‚Í>sĂa>cƒ'>SBî>C´>2Âz>"‚A>B>Í=ăƒ'=Ă´=˘‚A=‚Í=C´=Í<‚Í��������<‚Í=Í=C´=‚Í=˘‚A=Ă´=ăƒ'>Í>B>"‚A>2Âz>C´>SBî>cƒ'>sĂa>‚Í>Š!ę>’B>šb$>˘‚A>Ş˘^>˛Âz>şâ—>Ă´>Ë"Ń>ÓBî>Űc >ăƒ'>ëŁD>óĂa>űă~?Í?Ü? !ę?1ů?B?R?b$?r2?"‚A?&’O?*˘^?.˛l?2Âz?6҉?:â—?>ňŚ?C´?GÂ?K"Ń?O2ß?SBî?WRü?[c ?_s?cƒ'?g“6?kŁD?ołS?sĂa?wÓo?{ă~?óŒ?óŒ?{ă~?wÓo?sĂa?ołS?kŁD?g“6?cƒ'?_s?[c ?WRü?SBî?O2ß?K"Ń?GÂ?C´?>ňŚ?:â—?6҉?2Âz?.˛l?*˘^?&’O?"‚A?r2?b$?R?B?1ů? !ę?Ü?Í>űă~>óĂa>ëŁD>ăƒ'>Űc >ÓBî>Ë"Ń>Ă´>şâ—>˛Âz>Ş˘^>˘‚A>šb$>’B>Š!ę>‚Í>sĂa>cƒ'>SBî>C´>2Âz>"‚A>B>Í=ăƒ'=Ă´=˘‚A=‚Í=C´=Í<‚Í������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/bgyrw.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016101� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'bgyrw ' / Name of colour table HISTORY (r,g,b) colour table converted from: bgyrw.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:58 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<€��=���=€��=Ŕ��>���>��>0��>P��>`��>€��>��>˜��>¨��>¸��>Č��>Đ��>ŕ��>đ��>ř��?��? ��?��?��? ��?(��?,��?4��?<��?@��?H��?P��?T��?\��?d��?l��?p��?x��?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<€��=@��= ��=Ŕ��>���> ��>0��>P��>p��>ˆ��>��> ��>°��>¸��>Č��>Ř��>ŕ��>đ��?���?��? ��?��?��? ��?(��?0��?4��?<��?D��?L��?P��?X��?`��?d��?l��?t��?x��?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?|��?x��?p��?h��?d��?\��?T��?L��?H��?@��?8��?4��?,��?$��? ��?��?��?��?��>ř��>č��>ŕ��>Đ��>Ŕ��>¸��>¨��>˜��>ˆ��>€��>`��>@��>0��>��=ŕ��=Ŕ��=€��=���������������������������������������������������������������������������������������<ŕ��=`��=¨��=č�>��>,�>L�>h��>‚�>��> ��>Ž�>ź��>Ě��>Ú�>č��>ö�?�? ��?�?�? ��?'�?.��?6��?=�?D��?L��?S�?Z��?a�?i�?p��?w�?�����< ��= ��=p��= ��=Č��=đ��> �> ��>4�>L�>`��>t�>„��>Ž�>˜��>˘�>Ź��>ś�>Ŕ��>Ě��>Ö�>ŕ��>ę�>ô��>ţ�?��? �?��?�?�?��?#�?(��?-�?2��?7�?<��?A�?F��?L��?Q�?V��?[�?`��?e�?j��?o�?t��?y�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?�?|��?t��?l��?h��?`��?X��?T��?L��?D��?@��?8��?0��?(��?$��?��?��?��?��?���>ř��>č��>Ř��>Č��>Ŕ��>°��> ��>˜��>ˆ��>p��>`��>@��> ��>���=ŕ��= ��=@��=���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<ŕ��=`��=¨��=č�>��>,�>L�>h��>‚�>��> ��>Ž�>ź��>Ě��>Ú�>č��>ö�?�? ��?�?�? ��?'�?.��?6��?=�?D��?L��?S�?Z��?a�?i�?p��?w�?� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/blue.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015676� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'blue ' / Name of colour table HISTORY (r,g,b) colour table converted from: blue.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:58 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX<�sX<@­<€ˆQ;€sX����;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/blulut.fits�����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016256� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'blulut ' / Name of colour table HISTORY (r,g,b) colour table converted from: blulut.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:58 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������������������������������7'ĹŹ7'ĹŹ7'ĹŹ7§ĹŹ7§ĹŹ7§ĹŹ7ű¨‚8'ĹŹ8Qˇ8{¨‚8’Ě÷8§ĹŹ8źžb8ćŻÍ9Pœ9IR92B9G:˝9fŻÍ9ƒo9’Ě÷9§ĹŹ9ˇ€49ѡ9ćŻÍ:�sX:-ŕ:čh:/˘đ:Aü:TV.:iNä:~G™:Šďł:–ť™:Ľ&–:˛B:Áü:ѡ:âÁ+:őĘ;ş4; ŽÉ;˛ę;#× ;/˘đ;<œ;I2;VM;d¸|;ts;‚Ć;ŠGí;“ Ú;œMŠ;ĽÎ[;Ż˘đ;şK;Äď‰;ĐgŒ;Ü3r;čS;;őĘ<E<&Ť<\)<ĺŠ<ÂÎ<&Ę</%<7Ô<@Öő<JW¨<TK<^�Ň<hS;<s#y<~G™<„ßÎ<ŠĹÁ<ęž<—Nf<Ç&<¤“É<ŤŠ]<˛Şă<şK<Á˝Ľ<ɚé<ѡ<Ú0<âŹ2<ë…<ôœő<ýóś=Ď-=šx= Ř0= á=iƒ=ń=#˜ =)i=/d=5ˆă=;Í6=BEö=HŢ+=OŞÎ=V–ć=]ˇk=eâ=l€Ç=t)ž=|â=‚ =†Ÿ=ŠW¨=Ž¤Š=“ á=—P=œ(ö= ä=Ľ´$=ޞo=Ż¨/=´Ńc=şĎ=żrq=Äď‰=ʌ=ĐBŮ=ÖO=Üý=â.^=čbö=îźA=ő5=űŇt>E>ľÝ>6e> ÉG>nƒ>#y>íg>É°>¸R>"šN>&ĚŁ>*ôń>/28>3Ř>7ćq><]d>@ëî>EŒŇ>JEN>OÂ>Ső0>Xď5>]ţ3>c$Č>h`W>mł}>s:>x >~:~>÷Q>„Űŕ>‡ÍŠ>ŠĚO>Öŕ>î>”>—Cé>š‚č>Íł>Ą(9>¤ŽŠ>¨G>Ť…>Żb>˛´>śa(>şŹ>˝ć›>Ážő>ĹĽš>ɜ9>͢s>ѡ>ŐŰw>Ú‘>ŢSe>âŚô>ç >ëá>đď>ô™>ů?)>ýő?^ž?Ë>?@d?ž? Dĺ? Ôé?mr?(?ş ?n?+V?ňg? ĂL?#œˇ?&€?)nY?,eA?/fĽ?2qŢ?5†ě?8Śv?;Đ}??W?BBŻ?EŒ*?Hßz?L=î?O§‡?S›?VšÔ?Z%1?]ş ?aZŻ?e!?hž?lo?pOô?t*E?xť?|K?€������������������������������������������������������7'ĹŹ7'ĹŹ7'ĹŹ7§ĹŹ7§ĹŹ7§ĹŹ7ű¨‚8'ĹŹ8Qˇ8{¨‚8’Ě÷8§ĹŹ8źžb8ćŻÍ9Pœ9IR92B9G:˝9fŻÍ9ƒo9’Ě÷9§ĹŹ9ˇ€49ѡ9ćŻÍ:�sX:-ŕ:čh:/˘đ:Aü:TV.:iNä:~G™:Šďł:–ť™:Ľ&–:˛B:Áü:ѡ:âÁ+:őĘ;ş4; ŽÉ;˛ę;#× ;/˘đ;<œ;I2;VM;d¸|;ts;‚Ć;ŠGí;“ Ú;œMŠ;ĽÎ[;Ż˘đ;şK;Äď‰;ĐgŒ;Ü3r;čS;;őĘ<E<&Ť<\)<ĺŠ<ÂÎ<&Ę</%<7Ô<@Öő<JW¨<TK<^�Ň<hS;<s#y<~G™<„ßÎ<ŠĹÁ<ęž<—Nf<Ç&<¤“É<ŤŠ]<˛Şă<şK<Á˝Ľ<ɚé<ѡ<Ú0<âŹ2<ë…<ôœő<ýóś=Ď-=šx= Ř0= á=iƒ=ń=#˜ =)i=/d=5ˆă=;Í6=BEö=HŢ+=OŞÎ=V–ć=]ˇk=eâ=l€Ç=t)ž=|â=‚ =†Ÿ=ŠW¨=Ž¤Š=“ á=—P=œ(ö= ä=Ľ´$=ޞo=Ż¨/=´Ńc=şĎ=żrq=Äď‰=ʌ=ĐBŮ=ÖO=Üý=â.^=čbö=îźA=ő5=űŇt>E>ľÝ>6e> ÉG>nƒ>#y>íg>É°>¸R>"šN>&ĚŁ>*ôń>/28>3Ř>7ćq><]d>@ëî>EŒŇ>JEN>OÂ>Ső0>Xď5>]ţ3>c$Č>h`W>mł}>s:>x >~:~>÷Q>„Űŕ>‡ÍŠ>ŠĚO>Öŕ>î>”>—Cé>š‚č>Íł>Ą(9>¤ŽŠ>¨G>Ť…>Żb>˛´>śa(>şŹ>˝ć›>Ážő>ĹĽš>ɜ9>͢s>ѡ>ŐŰw>Ú‘>ŢSe>âŚô>ç >ëá>đď>ô™>ů?)>ýő?^ž?Ë>?@d?ž? Dĺ? Ôé?mr?(?ş ?n?+V?ňg? ĂL?#œˇ?&€?)nY?,eA?/fĽ?2qŢ?5†ě?8Śv?;Đ}??W?BBŻ?EŒ*?Hßz?L=î?O§‡?S›?VšÔ?Z%1?]ş ?aZŻ?e!?hž?lo?pOô?t*E?xť?|K?€������;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/color.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016065� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'color ' / Name of colour table HISTORY (r,g,b) colour table converted from: color.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:58 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������������������������������������������><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ?G?G?G?G?G?G?G?G?G?G?G?G?G?G?G?G??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ����������������������������������������������������������������><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ?G?G?G?G?G?G?G?G?G?G?G?G?G?G?G?G??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ?ŸŠ>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ><ťĂ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ?G?G?G?G?G?G?G?G?G?G?G?G?G?G?G?G??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž?oďž??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž>žž ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/green.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016047� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'green ' / Name of colour table HISTORY (r,g,b) colour table converted from: green.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:58 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX<�sX ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/heat.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015670� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'heat ' / Name of colour table HISTORY (r,g,b) colour table converted from: heat.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:59 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����<@­<ŔÁý=Œ?=@Áý=pí>=‘}=¨§=ŔÁý=Řם=đň|>„>‘}>œN>(Š˝>4´>@Áý>LĚÍ>Xם>dĺ >pďÝ>|ýL>„„>ŠŠĆ>.>––ć>œœN>˘Ł>¨¨m>ŽŻ%>´´>şťE>ŔŔ­>ĆÇe>ĚĚÍ>ŇŇ5>ŘŘí>ŢŢU>äĺ >ęęt>đń,>öö”>üýL?Z?„ś?‡j? ŠĆ? z?Ö?“Š?–ć?™š?œN?ŸŠ?"˘^?%Ľš?(¨m?+ŤÉ?.Ž}?1ąŮ?4´?7ˇé?:ş?=˝ů?@Ŕ­?CÄ ?FĆ˝?IĘ?LĚÍ?Oρ?RŇÝ?UՑ?XŘí?[ŰĄ?^Ţü?aáą?dĺ ?gçŔ?jë?míĐ?pń,?sóŕ?v÷<?yůđ?|ýL?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<@­<ŔÁý=Œ?=@Áý=pí>=‘}=¨§=ŔÁý=Řם=đň|>„>‘}>œN>(Š˝>4´>@Áý>LĚÍ>Xם>dĺ >pďÝ>|ýL>„„>ŠŠĆ>.>––ć>œœN>˘Ł>¨¨m>ŽŻ%>´´>şťE>ŔŔ­>ĆÇe>ĚĚÍ>ŇŇ5>ŘŘí>ŢŢU>äĺ >ęęt>đń,>öö”>üýL?Z?„ś?‡j? ŠĆ? z?Ö?“Š?–ć?™š?œN?ŸŠ?"˘^?%Ľš?(¨m?+ŤÉ?.Ž}?1ąŮ?4´?7ˇé?:ş?=˝ů?@Ŕ­?CÄ ?FĆ˝?IĘ?LĚÍ?Oρ?RŇÝ?UՑ?XŘí?[ŰĄ?^Ţü?aáą?dĺ ?gçŔ?jë?míĐ?pń,?sóŕ?v÷<?yůđ?|ýL?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl11.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015661� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl11 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl11.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:59 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<€ˆQ=�}Ô=@Áý=€ƒ= Ÿč=ŔÁý=ŕŢÓ>�€s>‘}> Ÿč>0°ň>@Áý>PĐh>`ár>pďÝ>€€s>ˆˆř>.>˜˜ł> Ą8>ŞŞ;>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ŇŇ5>ÚÚş>âă?>ęęt>ňňú>úű?Z?…? ‰7? z?‘ź?•W?™š?Ü?!Ąw?%Ľš?*Şă?.Ž}?2˛Ŕ?6ˇ?:ş?>žŕ?BÂz?FĆ˝?JĘ˙?NΚ?RŇÝ?V×?ZÚş?^Ţü?bâ—?fćÚ?jë?nîˇ?rňú?v÷<?zú×?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������;€sX<�sX<@­<€ˆQ=�}Ô=@Áý=€ƒ=¨§=ČÉ2=čëF>„>˜ł>(Š˝>8¸(>HÉ2>\Ý×>lěB>|ýL>†‡+>.>˜˜ł> Ą8>¨¨m>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ÔŐR>Ü܇>äĺ >ěí‘>öö”>ţ˙?ƒĎ?‡j? Œ“?Ö?”p?˜ł?Ü?!Ąw?%Ľš?)Šü?.Ž}?2˛Ŕ?6ˇ?:ş??żĆ?CÄ ?GǤ?KËć?PŃ?TÔŞ?XŘí?\Ý/?aáą?eĺó?ię6?míĐ?rňú?v÷<?zú×?€��?€��?{ű˝?wř#?sóŕ?oďž?kě?gçŔ?cä&?_ßă?[ŰĄ?WŘ?SÓĂ?Oρ?KËć?GǤ?CÄ ??żĆ?;ť„?7ˇé?3ł§?/Żd?*Şă?&Ś ?"˘^?žĂ?š€?–ć?’Ł?Ža? ŠĆ?†ƒ?‚A>üýL>ôôÇ>ěí‘>äĺ >Ü܇>ÔŐR>ĚĚÍ>ÄÄH>ź˝>´´>ŞŞ;>˘Ł>šš€>’‘ű>ŠŠĆ>‚‚A>tö>dĺ >TÔ>Dŗ>4´>$Łƒ>•>„=čëF=ČÉ2=¨§=ˆŠH=PĐh=Œ?< Ľ'����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX<�sX<@­<€ˆQ=�}Ô=@Áý=€ƒ=¨§=ČÉ2=čëF>„>˜ł>(Š˝>8¸(>HÉ2>\Ý×>lěB>|ýL>†‡+>.>˜˜ł> Ą8>¨¨m>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ÔŐR>Ü܇>äĺ >ěí‘>öö”>ţ˙?ƒĎ?‡j? Œ“?Ö?”p?˜ł?Ü?!Ąw?%Ľš?)Šü?.Ž}?2˛Ŕ?6ˇ?:ş??żĆ?CÄ ?GǤ?KËć?PŃ?TÔŞ?XŘí?\Ý/?aáą?eĺó?ię6?míĐ?rňú?v÷<?zú×?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?{ű˝?wř#?sóŕ?oďž?kě?gçŔ?cä&?_ßă?ZÚş?V×?RŇÝ?NΚ?JĘ˙?FĆ˝?BÂz?>žŕ?:ş?5ľt?1ąŮ?-­—?)Šü?%Ľš?!Ąw?Ü?™š?•W?Ö? Œ“?ˆQ?„ś?�€s>řřb>đń,>čč§>ŕár>Ö×>ÎΚ>ĆÇe>žžŕ>śś[>ŽŻ%>ŚŚ >žž>––ć>ŒŒ“>„„>xůą>hč§>Xם>HÉ2>8¸(>(Š˝>˜ł>„=čëF=ČÉ2=¨§=ˆŠH=PĐh=Œ?< Ľ'�������� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl12.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015662� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl12 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl12.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:59 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?]Ţ?]Ţ?]Ţ?]Ţ?]Ţ?^Ţü?^Ţü?^Ţü?^Ţü?^Ţü?_ßă?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s?�€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s>€€s����������������������������������������������������������������?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?>žŕ?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl14.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015664� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl14 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl14.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:16:59 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<ŕŢÓ=pí>=¸şÇ=řůą>œN><ťĂ>\Ý×>|ýL>ŒŒ“>œœN>ŹŹ>ź˝>ĚĚÍ>Ü܇>ěí‘>üýL?†ƒ?Ža?—Ě?ŸŠ?(¨m?0°ň?8¸Đ?AÁ”?IĘ?RŇÝ?ZÚş?bâ—?kě?sóŕ?|ýL����;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=`ŢÓ=€ƒ=‘}= Ÿč=¸şÇ=ČÉ2=Řם=čëF>�€s>‡Š>‘}>˜ł>$Łƒ>0°ň><ťĂ>HÉ2>TÔ>`ár>lěB>|ýL>„„>ŠŠĆ>.>––ć>œœN>¤¤Ó>ŞŞ;>˛˛Ŕ>şťE>ÂÂz>ĘĘ˙>ŇŇ5>ŘŘí>ŕár>čč§>đń,>řřb?�€s?ƒĎ?‡j? ‹Ź?G?“Š?—Ě?›g?ŸŠ?#Łě?'§‡?+ŤÉ?/Żd?2˛Ŕ?5ľt?9šś?<źj?@Ŕ­?CÄ ?FĆ˝?JĘ˙?MÍł?QŃö?TÔŞ?XŘí?ZÚş?\Ý/?_ßă?aáą?cä&?fćÚ?hč§?jë?míĐ?oďž?qň?tôÇ?tôÇ?uőŽ?v÷<?wř#?wř#?xů ?yůđ?zú×?zú×?{ű˝?|ýL?}ţ3?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������>(Š˝>ŞŞ;>ţ˙?*Şă?TÔŞ?€��?v÷<?lěę?bâ—?XŘí?NΚ?EĹÖ?;ť„?1ąŮ?'§‡?Ü?”p? ŠĆ?�€s>ěí‘>ŘŘí>ĆÇe>˛˛Ŕ>žž>ŠŠĆ>lěB>HÉ2> Ÿč=đň|= Ÿč= Ľ'������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX;€sX;€sX<@­< Ľ'=�}Ô= Ľ'=@Áý=pí>=ˆŠH=˜˜ł=°ŽS=ŔÁý=ĐĐh=čëF=řůą>„>‘}>‘}>˜ł> Ÿč>(Š˝>4´>@Áý>LĚÍ>Xם>hč§>tö>€€s>†‡+>ŒŒ“>’‘ű>šš€>¤¤Ó>ŽŻ%>¸¸(>ŔŔ­>ČÉ2>ĐĐh>ŘŘí>âă?>îď_>úű?ƒĎ? ŠĆ?Ö?—Ě?Ü?$¤Ó?+ŤÉ?2˛Ŕ?9šś?AÁ”?HȊ?PŃ?WŘ?_ßă?eĺó?kě?rňú?xů ?€��������������������������������������������������������������������������������������������������������������������������������������=�}Ô=€ƒ=ŔÁý>�€s>$Łƒ>Dŗ>dĺ >‚‚A>”•>¤¤Ó>´´>ÄÄH>ÔŐR>ććÚ>öö”?ƒĎ? ‹Ź?”p?œN?$¤Ó?,Ź°?4´?=˝ů?EĹÖ?MÍł?UՑ?^Ţü?fćÚ?nîˇ?v÷<?€������< Ľ'= Ľ'=pí>=¨§=ĐĐh=řůą>•>(Š˝><ťĂ>TÔ>hč§>|ýL>ŠŠĆ>”•>žž>ŞŞ;>˛˛Ŕ>ź˝>ÄÄH>ÎΚ>ŘŘí>ŕár>ęęt>ňňú>üýL?ƒĎ?‡j? Œ“?Ö?•W?š€��������������������������������������������������������������������������������������������������������������������������������������������������������;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<�sX<@­<€ˆQ< Ľ'<ŕŢÓ=Œ?=@Áý=`ŢÓ=ˆŠH= Ÿč=¸şÇ=Řם=đň|>‡Š>œN>0°ň>Dŗ>\Ý×>pďÝ>‚‚A>ŽŽa>˜˜ł>¤¤Ó>˛˛Ŕ>ÂÂz>ĐĐh>ŕár>đń,?�€s?ˆQ?‘ź?™š?"˘^?+ŤÉ?4´?=˝ů?FĆ˝?Oρ?YŮÓ?`ŕĘ?hč§?oďž?wř#?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl15.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015665� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl15 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl15.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:00 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����=‘}>‘}>Xם>.>´´>ŘŘí>ţ˙?‘ź?#Łě?5ľt?GǤ?YŮÓ?kě?~˙?yůđ?tôÇ?oďž?jë?eĺó?_ßă?ZÚş?UՑ?PŃ?KËć?EĹÖ?@Ŕ­?;ť„?6ˇ?1ąŮ?,Ź°?&Ś ?!Ąw?œN?—Ě?’Ł? Œ“?‡j?‚A>úű>đń,>ććÚ>ÚÚş>ĐĐh>ĆÇe>ź˝>˛˛Ŕ>ŚŚ >œœN>’‘ű>ˆˆř>|ýL>hč§>PĐh><ťĂ>(Š˝>•>�€s=ĐĐh=¨§=€ƒ=0ł’<ŔÁý����>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€������;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€������;€sX<@­< Ľ'<ŕŢÓ=Œ?=0ł’=PĐh=pí>=ˆŠH=˜˜ł=¨§=¸şÇ=ČÉ2=Řם=čëF=řůą>„> ‹D>•>œN>$Łƒ>,­X>4´><ťĂ>Dŗ>LĚÍ>TÔ>\Ý×>dĺ >lěB>tö>|ýL>‚‚A>†‡+>ŠŠĆ>ŽŽa>’‘ű>––ć>šš€>žž>˘Ł>ŚŚ >ŞŞ;>ŽŻ%>˛˛Ŕ>śś[>şťE>žžŕ>ÂÂz>ĆÇe>ĘĘ˙>ÎΚ>ŇŇ5>Ö×>ÚÚş>ŢŢU>âă?>ććÚ>ęęt>îď_>ňňú>öö”>úű>ţ˙?Z?ƒĎ?…?‡j? ‰7? ‹Ź? z?G?‘ź?“Š?•W?—Ě?™š?›g?Ü?ŸŠ?!Ąw?#Łě?%Ľš?'§‡?)Šü?+ŤÉ?-­—?/Żd?1ąŮ?3ł§?5ľt?7ˇé?9šś?;ť„?=˝ů??żĆ?AÁ”?CÄ ?EĹÖ?GǤ?IĘ?KËć?MÍł?Oρ?QŃö?SÓĂ?UՑ?WŘ?YŮÓ?[ŰĄ?]Ţ?_ßă?aáą?cä&?eĺó?gçŔ?ię6?kě?míĐ?oďž?qň?sóŕ?uőŽ?wř#?yůđ?{ű˝?}ţ3?€��?{ű˝?wř#?sóŕ?nîˇ?jë?fćÚ?bâ—?]Ţ?YŮÓ?UՑ?QŃö?LĚÍ?HȊ?DÄđ?@Ŕ­?;ť„?7ˇé?3ł§?/Żd?*Şă?&Ś ?"˘^?žĂ?™š?•W?‘ź? z?ˆQ?„ś?�€s>řřb>îď_>ććÚ>ŢŢU>Ö×>ĚĚÍ>ÄÄH>ź˝>´´>ŞŞ;>˘Ł>šš€>’‘ű>ˆˆř>€€s>pďÝ>`ár>LĚÍ><ťĂ>,­X>œN>‡Š=đň|=ĐĐh=°ŽS=ˆŠH=PĐh=Œ?< Ľ'����<@­<ŕŢÓ=0ł’=pí>=˜˜ł=°ŽS=ĐĐh=đň|>‡Š>˜ł>$Łƒ>4´>Dŗ>TÔ>dĺ >pďÝ>€€s>ˆˆř>.>˜˜ł>žž>ŚŚ >ŽŻ%>śś[>žžŕ>ÄÄH>ĚĚÍ>ÔŐR>Ü܇>äĺ >ęęt>ňňú>úű?Z?…? ‰7? Œ“?Ö?”p?˜ł?œN?ŸŠ?#Łě?'§‡?+ŤÉ?/Żd?2˛Ŕ?6ˇ?:ş?>žŕ?BÂz?EĹÖ?IĘ?MÍł?QŃö?UՑ?XŘí?\Ý/?`ŕĘ?dĺ ?hč§?kě?oďž?sóŕ?wř#?{ű˝?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl2.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015601� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl2 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl2.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:00 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������������������������������������������������������������������������������������������<ŔÁý=@Áý=‘}=ŔÁý=đň|>‘}>(Š˝>@Áý>Xם>pďÝ>„„>.>œœN>¨¨m>´´>ŔŔ­>ĚĚÍ>ŘŘí>äĺ >đń,>üýL?„ś? ŠĆ?Ö?–ć?œN?"˘^?(¨m?.Ž}?4´?:ş?@Ŕ­?FĆ˝?LĚÍ?RŇÝ?XŘí?^Ţü?dĺ ?jë?pń,?sóŕ?v÷<?yůđ?|ýL?|ýL?|ýL?|ýL?|ýL?{ű˝?zú×?yůđ?xů ?xů ?xů ?xů ?xů ?wř#?v÷<?uőŽ?tôÇ?sóŕ?rňú?qň?pń,?pń,?oďž?nîˇ?míĐ?lěę?lěę?lěę?lěę?kě?jë?ię6?hč§?gçŔ?fćÚ?eĺó?dĺ ?dĺ ?dĺ ?dĺ ?dĺ ?cä&?bâ—?aáą?`ŕĘ?_ßă?^Ţü?]Ţ?\Ý/?[ŰĄ?ZÚş?YŮÓ?XŘí?XŘí?XŘí?XŘí?XŘí?WŘ?V×?UՑ?TÔŞ?SÓĂ?RŇÝ?QŃö?PŃ?Oρ?NΚ?MÍł?LĚÍ?LĚÍ?LĚÍ?LĚÍ?LĚÍ?KËć?JĘ˙?IĘ?HȊ?GǤ?FĆ˝?EĹÖ?DÄđ?DÄđ?DÄđ?DÄđ?DÄđ?CÄ ?BÂz?AÁ”?@Ŕ­??żĆ?>žŕ?=˝ů?<źj?;ť„?:ş?9šś?8¸Đ?8¸Đ?8¸Đ?8¸Đ?8¸Đ?7ˇé?6ˇ?5ľt?4´?3ł§?2˛Ŕ?1ąŮ?0°ň?0°ň?0°ň?0°ň?0°ň?/Żd?.Ž}?-­—?,Ź°?+ŤÉ?*Şă?)Šü?(¨m?'§‡?&Ś ?%Ľš?$¤Ó?$¤Ó?$¤Ó?$¤Ó?$¤Ó?#Łě?"˘^?!Ąw?  ?ŸŠ?žĂ?Ü?œN?›g?š€?™š?˜ł?˜ł?˜ł?˜ł?˜ł?—Ě?–ć?•W?”p?—Ě?š€?Ü?  ?#Łě?&Ś ?)Šü?,Ź°?0°ň?4´?8¸Đ?<źj??żĆ?BÂz?EĹÖ?HȊ?KËć?NΚ?QŃö?TÔŞ?WŘ?ZÚş?]Ţ?`ŕĘ?dĺ ?hč§?lěę?pń,?sóŕ?v÷<?yůđ?|ýL?}ţ3?~˙?€������>‘}>.>––ć>žž>¤¤Ó>ŹŹ>´´>şťE>ÂÂz>ČÉ2>ĐĐh>ŘŘí>ęęt>üýL?‡j?Ö?™š?"˘^?+ŤÉ?4´?=˝ů?FĆ˝?Oρ?XŘí?aáą?jë?sóŕ?|ýL?yůđ?v÷<?sóŕ?pń,?jë?dĺ ?^Ţü?XŘí?RŇÝ?LĚÍ?FĆ˝?@Ŕ­?:ş?4´?.Ž}?(¨m?"˘^?œN?–ć?Ö? ŠĆ?„ś>üýL>đń,>äĺ >ŘŘí>ĚĚÍ>ŔŔ­>´´>¨¨m>œœN>.>„„>pďÝ>Xם>@Áý>(Š˝>‘}=đň|=ŔÁý=‘}=@Áý<ŔÁý������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX;€sX;€sX;€sX����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>€€s>.> Ą8>°°ň>ŔŔ­>ĐĐh>ŕár>đń,?�€s?‡j?Ža?•W?œN?$¤Ó?,Ź°?4´?<źj?DÄđ?LĚÍ?TÔŞ?\Ý/?dĺ ?lěę?tôÇ?|ýL?}ţ3?~˙?€������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX<@­< Ľ'<ŕŢÓ=Œ?= Ľ'=@Áý=`ŢÓ=€ƒ=‘}= Ÿč=°ŽS=ČÉ2=Řם=čëF=řůą>‡Š> ‹D>•>œN>$Łƒ>,­X>4´><ťĂ>HÉ2>PĐh>Xם>`ár>lěB>tö>|ýL>‚‚A>†‡+>ˆˆř>ŒŒ“>.>”•>˜˜ł>œœN> Ą8>ŚŚ >ŞŞ;>ŽŻ%>˛˛Ŕ>¸¸(>ź˝>ŔŔ­>ÄÄH>ĘĘ˙>ĚĚÍ>ĐĐh>ÔŐR>ŘŘí>Ü܇>ŕár>äĺ >čč§>ěí‘>đń,>ôôÇ>úű>ţ˙?Z?ƒĎ?†ƒ?‡j? ‰7? ‹Ź? z?G?‘ź?“Š?–ć?˜ł?š€?œN?ŸŠ?  ?"˘^?#Łě?%Ľš?'§‡?)Šü?+ŤÉ?.Ž}?0°ň?2˛Ŕ?4´?7ˇé?9šś?;ť„?=˝ů?@Ŕ­?AÁ”?CÄ ?EĹÖ?GǤ?IĘ?KËć?MÍł?PŃ?RŇÝ?TÔŞ?V×?XŘí?YŮÓ?[ŰĄ?]Ţ?_ßă?aáą?cä&?eĺó?hč§?jë?lěę?nîˇ?qň?sóŕ?uőŽ?wř#?zú×?{ű˝?|ýL?}ţ3?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl4.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015603� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl4 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl4.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:00 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<ŕŢÓ=pí>=°ŽS=đň|>•>4´>PĐh>pďÝ>†‡+>––ć>¤¤Ó>´´>ÂÂz>ŇŇ5>ŕár>đń,>úű?‚A?‡j? Œ“?‘ź?–ć?›g?  ?%Ľš?*Şă?/Żd?4´?9šś?>žŕ?CÄ ?HȊ?HȊ?IĘ?IĘ?JĘ˙?JĘ˙?KËć?KËć?LĚÍ?LĚÍ?MÍł?MÍł?NΚ?NΚ?Oρ?Oρ?PŃ?PŃ?QŃö?QŃö?RŇÝ?RŇÝ?SÓĂ?SÓĂ?TÔŞ?TÔŞ?UՑ?UՑ?V×?V×?WŘ?WŘ?XŘí?XŘí?YŮÓ?YŮÓ?ZÚş?ZÚş?[ŰĄ?[ŰĄ?\Ý/?\Ý/?]Ţ?]Ţ?^Ţü?^Ţü?_ßă?_ßă?`ŕĘ?`ŕĘ?aáą?aáą?bâ—?bâ—?cä&?cä&?dĺ ?dĺ ?eĺó?eĺó?fćÚ?fćÚ?gçŔ?gçŔ?hč§?hč§?ię6?ię6?jë?jë?kě?kě?lěę?lěę?míĐ?míĐ?nîˇ?nîˇ?oďž?oďž?pń,?pń,?qň?qň?rňú?rňú?sóŕ?sóŕ?tôÇ?tôÇ?uőŽ?uőŽ?v÷<?v÷<?wř#?wř#?xů ?xů ?yůđ?yůđ?zú×?zú×?{ű˝?{ű˝?|ýL?|ýL?}ţ3?}ţ3?~˙?~˙?€��?€��������������������������������������������������������������������������������������������������������������������������������������<@­<ŔÁý=Œ?=@Áý=pí>=‘}=¨§=ČÉ2=ŕŢÓ=řůą>‡Š>•> Ÿč>,­X>8¸(>HÉ2>TÔ>`ár>lěB>xůą>‚‚A>ˆˆř>ŽŽa>––ć>œœN>˘Ł>¨¨m>ŽŻ%>´´>şťE>ŔŔ­>ČÉ2>ÎΚ>ÔŐR>ÚÚş>ŕár>ććÚ>ěí‘>ňňú>úű?�€s?ƒĎ?†ƒ? ‰7? Œ“?G?’Ł?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?–ć?•W?”p?”p?“Š?’Ł?’Ł?‘ź?‘ź?Ö?G?G?Ža? z? z? Œ“? Œ“? ‰7?‡j?„ś?‚A>ţ˙>úű>ôôÇ>đń,>ęęt>ććÚ>ŕár>Ü܇>Ö×>ŇŇ5>ĚĚÍ>ČÉ2>şťE>ŽŻ%>˘Ł>––ć>ˆˆř>xůą>`ár>HÉ2>,­X>•=řůą=ČÉ2=‘}=@Áý<ŔÁý����<�sX<€ˆQ<ŔÁý=Œ?=0ł’=PĐh=€ƒ=‘}= Ÿč=¸şÇ=ČÉ2=Řם=čëF>�€s>‡Š>‘}>œN>$Łƒ>,­X>8¸(>@Áý>HÉ2>TÔ>\Ý×>dĺ >lěB>xůą>€€s>„„>ŠŠĆ>ŽŽa>’‘ű>˜˜ł>œœN> Ą8>ŚŚ >ŞŞ;>ŽŻ%>˛˛Ŕ>¸¸(>ź˝>ŔŔ­>ĆÇe>ĘĘ˙>ÎΚ>ÔŐR>ŘŘí>Ü܇>âă?>ććÚ>ęęt>îď_>ôôÇ>řřb>üýL?Z?ƒĎ?…?ˆQ? ŠĆ? Œ“?Ža?‘ź?“Š?•W?˜ł?š€?œN?ŸŠ?!Ąw?#Łě?&Ś ?(¨m?*Şă?,Ź°?/Żd?1ąŮ?3ł§?6ˇ?8¸Đ?:ş?=˝ů??żĆ?AÁ”?DÄđ?FĆ˝?HȊ?JĘ˙?MÍł?Oρ?QŃö?TÔŞ?V×?XŘí?[ŰĄ?]Ţ?_ßă?bâ—?dĺ ?fćÚ?hč§?kě?míĐ?oďž?rňú?tôÇ?v÷<?yůđ?{ű˝?}ţ3?€������<�sX<€ˆQ<ŔÁý=�}Ô= Ľ'=@Áý=`ŢÓ=€ƒ=‘}= Ÿč=°ŽS=ČÉ2=Řם=čëF=řůą>„> ‹D>•>œN>$Łƒ>,­X>4´><ťĂ>HÉ2>PĐh>Xם>`ár>hč§>pďÝ>xůą>€€s>„„>ˆˆř>ŒŒ“>.>––ć>šš€>žž>˘Ł>ŚŚ >ŞŞ;>ŽŻ%>˛˛Ŕ>śś[>şťE>žžŕ>ÂÂz>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ŔŔ­>şťE>´´>ŽŻ%>¨¨m>˘Ł>œœN>––ć>ŽŽa>ˆˆř>‚‚A>xůą>lěB>`ár>TÔ>HÉ2>8¸(>,­X> Ÿč>•>‡Š=řůą=ŕŢÓ=ČÉ2=¨§=‘}=pí>=@Áý=Œ?<ŔÁý<@­������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl5.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015604� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl5 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl5.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:00 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<€ˆQ=Œ?=`ŢÓ=˜˜ł=¸şÇ=ŕŢÓ>„>˜ł>(Š˝><ťĂ>PĐh>dĺ >tö>„„>ŽŽa>˜˜ł>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8>žž>¨¨m>˛˛Ŕ>ź˝>ĆÇe>ĐĐh>ÚÚş>äĺ >îď_>řřb?Z?†ƒ? ‹Ź?Ö?•W?š€?ŸŠ?$¤Ó?)Šü?.Ž}?4´?9šś?>žŕ?DÄđ?IĘ?NΚ?TÔŞ?YŮÓ?^Ţü?dĺ ?ię6?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?xů ?pń,?hč§?aáą?YŮÓ?QŃö?JĘ˙?BÂz?:ş?3ł§?+ŤÉ?#Łě?(¨m?-­—?2˛Ŕ?7ˇé?<źj?AÁ”?FĆ˝?KËć?QŃö?V×?[ŰĄ?`ŕĘ?eĺó?jë?oďž?tôÇ?yůđ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������< Ľ'= Ľ'=€ƒ=¨§=Řם>�€s>•>,­X>@Áý>Xם>lěB>€€s>ŒŒ“>––ć>˘Ł>ŞŞ;>´´>žžŕ>ČÉ2>ŇŇ5>ÚÚş>äĺ >îď_>řřb?Z?†ƒ? ŠĆ?G?”p?™š?žĂ?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?)Šü?/Żd?5ľt?;ť„?AÁ”?GǤ?MÍł?TÔŞ?ZÚş?`ŕĘ?fćÚ?lěę?rňú?xů ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������< Ľ'= Ľ'=pí>= Ÿč=ĐĐh=řůą>‘}>$Łƒ>8¸(>PĐh>dĺ >xůą>†‡+>.>œœN>ŚŚ >°°ň>şťE>ÄÄH>ĐĐh>ÚÚş>äĺ >îď_>řřb?‚A?‡j? Œ“?‘ź?–ć?œN?!Ąw?&Ś ?+ŤÉ?0°ň?6ˇ?;ť„?@Ŕ­?EĹÖ?JĘ˙?PŃ?UՑ?ZÚş?_ßă?dĺ ?jë?oďž?tôÇ?yůđ?€��?zú×?uőŽ?oďž?jë?dĺ ?_ßă?ZÚş?TÔŞ?Oρ?IĘ?DÄđ?>žŕ?9šś?4´?.Ž}?)Šü?#Łě?žĂ?˜ł?“Š?Ža?ˆQ?ƒĎ>úű>đń,>äĺ >ÚÚş>ĐĐh>ÄÄH>şťE>ŽŻ%>¤¤Ó>˜˜ł>ŽŽa>„„>pďÝ>\Ý×>Dŗ>0°ň>˜ł>„=ŕŢÓ=°ŽS=ˆŠH=0ł’<ŔÁý������������������������������������������������������������������������������������������������������������������������������������<€ˆQ=Œ?=`ŢÓ=˜˜ł=ŔÁý=ŕŢÓ>„>˜ł>,­X>@Áý>TÔ>dĺ >xůą>†‡+>.>šš€>¤¤Ó>šš€>ŽŽa>‚‚A>lěB>TÔ><ťĂ>$Łƒ>‘}=đň|=ŔÁý=‘}=@Áý<ŔÁý������������������������������������������������������������������������<@­<ŔÁý=Œ?=@Áý=€ƒ=˜˜ł=°ŽS=ČÉ2=čëF>�€s> ‹D>˜ł>$Łƒ>4´>@Áý>LĚÍ>Xם>hč§>tö>€€s>†‡+>ŽŽa>”•>šš€> Ą8>ŚŚ >ŽŻ%>´´>şťE>ŔŔ­>ČÉ2>ÎΚ>ÔŐR>ÚÚş>ŕár>čč§>îď_>ôôÇ>úű?Z?„ś?‡j? ŠĆ?Ža?‘ź?”p?—Ě?š€?žĂ?!Ąw?$¤Ó?'§‡?+ŤÉ?.Ž}?1ąŮ?4´?7ˇé?;ť„?>žŕ?AÁ”?DÄđ?HȊ?KËć?NΚ?QŃö?UՑ?XŘí?[ŰĄ?^Ţü?aáą?eĺó?hč§?kě?nîˇ?rňú?uőŽ?xů ?{ű˝?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/idl6.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015605� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'idl6 ' / Name of colour table HISTORY (r,g,b) colour table converted from: idl6.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:01 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����<@­<ŕŢÓ=0ł’=pí>=˜˜ł=°ŽS=ĐĐh=đň|>‡Š>˜ł>$Łƒ>4´>Dŗ>TÔ>dĺ >pďÝ>€€s>ˆˆř>.>˜˜ł>žž>ŚŚ >ŽŻ%>śś[>žžŕ>ÄÄH>ĚĚÍ>ÔŐR>Ü܇>äĺ >ęęt>ňňú>úű?Z?…? ‰7? Œ“?Ö?”p?˜ł?œN?ŸŠ?#Łě?'§‡?+ŤÉ?/Żd?2˛Ŕ?6ˇ?:ş?>žŕ?BÂz?EĹÖ?IĘ?MÍł?QŃö?UՑ?XŘí?\Ý/?`ŕĘ?dĺ ?hč§?kě?oďž?sóŕ?wř#?{ű˝?€��?{ű˝?wř#?sóŕ?oďž?kě?fćÚ?bâ—?^Ţü?ZÚş?V×?RŇÝ?MÍł?IĘ?EĹÖ?AÁ”?=˝ů?8¸Đ?4´?0°ň?,Ź°?(¨m?$¤Ó?ŸŠ?›g?—Ě?“Š?G? ŠĆ?†ƒ?‚A>üýL>ôôÇ>ěí‘>âă?>ÚÚş>ŇŇ5>ĘĘ˙>ÂÂz>¸¸(>°°ň>¨¨m> Ą8>˜˜ł>.>†‡+>|ýL>lěB>\Ý×>LĚÍ>8¸(>(Š˝>˜ł>‡Š=đň|=ĐĐh=¨§=ˆŠH=PĐh=Œ?< Ľ'����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<@­<ŕŢÓ=0ł’=pí>=˜˜ł=¸şÇ=Řם=řůą> ‹D>œN>,­X><ťĂ>LĚÍ>\Ý×>lěB>|ýL>†‡+>ŽŽa>––ć>žž>ŚŚ >ŽŻ%>śś[>žžŕ>ĆÇe>ÎΚ>Ö×>ŢŢU>ććÚ>îď_>öö”>ţ˙?ƒĎ?‡j? ‹Ź?G?“Š?—Ě?›g?ŸŠ?#Łě?'§‡?+ŤÉ?/Żd?3ł§?7ˇé?;ť„??żĆ?CÄ ?GǤ?KËć?Oρ?SÓĂ?WŘ?[ŰĄ?_ßă?cä&?gçŔ?kě?oďž?sóŕ?wř#?{ű˝?€��?{ű˝?wř#?sóŕ?oďž?kě?gçŔ?cä&?_ßă?[ŰĄ?WŘ?SÓĂ?Oρ?KËć?GǤ?CÄ ??żĆ?;ť„?7ˇé?3ł§?/Żd?*Şă?&Ś ?"˘^?žĂ?š€?–ć?’Ł?Ža? ŠĆ?†ƒ?‚A>üýL>ôôÇ>ěí‘>äĺ >Ü܇>ÔŐR>ĚĚÍ>ÄÄH>ź˝>´´>ŞŞ;>˘Ł>šš€>’‘ű>ŠŠĆ>‚‚A>tö>dĺ >TÔ>Dŗ>4´>$Łƒ>•>„=čëF=ČÉ2=¨§=ˆŠH=PĐh=Œ?< Ľ'������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<@­<ŕŢÓ=0ł’=pí>=˜˜ł=¸şÇ=Řם=đň|>‡Š>˜ł>(Š˝>8¸(>HÉ2>Xם>dĺ >tö>‚‚A>ŠŠĆ>’‘ű>šš€>˘Ł>ŞŞ;>°°ň>¸¸(>ŔŔ­>ČÉ2>ĐĐh>ŘŘí>ŕár>ććÚ>îď_>öö”>ţ˙?ƒĎ?‡j? ‹Ź?Ža?’Ł?–ć?š€?žĂ?"˘^?&Ś ?*Şă?-­—?1ąŮ?5ľt?9šś?=˝ů?AÁ”?EĹÖ?HȊ?LĚÍ?PŃ?TÔŞ?XŘí?\Ý/?`ŕĘ?cä&?gçŔ?kě?oďž?sóŕ?wř#?{ű˝?€��?{ű˝?wř#?sóŕ?oďž?kě?gçŔ?cä&?_ßă?[ŰĄ?WŘ?SÓĂ?Oρ?KËć?GǤ?CÄ ??żĆ?;ť„?7ˇé?3ł§?/Żd?*Şă?&Ś ?"˘^?žĂ?š€?–ć?’Ł?Ža? ŠĆ?†ƒ?‚A>üýL>ôôÇ>ěí‘>äĺ >Ü܇>ÔŐR>ĚĚÍ>ÄÄH>ź˝>´´>ŞŞ;>˘Ł>šš€>’‘ű>ŠŠĆ>‚‚A>tö>dĺ >TÔ>Dŗ>4´>$Łƒ>•>„=čëF=ČÉ2=¨§=ˆŠH=PĐh=Œ?< Ľ'���� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/isophot.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016434� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'isophot ' / Name of colour table HISTORY (r,g,b) colour table converted from: isophot.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:01 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������������������������������������������������������������������?€��?€��?€������������������������������������������������������������������������������������������?€��?€��?€������������������������������������������������������������������������������������������?€��?€��?€������������������������������������������������������������������������������������������?€��?€��?€������������������=@Áý=ŔÁý>‘}>@Áý>pďÝ>.>¨¨m>ŔŔ­>ŘŘí>đń,?„ś?Ö?œN?(¨m?4´?9šś?>žŕ?CÄ ?€��?€��?€��?WŘ?\Ý/?aáą?fćÚ?kě?pń,?uőŽ?zú×?€��?~˙?~˙?~˙?~˙?}ţ3?}ţ3?}ţ3?}ţ3?|ýL?|ýL?|ýL?|ýL?|ýL?€��?€��?€��?|ýL?|ýL?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������?€��?€��?€������������������=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>‚‚A>’‘ű>˘Ł>˛˛Ŕ>ÂÂz>ŇŇ5>âă?>ôôÇ>ţ˙?„ś? ‰7?€��?€��?€��?žĂ?#Łě?(¨m?-­—?3ł§?8¸Đ?=˝ů?BÂz?HȊ?KËć?Oρ?RŇÝ?V×?ZÚş?]Ţ?aáą?dĺ ?hč§?lěę?oďž?sóŕ?wř#?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?zú×?uőŽ?pń,?lěę?gçŔ?bâ—?^Ţü?YŮÓ?TÔŞ?PŃ?KËć?FĆ˝?BÂz?€��?€��?€��?0°ň?+ŤÉ?'§‡?#Łě?žĂ?š€?–ć?‘ź? z? ‰7?„ś?�€s>řřb>đń,>ŢŢU>ÎΚ>žžŕ>ŽŻ%>žž>ŽŽa>|ýL>\Ý×?€��?€��?€��=¸şÇ=pí><ŕŢÓ����������������������������������������������������������������������������?€��?€��?€������������������������������������������������������������������������������������������?€��?€��?€��>‘}>4´>Xם>€€s>’‘ű>¤¤Ó>¸¸(>ĘĘ˙>Ü܇>đń,>řřb?Z?…? ŠĆ?G?“Š?˜ł?œN?!Ąw?&Ś ?*Şă?/Żd?4´?>žŕ?IĘ?TÔŞ?^Ţü?ię6?tôÇ?€����������������������= Ľ'= Ÿč=đň|> Ÿč>HÉ2>pďÝ>ŽŽa>˘Ł>śś[>ĘĘ˙>ŢŢU>ňňú?„ś?Ža?˜ł?"˘^?,Ź°?7ˇé?€��?€��?€��?`ŕĘ?jë?tôÇ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?uőŽ?pń,?kě?fćÚ?aáą?\Ý/?WŘ?RŇÝ?MÍł?HȊ?CÄ ?>žŕ?9šś?4´?'§‡?›g?G?ƒĎ>îď_>Ö×>žžŕ>ŚŚ ?€��?€��?€��> ‹D=¸şÇ=0ł’����������������������������������������������������������������������������?€��?€��?€������������������������������������������������������������������������������������������?€��?€��?€������������������������������������������������������������������������������������������?€��?€��?€������������������������������������������������������������������������������=@Áý=ŔÁý>‘}?€��?€��?€��>¨¨m>ŔŔ­>ŘŘí>đń,?„ś?Ö?œN?(¨m?4´?9šś??żĆ?EĹÖ?KËć?PŃ?V×?\Ý/?bâ—?gçŔ?míĐ?sóŕ?yůđ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/light.fits������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016056� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'light ' / Name of colour table HISTORY (r,g,b) colour table converted from: light.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:01 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������;€sX<�sX<@­<€ˆQ<€ˆQ< Ľ'<ŔÁý<ŕŢÓ<ŕŢÓ=�}Ô=Œ?=0ł’=@Áý=PĐh=pí>=ˆŠH=˜˜ł=¨§=¸şÇ=ČÉ2=Řם=đň|>„>‘}>œN>(Š˝>8¸(>@Áý>LĚÍ>\Ý×>lěB>|ýL>†‡+>ŽŽa>––ć>žž>¨¨m>˛˛Ŕ>ź˝>ÄÄH>ÎΚ>ÔŐR>ŢŢU>čč§>đń,>řřb?�€s?„ś?‡j? Œ“?Ö?”p?—Ě?š€?žĂ?!Ąw?#Łě?&Ś ?(¨m?+ŤÉ?-­—?0°ň?2˛Ŕ?4´?6ˇ?8¸Đ?:ş?<źj?>žŕ?@Ŕ­?BÂz?DÄđ?FĆ˝?GǤ?IĘ?KËć?MÍł?NΚ?Oρ?QŃö?RŇÝ?SÓĂ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?eĺó?fćÚ?gçŔ?hč§?ię6?ię6?jë?kě?kě?lěę?míĐ?míĐ?nîˇ?oďž?oďž?oďž?pń,?pń,?qň?qň?rňú?rňú?sóŕ?sóŕ?sóŕ?tôÇ?tôÇ?uőŽ?uőŽ?uőŽ?v÷<?v÷<?v÷<?wř#?wř#?xů ?xů ?xů ?yůđ?yůđ?zú×?zú×?zú×?{ű˝?{ű˝?{ű˝?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€��?€������< Ľ'=`ŢÓ=°ŽS=ŕŢÓ> ‹D> Ÿč>8¸(>LĚÍ>\Ý×>pďÝ>€€s>†‡+>.>––ć>œœN>˘Ł>ŞŞ;>ŽŻ%>´´>¸¸(>žžŕ>ÄÄH>ČÉ2>ĚĚÍ>ŇŇ5>Ö×>Ü܇>ŢŢU>âă?>ććÚ>ęęt>îď_>đń,>öö”>řřb>üýL?�€s?Z?‚A?„ś?…?ˆQ? ‰7? ŠĆ? Œ“? z?Ža?G?Ö?’Ł?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?'§‡?(¨m?)Šü?*Şă?+ŤÉ?-­—?-­—?.Ž}?/Żd?0°ň?0°ň?1ąŮ?2˛Ŕ?3ł§?3ł§?4´?5ľt?6ˇ?6ˇ?7ˇé?8¸Đ?8¸Đ?:ş?;ť„?;ť„?<źj?=˝ů?=˝ů?>žŕ?>žŕ??żĆ?@Ŕ­?@Ŕ­?AÁ”?BÂz?BÂz?CÄ ?CÄ ?DÄđ?DÄđ?EĹÖ?GǤ?GǤ?HȊ?HȊ?IĘ?IĘ?JĘ˙?JĘ˙?KËć?KËć?LĚÍ?LĚÍ?MÍł?MÍł?NΚ?NΚ?Oρ?Oρ?PŃ?PŃ?QŃö?QŃö?SÓĂ?SÓĂ?TÔŞ?TÔŞ?UՑ?UՑ?V×?V×?V×?WŘ?WŘ?XŘí?XŘí?YŮÓ?YŮÓ?ZÚş?ZÚş?ZÚş?[ŰĄ?[ŰĄ?\Ý/?\Ý/?\Ý/?]Ţ?]Ţ?^Ţü?^Ţü?^Ţü?`ŕĘ?`ŕĘ?aáą?aáą?aáą?bâ—?bâ—?cä&?cä&?cä&?dĺ ?dĺ ?dĺ ?eĺó?eĺó?eĺó?fćÚ?fćÚ?gçŔ?gçŔ?gçŔ?hč§?hč§?hč§?ię6?ię6?ię6?jë?jë?jë?kě?kě?kě?míĐ?míĐ?míĐ?nîˇ?nîˇ?nîˇ?oďž?oďž?oďž?pń,?pń,?pń,?pń,?qň?qň?qň?rňú?rňú?rňú?sóŕ?sóŕ?sóŕ?tôÇ?tôÇ?tôÇ?tôÇ?uőŽ?uőŽ?uőŽ?v÷<?v÷<?v÷<?v÷<?wř#?wř#?wř#?xů ?xů ?xů ?xů ?zú×?zú×?zú×?zú×?{ű˝?{ű˝?{ű˝?|ýL?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/Makefile.PL�����������������������������������������������������������0000644�0601750�0601001�00000000654�12562522364�016040� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; # files ending in .fits will end up in # PDL/Graphics/LUT/tables/ use ExtUtils::MakeMaker; my @tables = glob( "*.fits" ); WriteMakefile( 'NAME' => 'PDL::Graphics::LUT::tables::DATA', 'VERSION_FROM' => '../../../Basic/Core/Version.pm', 'PM' => { (map {($_,'$(INST_LIBDIR)/'.$_)} @tables) }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); ������������������������������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/manycol.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016411� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'manycol ' / Name of colour table HISTORY (r,g,b) colour table converted from: manycol.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:01 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END >˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ ��������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ ������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ ������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������?9šś?9šś>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ������������������������������������?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň������������������������������������?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?€��?€��?€��?€��?€��?€��?€��?€��?€��?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ������������������������������������?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň������������������������������������?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?€��?€��?€��?€��?€��?€��?€��?€��?€��?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ������������������������������������?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň������������������������������������?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?0°ň?€��?€��?€��?€��?€��?€��?€��?€��?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą��������>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ>˛˛Ŕ?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?9šś?9šś ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/pastel.fits�����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016237� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'pastel ' / Name of colour table HISTORY (r,g,b) colour table converted from: pastel.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:01 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������< Ľ'=`ŢÓ=°ŽS=ŕŢÓ> ‹D> Ÿč>8¸(>LĚÍ>\Ý×>pďÝ>€€s>†‡+>.>––ć>œœN>˘Ł>ŞŞ;>ŽŻ%>´´>¸¸(>žžŕ>ÄÄH>ČÉ2>ĚĚÍ>ŇŇ5>Ö×>Ü܇>ŢŢU>âă?>ććÚ>ęęt>îď_>đń,>öö”>řřb>üýL?�€s?Z?‚A?„ś?…?ˆQ? ‰7? ŠĆ? Œ“? z?Ža?G?Ö?’Ł?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?'§‡?(¨m?)Šü?*Şă?+ŤÉ?-­—?-­—?.Ž}?/Żd?0°ň?0°ň?1ąŮ?2˛Ŕ?3ł§?3ł§?4´?5ľt?6ˇ?6ˇ?7ˇé?8¸Đ?8¸Đ?:ş?;ť„?;ť„?<źj?=˝ů?=˝ů?>žŕ?>žŕ??żĆ?@Ŕ­?@Ŕ­?AÁ”?BÂz?BÂz?CÄ ?CÄ ?DÄđ?DÄđ?EĹÖ?GǤ?GǤ?HȊ?HȊ?IĘ?IĘ?JĘ˙?JĘ˙?KËć?KËć?LĚÍ?LĚÍ?MÍł?MÍł?NΚ?NΚ?Oρ?Oρ?PŃ?PŃ?QŃö?QŃö?SÓĂ?SÓĂ?TÔŞ?TÔŞ?UՑ?UՑ?V×?V×?V×?WŘ?WŘ?XŘí?XŘí?YŮÓ?YŮÓ?ZÚş?ZÚş?ZÚş?[ŰĄ?[ŰĄ?\Ý/?\Ý/?\Ý/?]Ţ?]Ţ?^Ţü?^Ţü?^Ţü?`ŕĘ?`ŕĘ?aáą?aáą?aáą?bâ—?bâ—?cä&?cä&?cä&?dĺ ?dĺ ?dĺ ?eĺó?eĺó?eĺó?fćÚ?fćÚ?gçŔ?gçŔ?gçŔ?hč§?hč§?hč§?ię6?ię6?ię6?jë?jë?jë?kě?kě?kě?míĐ?míĐ?míĐ?nîˇ?nîˇ?nîˇ?oďž?oďž?oďž?pń,?pń,?pń,?pń,?qň?qň?qň?rňú?rňú?rňú?sóŕ?sóŕ?sóŕ?tôÇ?tôÇ?tôÇ?tôÇ?uőŽ?uőŽ?uőŽ?v÷<?v÷<?v÷<?v÷<?wř#?wř#?wř#?xů ?xů ?xů ?xů ?zú×?zú×?zú×?zú×?{ű˝?{ű˝?{ű˝?|ýL?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?€��?€������������������;€sX;€sX;€sX;€sX;€sX<�sX<�sX<�sX<�sX<@­<@­<@­<@­<@­<€ˆQ<€ˆQ<€ˆQ<€ˆQ< Ľ'< Ľ'< Ľ'< Ľ'<ŔÁý<ŔÁý<ŔÁý<ŕŢÓ<ŕŢÓ<ŕŢÓ<ŕŢÓ=�}Ô=�}Ô=�}Ô=Œ?=Œ?=Œ?=Œ?=0ł’=0ł’=0ł’=@Áý=@Áý=@Áý=PĐh=PĐh=PĐh=`ŢÓ=`ŢÓ=`ŢÓ=pí>=pí>=pí>=€ƒ=€ƒ=€ƒ=ˆŠH=ˆŠH=ˆŠH=‘}=‘}=˜˜ł=˜˜ł=˜˜ł= Ÿč= Ÿč=¨§=¨§=¨§=°ŽS=°ŽS=¸şÇ=¸şÇ=¸şÇ=ŔÁý=ŔÁý=ČÉ2=ČÉ2=ĐĐh=ĐĐh=Řם=Řם=ŕŢÓ=ŕŢÓ=ŕŢÓ=đň|=đň|=řůą=řůą>�€s>�€s>„>„>‡Š> ‹D> ‹D>‘}>‘}>•>•>˜ł>˜ł>œN> Ÿč> Ÿč>$Łƒ>$Łƒ>(Š˝>,­X>,­X>0°ň>0°ň>4´>8¸(>8¸(><ťĂ>@Áý>@Áý>HÉ2>LĚÍ>LĚÍ>PĐh>TÔ>TÔ>Xם>\Ý×>`ár>`ár>dĺ >hč§>lěB>lěB>pďÝ>tö>xůą>xůą>|ýL>€€s>‚‚A>„„>†‡+>†‡+>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>Ö×>ŘŘí>ÚÚş>ŢŢU>ŕár>âă?>ććÚ>čč§>ęęt>îď_>đń,>ôôÇ>öö”>úű>üýL?�€s?Z?ƒĎ?„ś?†ƒ?‡j? ‰7? ŠĆ? Œ“?Ža?G?‘ź?“Š?”p?–ć?˜ł?™š?›g?Ü?ŸŠ?!Ąw?"˘^?$¤Ó?&Ś ?(¨m?*Şă?,Ź°?.Ž}?0°ň?2˛Ŕ?4´?6ˇ?8¸Đ?:ş?<źj?>žŕ?@Ŕ­?BÂz?EĹÖ?GǤ?IĘ?KËć?MÍł?PŃ?RŇÝ?TÔŞ?WŘ?YŮÓ?\Ý/?^Ţü?`ŕĘ?cä&?eĺó?hč§?jë?míĐ?pń,?rňú?uőŽ?xů ?zú×?}ţ3����?€��?zú×?qň?ię6?cä&?\Ý/?WŘ?QŃö?LĚÍ?HȊ?CÄ ??żĆ?<źj?7ˇé?4´?1ąŮ?.Ž}?*Şă?(¨m?%Ľš?#Łě?  ?Ü?›g?™š?–ć?”p?‘ź?Ö?Ža? Œ“? ŠĆ?ˆQ?‡j?„ś?ƒĎ?Z>ţ˙>üýL>úű>öö”>ôôÇ>îď_>ěí‘>ęęt>ććÚ>äĺ >âă?>ŕár>ŢŢU>ÚÚş>Ö×>ÔŐR>ŇŇ5>ĐĐh>ÎΚ>ĚĚÍ>ĘĘ˙>ČÉ2>ĆÇe>ÄÄH>ÂÂz>žžŕ>ź˝>şťE>¸¸(>śś[>´´>˛˛Ŕ>°°ň>°°ň>ŽŻ%>ŹŹ>ŞŞ;>¨¨m>¤¤Ó>¤¤Ó>˘Ł> Ą8>žž>žž>œœN>šš€>˜˜ł>˜˜ł>––ć>”•>’‘ű>’‘ű>.>ŽŽa>ŽŽa>ŠŠĆ>ˆˆř>ˆˆř>†‡+>„„>„„>‚‚A>‚‚A>€€s>|ýL>|ýL>xůą>tö>tö>pďÝ>pďÝ>lěB>lěB>hč§>`ár>`ár>\Ý×>\Ý×>Xם>Xם>TÔ>TÔ>PĐh>PĐh>LĚÍ>LĚÍ>HÉ2>HÉ2>Dŗ>Dŗ>@Áý>@Áý><ťĂ><ťĂ>8¸(>8¸(>0°ň>0°ň>,­X>,­X>(Š˝>(Š˝>$Łƒ>$Łƒ>$Łƒ> Ÿč> Ÿč>œN>œN>˜ł>˜ł>•>•>•>‘}>‘}> ‹D> ‹D> ‹D>‡Š>‡Š>„>„>„=řůą=řůą=đň|=đň|=đň|=čëF=čëF=ŕŢÓ=ŕŢÓ=ŕŢÓ=Řם=Řם=Řם=ĐĐh=ĐĐh=ĐĐh=ČÉ2=ČÉ2=ŔÁý=ŔÁý=ŔÁý=¸şÇ=¸şÇ=¸şÇ=°ŽS=°ŽS=°ŽS=¨§=¨§=¨§= Ÿč= Ÿč= Ÿč=‘}=‘}=‘}=ˆŠH=ˆŠH=ˆŠH=€ƒ=€ƒ=€ƒ=pí>=pí>=pí>=pí>=`ŢÓ=`ŢÓ=`ŢÓ=PĐh=PĐh=PĐh=@Áý=@Áý=@Áý=0ł’=0ł’=0ł’=0ł’= Ľ'= Ľ'= Ľ'=Œ?=Œ?=Œ?=Œ?=�}Ô=�}Ô=�}Ô<ŕŢÓ<ŕŢÓ<ŕŢÓ<ŕŢÓ< Ľ'< Ľ'< Ľ'< Ľ'<€ˆQ<€ˆQ<€ˆQ<@­<@­<@­<@­<�sX<�sX<�sX<�sX;€sX;€sX;€sX;€sX�������� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/rainbow.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016410� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'rainbow ' / Name of colour table HISTORY (r,g,b) colour table converted from: rainbow.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:02 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����<ŕŢÓ=pí>=°ŽS=čëF>•>4´>PĐh>lěB>†‡+>––ć>¤¤Ó>´´>ÂÂz>ŇŇ5>ŕár>đń,>ţ˙?‡j?Ža?–ć?Ža?‡j>ţ˙>đń,>ŕár>ŇŇ5>ÂÂz>´´>¤¤Ó>––ć>†‡+>lěB>PĐh>4´>•=čëF=°ŽS=pí><ŕŢÓ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<�sX=Œ?=ˆŠH=ČÉ2>„>(Š˝>LĚÍ>pďÝ>ˆˆř>œœN>ŽŻ%>ŔŔ­>ŇŇ5>äĺ >řřb?…?G?˜ł?"˘^?+ŤÉ?5ľt??żĆ?HȊ?RŇÝ?[ŰĄ?eĺó?nîˇ?yůđ?€��?€��?€��?€��?€��?€��?€��?~˙?zú×?uőŽ?qň?lěę?hč§?dĺ ?_ßă?[ŰĄ?V×?RŇÝ?MÍł?IĘ?DÄđ?AÁ”?=˝ů?9šś?5ľt?1ąŮ?.Ž}?)Šü?&Ś ?"˘^?  ?Ü?›g?žĂ?  ?#Łě?%Ľš?(¨m?*Şă?-­—?/Żd?2˛Ŕ?5ľt?7ˇé?:ş?<źj??żĆ?AÁ”?DÄđ?FĆ˝?IĘ?LĚÍ?NΚ?QŃö?SÓĂ?V×?XŘí?[ŰĄ?]Ţ?`ŕĘ?bâ—?eĺó?hč§?jë?míĐ?oďž?rňú?tôÇ?wř#?yůđ?|ýL?€��������������������������������������������������������������������������������������������������������������������������������������������������������������������������<ŔÁý=@Áý=€ƒ=¨§=ČÉ2=čëF>„>‘}> Ÿč>,­X><ťĂ>HÉ2>Xם>dĺ >pďÝ>€€s>†‡+>ŒŒ“>’‘ű>˜˜ł>žž>¤¤Ó>ŞŞ;>°°ň>śś[>ź˝>ÂÂz>ČÉ2>ÎΚ>ŇŇ5>ŘŘí>ŢŢU>äĺ >ęęt>îď_>ôôÇ>úű>ţ˙?‚A?…?‡j? ŠĆ? z?G?’Ł?•W?—Ě?š€?œN?ŸŠ?!Ąw?$¤Ó?&Ś ?)Šü?+ŤÉ?.Ž}?0°ň?3ł§?5ľt?8¸Đ?:ş?=˝ů??żĆ?BÂz?DÄđ?FĆ˝?IĘ?KËć?NΚ?PŃ?RŇÝ?UՑ?WŘ?ZÚş?\Ý/?^Ţü?aáą?cä&?eĺó?hč§?jë?lěę?oďž?qň?sóŕ?uőŽ?xů ?zú×?|ýL?€��?|ýL?zú×?xů ?uőŽ?sóŕ?qň?oďž?lěę?jë?hč§?eĺó?cä&?aáą?^Ţü?\Ý/?ZÚş?WŘ?UՑ?RŇÝ?PŃ?NΚ?KËć?IĘ?FĆ˝?DÄđ?FĆ˝?IĘ?LĚÍ?Oρ?SÓĂ?WŘ?[ŰĄ?^Ţü?cä&?fćÚ?kě?nîˇ?sóŕ?wř#?|ýL?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?yůđ?oďž?eĺó?[ŰĄ?QŃö?GǤ?=˝ů?3ł§?)Šü?ŸŠ?•W? ‹Ź?‚A>îď_>Ü܇>ČÉ2>´´>˘Ł>ŒŒ“>tö>LĚÍ>,­X>„=ČÉ2=¨§=€ƒ=@Áý<ŔÁý��������������������������������������������������������<�sX<ŕŢÓ=PĐh=¨§=čëF>˜ł>Dŗ>lěB>ŽŽa>ŚŚ >ŔŔ­>Ü܇>řřb? ŠĆ?™š?)Šü?9šś?JĘ˙?[ŰĄ?míĐ?€��>(Š˝><ťĂ>LĚÍ>`ár>tö>„„>ŽŽa>˜˜ł>˘Ł>ŹŹ>śś[>ŔŔ­>ĘĘ˙>ÔŐR>ŢŢU>čč§>ňňú>üýL?ƒĎ? ‰7?Ža?“Š?˜ł?Ü?#Łě?(¨m?-­—?3ł§?8¸Đ?=˝ů?CÄ ?HȊ?MÍł?SÓĂ?XŘí?^Ţü?cä&?ię6?nîˇ?tôÇ?yůđ?€��?yůđ?tôÇ?nîˇ?ię6?cä&?^Ţü?XŘí?SÓĂ?MÍł?HȊ?CÄ ?=˝ů?8¸Đ?3ł§?-­—?(¨m?#Łě?Ü?˜ł?“Š?Ža? ‰7?ƒĎ>üýL>ňňú>čč§>ŢŢU>ÔŐR>ĘĘ˙>ŔŔ­>śś[>ŹŹ>˘Ł>˜˜ł>ŽŽa>„„>tö>`ár>LĚÍ><ťĂ>(Š˝>•>„=ŕŢÓ=ŔÁý=˜˜ł=pí>=0ł’<ŕŢÓ<@­��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<�sX<ŕŢÓ=PĐh=¨§=čëF>˜ł>Dŗ>lěB>ŽŽa>ŚŚ >ŔŔ­>Ü܇>řřb? ŠĆ?™š?)Šü?9šś?JĘ˙?[ŰĄ?míĐ?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/rainbow1.fits���������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016471� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'rainbow1 ' / Name of colour table HISTORY (r,g,b) colour table converted from: rainbow1.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:02 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����<ŕŢÓ=pí>=°ŽS=čëF>•>4´>PĐh>lěB>†‡+>––ć>¤¤Ó>´´>ÂÂz>ŇŇ5>ŕár>đń,>ţ˙?‡j?Ža?–ć?Ža?‡j>ţ˙>đń,>ŕár>ŇŇ5>ÂÂz>´´>¤¤Ó>––ć>†‡+>lěB>PĐh>4´>•=čëF=°ŽS=pí><ŕŢÓ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<�sX<€ˆQ<ŔÁý=�}Ô=0ł’=`ŢÓ=ˆŠH= Ÿč=¸şÇ=ĐĐh=čëF>�€s> ‹D>˜ł>(Š˝>LĚÍ>pďÝ>ˆˆř>œœN>ŽŻ%>ŔŔ­>ŇŇ5>äĺ >řřb?…?G?˜ł?"˘^?+ŤÉ?5ľt??żĆ?HȊ?RŇÝ?[ŰĄ?eĺó?nîˇ?yůđ?€��?€��?€��?€��?€��?€��?€��?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?}ţ3?{ű˝?yůđ?wř#?uőŽ?sóŕ?qň?oďž?míĐ?kě?ię6?gçŔ?eĺó?cä&?aáą?_ßă?]Ţ?[ŰĄ?YŮÓ?WŘ?UՑ?SÓĂ?QŃö?Oρ?MÍł?KËć?IĘ?GǤ?EĹÖ?CÄ ?AÁ”??żĆ?=˝ů?;ť„����������������������������������������������������������������������������������������������������������������������������������������������������������������������������<�sX<€ˆQ<ŔÁý=�}Ô= Ľ'=PĐh=€ƒ= Ÿč=ČÉ2=đň|> ‹D> Ÿč>4´>HÉ2>\Ý×>pďÝ>‚‚A>ŠŠĆ>’‘ű>šš€>¤¤Ó>ŞŞ;>°°ň>śś[>ź˝>ÂÂz>ČÉ2>ÎΚ>ŇŇ5>ŘŘí>ŢŢU>äĺ >ęęt>îď_>ôôÇ>úű>ţ˙?‚A?…?‡j? ŠĆ? z?G?’Ł?•W?—Ě?š€?œN?ŸŠ?!Ąw?$¤Ó?&Ś ?)Šü?+ŤÉ?.Ž}?0°ň?3ł§?5ľt?8¸Đ?:ş?=˝ů??żĆ?BÂz?DÄđ?FĆ˝?IĘ?KËć?NΚ?PŃ?RŇÝ?UՑ?WŘ?ZÚş?\Ý/?^Ţü?aáą?cä&?eĺó?hč§?jë?lěę?oďž?qň?sóŕ?uőŽ?xů ?zú×?|ýL?€��?|ýL?zú×?xů ?uőŽ?sóŕ?qň?oďž?lěę?jë?hč§?eĺó?cä&?aáą?^Ţü?\Ý/?ZÚş?WŘ?UՑ?RŇÝ?PŃ?NΚ?KËć?IĘ?FĆ˝?DÄđ?FĆ˝?IĘ?LĚÍ?Oρ?SÓĂ?WŘ?[ŰĄ?^Ţü?cä&?fćÚ?kě?nîˇ?sóŕ?wř#?|ýL?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?yůđ?oďž?eĺó?[ŰĄ?QŃö?GǤ?=˝ů?3ł§?)Šü?ŸŠ?•W? ‹Ź?‚A>îď_>Ü܇>ČÉ2>´´>˘Ł>ŒŒ“>tö>LĚÍ>,­X>„=ČÉ2=¨§=€ƒ=@Áý<ŔÁý��������������������������������������������������������������������������������������������������������������������������������������������>(Š˝><ťĂ>LĚÍ>`ár>tö>„„>ŽŽa>˜˜ł>˘Ł>ŹŹ>śś[>ŔŔ­>ĘĘ˙>ÔŐR>ŢŢU>čč§>ňňú>üýL?ƒĎ? ‰7?Ža?“Š?˜ł?Ü?#Łě?(¨m?-­—?3ł§?8¸Đ?=˝ů?CÄ ?HȊ?MÍł?SÓĂ?XŘí?^Ţü?cä&?ię6?nîˇ?tôÇ?yůđ?€��?yůđ?tôÇ?nîˇ?ię6?cä&?^Ţü?YŮÓ?TÔŞ?Oρ?JĘ˙?EĹÖ?@Ŕ­?;ť„?6ˇ?1ąŮ?,Ź°?(¨m?$¤Ó?  ?œN?˜ł?”p?Ö? Œ“?ˆQ?„ś?�€s>řřb>đń,>ęęt>äĺ >ŢŢU>ŘŘí>ŇŇ5>ĚĚÍ>ĆÇe>ŔŔ­>şťE>´´>ŽŻ%>¨¨m>˘Ł>œœN>––ć>.>ŠŠĆ>„„>|ýL>pďÝ>dĺ >Xם>LĚÍ>@Áý>4´>(Š˝>œN>‘}>„=đň|=ĐĐh=°ŽS=‘}=`ŢÓ= Ľ'<ŔÁý�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/rainbow2.fits���������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016472� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'rainbow2 ' / Name of colour table HISTORY (r,g,b) colour table converted from: rainbow2.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:02 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>€€s>.> Ą8>°°ň>ŔŔ­>ĐĐh>ŕár>đń,?�€s?ˆQ?Ö?˜ł?  ?(¨m?0°ň?8¸Đ?@Ŕ­?HȊ?PŃ?XŘí?`ŕĘ?hč§?pń,?xů ?€��?wř#?oďž?gçŔ?_ßă?WŘ?Oρ?GǤ??żĆ?7ˇé?/Żd?'§‡?ŸŠ?—Ě?G?‡j>ţ˙>îď_>ŢŢU>ÎΚ>žžŕ>ŽŻ%>žž>ŽŽa>|ýL>\Ý×><ťĂ>œN=řůą=¸şÇ=pí><ŕŢÓ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>€€s>.> Ą8>°°ň>ŔŔ­>ĐĐh>ŕár>đń,?�€s?ˆQ?Ö?˜ł?  ?(¨m?0°ň?8¸Đ?@Ŕ­?HȊ?PŃ?XŘí?`ŕĘ?hč§?pń,?xů ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>€€s>.> Ą8>°°ň>ŔŔ­>ĐĐh>ŕár>đń,?�€s?ˆQ?Ö?˜ł?  ?(¨m?0°ň?8¸Đ?@Ŕ­?HȊ?PŃ?XŘí?`ŕĘ?hč§?pń,?xů ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?{ű˝?wř#?sóŕ?oďž?kě?gçŔ?cä&?_ßă?[ŰĄ?WŘ?SÓĂ?Oρ?KËć?GǤ?CÄ ??żĆ?;ť„?7ˇé?3ł§?/Żd?+ŤÉ?'§‡?#Łě?ŸŠ?›g?—Ě?“Š?G? ‹Ź?‡j?ƒĎ>ţ˙>öö”>îď_>ććÚ>ŢŢU>Ö×>ÎΚ>ĆÇe>žžŕ>śś[>ŽŻ%>ŚŚ >žž>––ć>ŽŽa>†‡+>|ýL>lěB>\Ý×>LĚÍ><ťĂ>,­X>œN> ‹D=řůą=Řם=¸şÇ=˜˜ł=pí>=0ł’<ŕŢÓ<@­����=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>€€s>.> Ą8>°°ň>ŔŔ­>ĐĐh>ŕár>đń,?�€s?ˆQ?Ö?˜ł?  ?(¨m?0°ň?8¸Đ?@Ŕ­?HȊ?PŃ?XŘí?`ŕĘ?hč§?pń,?xů ����=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>€€s>.> Ą8>°°ň>ŔŔ­>ĐĐh>ŕár>đń,?�€s?ˆQ?Ö?˜ł?  ?(¨m?0°ň?8¸Đ?@Ŕ­?HȊ?PŃ?XŘí?`ŕĘ?hč§?pń,?xů ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?wř#?oďž?gçŔ?_ßă?WŘ?Oρ?GǤ??żĆ?7ˇé?/Żd?'§‡?ŸŠ?—Ě?G?‡j>ţ˙>îď_>ŢŢU>ÎΚ>žžŕ>ŽŻ%>žž>ŽŽa>|ýL>\Ý×><ťĂ>œN=řůą=¸şÇ=pí><ŕŢÓ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>€€s>.> Ą8>°°ň>ŔŔ­>ĐĐh>ŕár>đń,?�€s?ˆQ?Ö?˜ł?  ?(¨m?0°ň?8¸Đ?@Ŕ­?HȊ?PŃ?XŘí?`ŕĘ?hč§?pń,?xů ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/rainbow3.fits���������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016473� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'rainbow3 ' / Name of colour table HISTORY (r,g,b) colour table converted from: rainbow3.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:02 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=@Áý=ŔÁý>‘}>@Áý>pďÝ>.>¨¨m>ŔŔ­>ŘŘí>đń,?„ś?Ö?œN?(¨m?4´?9šś?>žŕ?CÄ ?HȊ?MÍł?RŇÝ?WŘ?\Ý/?aáą?fćÚ?kě?pń,?uőŽ?zú×?€��?~˙?~˙?~˙?~˙?~˙?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������������������������������������������������������������������������������������������=�}Ô=€ƒ=ŔÁý>�€s> Ÿč>@Áý>`ár>‚‚A>’‘ű>˘Ł>˛˛Ŕ>ÂÂz>ŇŇ5>âă?>ôôÇ>ţ˙?„ś? ‰7?Ža?”p?™š?žĂ?#Łě?(¨m?.Ž}?3ł§?8¸Đ?=˝ů?BÂz?HȊ?KËć?Oρ?SÓĂ?V×?ZÚş?^Ţü?aáą?eĺó?ię6?lěę?pń,?tôÇ?wř#?{ű˝?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?zú×?uőŽ?qň?lěę?gçŔ?cä&?^Ţü?YŮÓ?UՑ?PŃ?KËć?GǤ?BÂz?=˝ů?9šś?4´?0°ň?,Ź°?'§‡?#Łě?ŸŠ?š€?–ć?’Ł? z? ‰7?…?�€s>řřb>đń,>ŕár>ĐĐh>ŔŔ­>°°ň> Ą8>.>€€s>\Ý×><ťĂ>œN=řůą=¸şÇ=pí><ŕŢÓ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=Œ?=‘}=Řם>‘}>8¸(>\Ý×>€€s>’‘ű>ŚŚ >¸¸(>ĘĘ˙>Ü܇>đń,>řřb?Z?…? ŠĆ?G?“Š?˜ł?œN?!Ąw?&Ś ?*Şă?/Żd?4´?>žŕ?IĘ?TÔŞ?^Ţü?ię6?tôÇ?€����������������������= Ľ'= Ÿč=đň|> Ÿč>LĚÍ>tö>ŽŽa>˘Ł>śś[>ĚĚÍ>ŕár>ôôÇ?„ś?Ža?™š?#Łě?-­—?7ˇé?AÁ”?LĚÍ?V×?`ŕĘ?jë?tôÇ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?zú×?uőŽ?pń,?kě?fćÚ?aáą?\Ý/?WŘ?RŇÝ?MÍł?HȊ?CÄ ?>žŕ?9šś?4´?(¨m?œN?Ö?„ś>đń,>ŘŘí>ŔŔ­>ŚŚ >ŽŽa>lěB><ťĂ> ‹D=¸şÇ=0ł’����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=@Áý=ŔÁý>‘}>@Áý>pďÝ>.>¨¨m>ŔŔ­>ŘŘí>đń,?„ś?Ö?œN?(¨m?4´?9šś??żĆ?EĹÖ?KËć?PŃ?V×?\Ý/?bâ—?gçŔ?míĐ?sóŕ?yůđ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/rainbow4.fits���������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016474� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'rainbow4 ' / Name of colour table HISTORY (r,g,b) colour table converted from: rainbow4.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:03 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=PĐh=Řם>$Łƒ>\Ý×>ŠŠĆ>ŚŚ >ŔŔ­>Ü܇>řřb? ŠĆ?˜ł?&Ś ?4´?9šś??żĆ?EĹÖ?KËć?PŃ?V×?\Ý/?bâ—?gçŔ?míĐ?sóŕ?yůđ?€��?~˙?~˙?~˙?~˙?}ţ3?}ţ3?}ţ3?}ţ3?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?}ţ3?}ţ3?}ţ3?}ţ3?~˙?~˙?~˙?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=Œ?=‘}=ŕŢÓ>•>8¸(>`ár>‚‚A>––ć>¨¨m>şťE>ÎΚ>ŕár>ôôÇ?�€s?†ƒ? Œ“?’Ł?˜ł?žĂ?$¤Ó?*Şă?0°ň?6ˇ?<źj?BÂz?HȊ?LĚÍ?PŃ?TÔŞ?XŘí?]Ţ?aáą?eĺó?ię6?nîˇ?rňú?v÷<?zú×?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?yůđ?tôÇ?nîˇ?ię6?dĺ ?^Ţü?YŮÓ?SÓĂ?NΚ?IĘ?CÄ ?>žŕ?9šś?4´?/Żd?*Şă?%Ľš?  ?›g?–ć?‘ź? Œ“?‡j?‚A>úű>đń,>Ü܇>ĘĘ˙>¸¸(>ŚŚ >’‘ű>€€s>\Ý×>8¸(>‘}=Řם=‘}=Œ?��������������������������������������������������������������������������������������������������������������������=Œ?=‘}=Řם>‘}>8¸(>\Ý×>€€s>’‘ű>ŚŚ >¸¸(>ĘĘ˙>Ü܇>đń,>řřb?Z?…? ŠĆ?G?“Š?˜ł?œN?!Ąw?&Ś ?*Şă?/Żd?4´?>žŕ?IĘ?TÔŞ?^Ţü?ię6?tôÇ?€��<@­<ŕŢÓ=0ł’=pí>=˜˜ł=¸şÇ=Řם=řůą> ‹D>œN>,­X><ťĂ>LĚÍ>Xם>hč§>xůą>„„>ŒŒ“>”•>œœN>¤¤Ó>ŹŹ>´´>ź˝>ÄÄH>ĚĚÍ>ŇŇ5>ÚÚş>âă?>ęęt>ňňú>úű?Z?…? ‰7? z?‘ź?•W?™š?œN?  ?$¤Ó?(¨m?,Ź°?0°ň?4´?8¸Đ?<źj?@Ŕ­?DÄđ?HȊ?LĚÍ?Oρ?SÓĂ?WŘ?[ŰĄ?_ßă?cä&?gçŔ?kě?oďž?sóŕ?wř#?{ű˝?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?yůđ?sóŕ?míĐ?gçŔ?bâ—?\Ý/?V×?PŃ?KËć?EĹÖ??żĆ?9šś?4´?&Ś ?˜ł? ŠĆ>řřb>Ü܇>ŔŔ­>ŚŚ >ŠŠĆ>\Ý×>$Łƒ=Řם=PĐh��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=PĐh=Řם>$Łƒ>\Ý×>ŠŠĆ>ŚŚ >ŔŔ­>Ü܇>řřb? ŠĆ?˜ł?&Ś ?4´?9šś??żĆ?EĹÖ?KËć?PŃ?V×?\Ý/?bâ—?gçŔ?míĐ?sóŕ?yůđ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/ramp.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015706� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'ramp ' / Name of colour table HISTORY (r,g,b) colour table converted from: ramp.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:03 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?˜ł?™š?˜ł?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€������;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?˜ł?™š?˜ł?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€������;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?˜ł?™š?˜ł?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/random.fits�����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016227� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'random ' / Name of colour table HISTORY (r,g,b) colour table converted from: random.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:03 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������>đń,>đń,>đń,?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€��?|ýL?|ýL?{ű˝?{ű˝?{ű˝?€��?€��?4´?4´����������������������������>đń,>đń,>đń,?  ?  ?HȊ?HȊ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?kě?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?(¨m?  ?  ?  ?  ?  ?  ?  ?  ?  >đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>†‡+����������������������������������������������������������������������������������������������������������������>¸¸(?4´?4´?4´?4´?4´?4´?4´?4´?4´?{ű˝?€��?€��?€��?€��?€��?€��?€��?€��?~˙?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?ię6?4´?4´?4´?4´?4´?4´?4´?4´?4´?ˆQ>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>đń,>đń,?9šś?9šś?Oρ?YŮÓ?YŮÓ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?HȊ?HȊ?HȊ?  ?  >đń,>đń,?4´?4´?DÄđ?\Ý/?\Ý/?€��?€��?€��?€��?eĺó?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?4´?4´?4´?4´?4´?4´?4´?4´?4´?žĂ>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?˜ł?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?`ŕĘ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?yůđ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?FĆ˝?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>ź˝��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?4´?4´?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?fćÚ?fćÚ?€��?€��?4´?4´?„ś����������������������������������������������������������������?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?=˝ů?4´?4´?4´?4´?4´?4´?4´?4´?'§‡����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>îď_?4´?4´?4´?4´?4´?4´?4´?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€��?xů ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?_ßă?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?MÍł?4´?4´?4´?4´?4´?4´?4´?4´?4´> ‹D������������������������������������ ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/random1.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016310� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'random1 ' / Name of colour table HISTORY (r,g,b) colour table converted from: random1.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:03 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������>lěB>lěB>lěB>lěB>lěB>lěB>lěB>lěB>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>lěB>lěB>lěB>lěB>lěB>lěB>lěB>lěB������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ>˜ł>˜ł>˜ł>˜ł>˜ł>˜ł>˜ł>˜ł>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5>ŇŇ5?5ľt?5ľt?5ľt?5ľt?5ľt?5ľt?5ľt?5ľt?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?yůđ?yůđ?yůđ?yůđ?yůđ?yůđ?yůđ?yůđ?ię6?ię6?ię6?ię6?ię6?ię6?ię6?ię6?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?IĘ?IĘ?IĘ?IĘ?IĘ?IĘ?IĘ?IĘ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=PĐh=PĐh=PĐh=PĐh=PĐh=PĐh=PĐh=PĐh>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí?‚A?‚A?‚A?‚A?‚A?‚A?‚A?‚A?—Ě?—Ě?—Ě?—Ě?—Ě?—Ě?—Ě?—Ě?+ŤÉ?+ŤÉ?+ŤÉ?+ŤÉ?+ŤÉ?+ŤÉ?+ŤÉ?+ŤÉ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ??żĆ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?RŇÝ?eĺó?eĺó?eĺó?eĺó?eĺó?eĺó?eĺó?eĺó?xů ?xů ?xů ?xů ?xů ?xů ?xů ?xů ?sóŕ?sóŕ?sóŕ?sóŕ?sóŕ?sóŕ?sóŕ?sóŕ?aáą?aáą?aáą?aáą?aáą?aáą?aáą?aáą?NΚ?NΚ?NΚ?NΚ?NΚ?NΚ?NΚ?NΚ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?Oρ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?3ł§?3ł§?3ł§?3ł§?3ł§?3ł§?3ł§?3ł§>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2>ČÉ2=ČÉ2=ČÉ2=ČÉ2=ČÉ2=ČÉ2=ČÉ2=ČÉ2=ČÉ2��������������������������������������������������������������������������������������������������������������������������������>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?MÍł?MÍł?MÍł?MÍł?MÍł?MÍł?MÍł?MÍł?yůđ?yůđ?yůđ?yůđ?yůđ?yůđ?yůđ?yůđ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?Ö?Ö?Ö?Ö?Ö?Ö?Ö?Ö>äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >äĺ >´´>´´>´´>´´>´´>´´>´´>´´>„„>„„>„„>„„>„„>„„>„„>„„>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝>(Š˝=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ=`ŢÓ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������ ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/random2.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016311� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'random2 ' / Name of colour table HISTORY (r,g,b) colour table converted from: random2.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:04 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������������������;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX������������������������������������������������������������������������������������������������������������������������>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?  ?  ?  ?  ?  ?  ?  ?  ?  ?  >đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|=đň|>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?˜ł?˜ł?˜ł?˜ł?˜ł?˜ł?˜ł?˜ł?˜ł?˜ł?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������������������������������������������;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX;€sX>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  >đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ>pďÝ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/random3.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016312� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'random3 ' / Name of colour table HISTORY (r,g,b) colour table converted from: random3.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:04 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,������������������������������������������������������������������������������������������������������������������������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€������������������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/random4.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016313� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'random4 ' / Name of colour table HISTORY (r,g,b) colour table converted from: random4.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:04 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������������������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´������������������������������������������������������������������������������������������������������������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?9šś?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?YŮÓ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  >đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?€��?€��?€��?€��������������������������������������������������?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?\Ý/?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?fćÚ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?4´?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/random5.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016314� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'random5 ' / Name of colour table HISTORY (r,g,b) colour table converted from: random5.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:04 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������;€sX;€sX<�sX<�sX<@­<€ˆQ<€ˆQ< Ľ'< Ľ'<ŔÁý<ŕŢÓ<ŕŢÓ=�}Ô=Œ?=Œ?= Ľ'=0ł’=@Áý=@Áý=PĐh=`ŢÓ=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=‘}=˜˜ł= Ÿč=¨§=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=đň|=řůą>�€s>„>‡Š> ‹D>‘}>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?`ŕĘ?aáą?bâ—?cä&?dĺ ?fćÚ?gçŔ?hč§?ię6?jë?kě?míĐ?nîˇ?oďž?pń,?qň?sóŕ?tôÇ?uőŽ?v÷<?wř#?yůđ?zú×?{ű˝?|ýL?}ţ3?€��������������������������������������������������<�sX<€ˆQ<ŕŢÓ= Ľ'=PĐh=ˆŠH=¨§=ČÉ2=đň|=ČÉ2=¨§=ˆŠH=PĐh= Ľ'<ŕŢÓ<€ˆQ<�sX��������;€sX<@­<ŔÁý= Ľ'=`ŢÓ=‘}=¸şÇ=ŕŢÓ>‡Š> Ÿč>‡Š=ŕŢÓ=¸şÇ=‘}=`ŢÓ= Ľ'<ŔÁý<@­;€sX����;€sX<€ˆQ=�}Ô=@Áý=ˆŠH=¸şÇ=čëF> ‹D>(Š˝>HÉ2>(Š˝> ‹D=čëF=¸şÇ=ˆŠH=@Áý=�}Ô<€ˆQ;€sX����<�sX<ŔÁý=0ł’=ˆŠH=ŔÁý>�€s> Ÿč>HÉ2>lěB>ŒŒ“>lěB>HÉ2> Ÿč>�€s=ŔÁý=ˆŠH=0ł’<ŔÁý<�sX����<�sX=�}Ô=`ŢÓ=°ŽS=řůą>$Łƒ>PĐh>€€s>˜˜ł>´´>˜˜ł>€€s>PĐh>$Łƒ=řůą=°ŽS=`ŢÓ=�}Ô<�sX����<@­=Œ?=‘}=Řם>˜ł>LĚÍ>€€s>œœN>şťE>Ü܇>şťE>œœN>€€s>LĚÍ>˜ł=Řם=‘}=Œ?<@­����<€ˆQ=0ł’=¨§>�€s>4´>pďÝ>˜˜ł>şťE>Ü܇?‚A>Ü܇>şťE>˜˜ł>pďÝ>4´>�€s=¨§=0ł’<€ˆQ����<€ˆQ=PĐh=ŔÁý>•>TÔ>ŠŠĆ>ŽŻ%>Ö×?�€s?–ć?�€s>Ö×>ŽŻ%>ŠŠĆ>TÔ>•=ŔÁý=PĐh<€ˆQ����< Ľ'=pí>=Řם>,­X>pďÝ>žž>ĆÇe>ňňú?‘ź?*Şă?‘ź>ňňú>ĆÇe>žž>pďÝ>,­X=Řם=pí>< Ľ'����<ŔÁý=€ƒ=řůą>@Áý>†‡+>°°ň>ŢŢU?‡j?"˘^?>žŕ?"˘^?‡j>ŢŢU>°°ň>†‡+>@Áý=řůą=€ƒ<ŔÁý����<ŔÁý=‘}>‡Š>TÔ>”•>ÂÂz>ôôÇ?–ć?3ł§?RŇÝ?3ł§?–ć>ôôÇ>ÂÂz>”•>TÔ>‡Š=‘}<ŔÁý����<ŕŢÓ= Ÿč>•>hč§>˘Ł>ÔŐR?†ƒ?$¤Ó?DÄđ?fćÚ?DÄđ?$¤Ó?†ƒ>ÔŐR>˘Ł>„„>lěB>tö>ŽŽa>´´>ěí‘?•W?6ˇ?YŮÓ?€��?€��?}ţ3?|ýL?{ű˝?zú×?yůđ?wř#?v÷<?uőŽ?tôÇ?sóŕ?qň?pń,?oďž?nîˇ?míĐ?kě?jë?ię6?hč§?gçŔ?fćÚ?dĺ ?cä&?bâ—?aáą?`ŕĘ?^Ţü?]Ţ?\Ý/?[ŰĄ?ZÚş?YŮÓ?WŘ?V×?UՑ?TÔŞ?SÓĂ?RŇÝ?PŃ?Oρ?NΚ?MÍł?LĚÍ?KËć?JĘ˙?HȊ?GǤ?FĆ˝?EĹÖ?DÄđ?CÄ ?AÁ”?@Ŕ­??żĆ?>žŕ?=˝ů?<źj?;ť„?9šś?8¸Đ?7ˇé?6ˇ?5ľt?4´?3ł§?2˛Ŕ?0°ň?/Żd?.Ž}?-­—?,Ź°?+ŤÉ?*Şă?)Šü?'§‡?&Ś ?%Ľš?$¤Ó?#Łě?"˘^?!Ąw?  ?žĂ?Ü?œN?›g?š€?™š?˜ł?—Ě?–ć?•W?“Š?’Ł?‘ź?Ö?G?Ža? z? Œ“? ‹Ź? ŠĆ? ‰7?‡j?†ƒ?…?„ś?ƒĎ?‚A?Z?�€s>ţ˙>üýL>úű>řřb>öö”>ôôÇ>đń,>îď_>ěí‘>ęęt>čč§>ććÚ>äĺ >âă?>ŕár>ŢŢU>Ü܇>ÚÚş>ŘŘí>Ö×>ÔŐR>ŇŇ5>ĐĐh>ÎΚ>ĚĚÍ>ĘĘ˙>ČÉ2>ĆÇe>ÄÄH>ÂÂz>ŔŔ­>žžŕ>şťE>¸¸(>śś[>´´>˛˛Ŕ>°°ň>ŽŻ%>ŹŹ>ŞŞ;>¨¨m>ŚŚ >¤¤Ó>˘Ł> Ą8>žž>œœN>šš€>˜˜ł>˜˜ł>––ć>”•>’‘ű>.>ŽŽa>ŒŒ“>ŠŠĆ>ˆˆř>†‡+>„„>‚‚A>€€s>|ýL>xůą>tö>pďÝ>lěB>hč§>dĺ >`ár>\Ý×>Xם>Xם>TÔ>PĐh>LĚÍ>HÉ2>Dŗ>@Áý><ťĂ>8¸(>4´>0°ň>0°ň>,­X>(Š˝>$Łƒ> Ÿč>œN>˜ł>•>‘}>‘}> ‹D>‡Š>„>�€s=řůą=đň|=đň|=čëF=ŕŢÓ=Řם=ĐĐh=ČÉ2=ČÉ2=ŔÁý=¸şÇ=°ŽS=¨§=¨§= Ÿč=˜˜ł=‘}=‘}=ˆŠH=€ƒ=pí>=`ŢÓ=`ŢÓ=PĐh=@Áý=@Áý=0ł’= Ľ'=Œ?=Œ?=�}Ô<ŕŢÓ<ŕŢÓ<ŔÁý< Ľ'< Ľ'<€ˆQ<€ˆQ<@­<�sX<�sX;€sX;€sX������������ ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/random6.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016315� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'random6 ' / Name of colour table HISTORY (r,g,b) colour table converted from: random6.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:04 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m>¨¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?(¨m?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL����>‘}>.>ŘŘí?Ö?4´?XŘí?|ýL��������������������������������>‘}>‘}>‘}>‘}>‘}>‘}>‘}>‘}>.>.>.>.>.>.>.>.>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí?Ö?Ö?Ö?Ö?Ö?Ö?Ö?Ö?4´?4´?4´?4´?4´?4´?4´?4´?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL��������������������������������>‘}>‘}>‘}>‘}>‘}>‘}>‘}>‘}>.>.>.>.>.>.>.>.>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí?Ö?Ö?Ö?Ö?Ö?Ö?Ö?Ö?4´?4´?4´?4´?4´?4´?4´?4´?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL��������������������������������>‘}>‘}>‘}>‘}>‘}>‘}>‘}>‘}>.>.>.>.>.>.>.>.>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí?Ö?Ö?Ö?Ö?Ö?Ö?Ö?Ö?4´?4´?4´?4´?4´?4´?4´?4´?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL��������������������������������>‘}>‘}>‘}>‘}>‘}>‘}>‘}>‘}>.>.>.>.>.>.>.>.>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí>ŘŘí?Ö?Ö?Ö?Ö?Ö?Ö?Ö?Ö?4´?4´?4´?4´?4´?4´?4´?4´?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?XŘí?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/real.fits�������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015672� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'real ' / Name of colour table HISTORY (r,g,b) colour table converted from: real.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:05 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END <�sX<€ˆQ<ŔÁý=�}Ô= Ľ'=@Áý=`ŢÓ=€ƒ=‘}= Ÿč=°ŽS=ŔÁý=ĐĐh=ŕŢÓ=đň|>�€s>‡Š>‘}>˜ł> Ÿč>(Š˝>0°ň>8¸(>@Áý>HÉ2>PĐh>Xם>`ár>hč§>pďÝ>xůą>€€s>„„>ˆˆř>ŒŒ“>.>”•>˜˜ł>œœN> Ą8>¤¤Ó>¨¨m>ŹŹ>°°ň>´´>¸¸(>ź˝>ŔŔ­>ÄÄH>ČÉ2>ĚĚÍ>ĐĐh>ÔŐR>ŘŘí>Ü܇>ŕár>äĺ >čč§>ěí‘>đń,>ôôÇ>řřb>üýL?�€s?‚A?„ś?†ƒ?ˆQ? ŠĆ? Œ“?Ža?Ö?’Ł?”p?–ć?˜ł?š€?œN?žĂ?  ?"˘^?$¤Ó?&Ś ?(¨m?*Şă?,Ź°?.Ž}?0°ň?2˛Ŕ?4´?6ˇ?8¸Đ?:ş?<źj?>žŕ?@Ŕ­?BÂz?DÄđ?FĆ˝?HȊ?JĘ˙?LĚÍ?NΚ?PŃ?RŇÝ?TÔŞ?V×?XŘí?ZÚş?\Ý/?^Ţü?`ŕĘ?bâ—?dĺ ?fćÚ?hč§?jë?lěę?nîˇ?pń,?rňú?tôÇ?v÷<?xů ?zú×?|ýL?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<�sX<€ˆQ<ŔÁý=�}Ô= Ľ'=@Áý=`ŢÓ=€ƒ=‘}= Ÿč=°ŽS=ŔÁý=ĐĐh=ŕŢÓ=đň|>�€s>‡Š>‘}>˜ł> Ÿč>(Š˝>0°ň>8¸(>@Áý>HÉ2>PĐh>Xם>`ár>hč§>pďÝ>xůą>€€s>„„>ˆˆř>ŒŒ“>.>”•>˜˜ł>œœN> Ą8>¤¤Ó>¨¨m>ŹŹ>°°ň>´´>¸¸(>ź˝>ŔŔ­>ÄÄH>ČÉ2>ĚĚÍ>ĐĐh>ÔŐR>ŘŘí>Ü܇>ŕár>äĺ >čč§>ěí‘>đń,>ôôÇ>řřb>üýL?�€s?‚A?„ś?†ƒ?ˆQ? ŠĆ? Œ“?Ža?Ö?’Ł?”p?–ć?˜ł?š€?œN?žĂ?  ?"˘^?$¤Ó?&Ś ?(¨m?*Şă?,Ź°?.Ž}?0°ň?2˛Ŕ?4´?6ˇ?8¸Đ?:ş?<źj?>žŕ?@Ŕ­?BÂz?DÄđ?FĆ˝?HȊ?JĘ˙?LĚÍ?NΚ?PŃ?RŇÝ?TÔŞ?V×?XŘí?ZÚş?\Ý/?^Ţü?`ŕĘ?bâ—?dĺ ?fćÚ?hč§?jë?lěę?nîˇ?pń,?rňú?tôÇ?v÷<?xů ?zú×?|ýL?~˙?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/red.fits��������������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�015521� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'red ' / Name of colour table HISTORY (r,g,b) colour table converted from: red.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:05 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŽŻ%>°°ň>˛˛Ŕ>´´>śś[>¸¸(>şťE>ź˝>žžŕ>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ČÉ2>ĘĘ˙>ĚĚÍ>ÎΚ>ĐĐh>ŇŇ5>ÔŐR>Ö×>ŘŘí>ÚÚş>Ü܇>ŢŢU>ŕár>âă?>äĺ >ććÚ>čč§>ęęt>ěí‘>îď_>đń,>ňňú>ôôÇ>öö”>řřb>úű>üýL>ţ˙?�€s?Z?‚A?ƒĎ?„ś?…?†ƒ?‡j?ˆQ? ‰7? ŠĆ? ‹Ź? Œ“? z?Ža?G?Ö?‘ź?’Ł?“Š?”p?•W?–ć?—Ě?˜ł?™š?š€?›g?œN?Ü?žĂ?ŸŠ?  ?!Ąw?"˘^?#Łě?$¤Ó?%Ľš?&Ś ?'§‡?(¨m?)Šü?*Şă?+ŤÉ?,Ź°?-­—?.Ž}?/Żd?0°ň?1ąŮ?2˛Ŕ?3ł§?4´?5ľt?6ˇ?7ˇé?8¸Đ?9šś?:ş?;ť„?<źj?=˝ů?>žŕ??żĆ?@Ŕ­?AÁ”?BÂz?CÄ ?DÄđ?EĹÖ?FĆ˝?GǤ?HȊ?IĘ?JĘ˙?KËć?LĚÍ?MÍł?NΚ?Oρ?PŃ?QŃö?RŇÝ?SÓĂ?TÔŞ?UՑ?V×?WŘ?XŘí?YŮÓ?ZÚş?[ŰĄ?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?dĺ ?eĺó?fćÚ?gçŔ?hč§?ię6?jë?kě?lěę?míĐ?nîˇ?oďž?pń,?qň?rňú?sóŕ?tôÇ?uőŽ?v÷<?wř#?xů ?yůđ?zú×?{ű˝?|ýL?}ţ3?~˙?€��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;€sX<�sX ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/smooth.fits�����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016260� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'smooth ' / Name of colour table HISTORY (r,g,b) colour table converted from: smooth.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:05 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����<€ˆQ=Œ?=PĐh=ˆŠH=°ŽS=ĐĐh=đň|> ‹D>œN>,­X>@Áý>PĐh>`ár>tö>‚‚A>ŠŠĆ>’‘ű>œœN>¤¤Ó>ŹŹ>śś[>žžŕ>ĆÇe>ĐĐh>ŘŘí>ŕár>ęęt>ňňú>úű?‚A?†ƒ? ŠĆ?G?“Š?—Ě?œN?  ?$¤Ó?)Šü?-­—?1ąŮ?6ˇ?:ş?>žŕ?BÂz?GǤ?KËć?Oρ?TÔŞ?XŘí?\Ý/?aáą?eĺó?ię6?nîˇ?rňú?v÷<?{ű˝?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?~˙?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?}ţ3?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?|ýL?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?{ű˝?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?zú×?v÷<?rňú?míĐ?ię6?eĺó?aáą?\Ý/?XŘí?TÔŞ?PŃ?KËć?GǤ?CÄ ??żĆ?:ş?6ˇ?2˛Ŕ?.Ž}?)Šü?%Ľš?!Ąw?Ü?™š?”p?Ö? Œ“?ˆQ?ƒĎ>ţ˙>öö”>îď_>äĺ >Ü܇>ÔŐR>ĚĚÍ>ÂÂz>şťE>˛˛Ŕ>ŞŞ;>˘Ł>˜˜ł>.>ˆˆř>€€s>lěB>\Ý×>LĚÍ><ťĂ>(Š˝>˜ł>‡Š=đň|=ČÉ2=¨§=ˆŠH=PĐh=�}Ô<€ˆQ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������<@­< Ľ'=�}Ô= Ľ'=PĐh=pí>=‘}=¨§=¸şÇ=ĐĐh=ŕŢÓ=řůą>„>‘}>œN>$Łƒ>0°ň>8¸(>Dŗ>PĐh>Xם>dĺ >lěB>xůą>€€s>†‡+>ŒŒ“>.>––ć>šš€> Ą8>¤¤Ó>ŞŞ;>°°ň>´´>şťE>žžŕ>ÄÄH>ČÉ2>ÎΚ>ÔŐR>ŘŘí>ŢŢU>âă?>čč§>îď_>ňňú>řřb>üýL?Z?ƒĎ?†ƒ? ‰7? ‹Ź?Ža?Ö?“Š?•W?˜ł?™š?›g?œN?Ü?žĂ?  ?!Ąw?"˘^?$¤Ó?%Ľš?&Ś ?(¨m?)Šü?*Şă?,Ź°?-­—?.Ž}?/Żd?1ąŮ?2˛Ŕ?3ł§?5ľt?6ˇ?7ˇé?9šś?:ş?;ť„?<źj?>žŕ??żĆ?@Ŕ­?BÂz?CÄ ?DÄđ?EĹÖ?GǤ?HȊ?IĘ?KËć?LĚÍ?MÍł?Oρ?PŃ?QŃö?SÓĂ?TÔŞ?UՑ?V×?XŘí?YŮÓ?ZÚş?\Ý/?]Ţ?^Ţü?`ŕĘ?aáą?bâ—?cä&?eĺó?fćÚ?fćÚ?bâ—?^Ţü?ZÚş?V×?SÓĂ?Oρ?KËć?GǤ?CÄ ??żĆ?;ť„?7ˇé?3ł§?/Żd?,Ź°?(¨m?$¤Ó?  ?œN?˜ł?”p?Ö? Œ“?ˆQ?…?Z>úű>ňňú>ęęt>âă?>ÚÚş>ŇŇ5>ĘĘ˙>ÂÂz>ź˝>´´>ŹŹ>¤¤Ó>œœN>”•>ŒŒ“>„„>xůą>hč§>\Ý×>LĚÍ><ťĂ>,­X>œN> ‹D=řůą=Řם=¸şÇ=˜˜ł=€ƒ=@Áý=�}Ô<€ˆQ��������������������������������������������������������������������?€��?{ű˝?v÷<?rňú?nîˇ?ię6?eĺó?aáą?\Ý/?XŘí?TÔŞ?Oρ?KËć?GǤ?BÂz?>žŕ?:ş?6ˇ?1ąŮ?-­—?)Šü?$¤Ó?  ?œN?—Ě?“Š?G? ŠĆ?†ƒ?‚A>úű>ňňú>ęęt>ŕár>ŘŘí>ĐĐh>ĆÇe>žžŕ>śś[>ŹŹ>¤¤Ó>œœN>’‘ű>ŠŠĆ>‚‚A>tö>`ár>PĐh>@Áý>,­X>œN> ‹D=đň|=ĐĐh=°ŽS=ˆŠH=PĐh=Œ?<€ˆQ�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/smooth1.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016341� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'smooth1 ' / Name of colour table HISTORY (r,g,b) colour table converted from: smooth1.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:05 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END >žž>¤¤Ó>ŞŞ;>°°ň>śś[>ź˝>ÂÂz>ČÉ2>ÎΚ>ÔŐR>ÚÚş>ŕár>ććÚ>ěí‘>ňňú>úű?�€s?ƒĎ?†ƒ? ŠĆ? z?‘ź?”p?—Ě?›g?žĂ?"˘^?%Ľš?)Šü?-­—?0°ň?4´?7ˇé?;ť„??żĆ?CÄ ?FĆ˝?JĘ˙?NΚ?RŇÝ?V×?ZÚş?^Ţü?ZÚş?V×?SÓĂ?PŃ?MÍł?JĘ˙?HȊ?EĹÖ?BÂz??żĆ?>žŕ?;ť„?:ş?7ˇé?5ľt?4´?1ąŮ?0°ň?.Ž}?-­—?,Ź°?*Şă?)Šü?'§‡?&Ś ?%Ľš?$¤Ó?"˘^?"˘^?!Ąw?  ?  ?ŸŠ?ŸŠ?žĂ?žĂ?Ü?Ü?œN?œN?œN?œN?œN?œN?œN?œN?Ü?Ü?žĂ?žĂ?ŸŠ?ŸŠ?  ?  ?!Ąw?"˘^?"˘^?$¤Ó?%Ľš?&Ś ?'§‡?)Šü?*Şă?,Ź°?-­—?.Ž}?0°ň?1ąŮ?4´?5ľt?7ˇé?:ş?;ť„?>žŕ??żĆ?BÂz?FĆ˝?JĘ˙?MÍł?QŃö?V×?ZÚş?_ßă?eĺó?kě?ię6?gçŔ?eĺó?dĺ ?bâ—?aáą?`ŕĘ?_ßă?^Ţü?\Ý/?\Ý/?[ŰĄ?[ŰĄ?ZÚş?YŮÓ?ZÚş?YŮÓ?YŮÓ?YŮÓ?YŮÓ?ZÚş?YŮÓ?ZÚş?YŮÓ?ZÚş?[ŰĄ?\Ý/?\Ý/?]Ţ?^Ţü?_ßă?`ŕĘ?aáą?bâ—?cä&?eĺó?fćÚ?gçŔ?ię6?jë?lěę?míĐ?pń,?rňú?sóŕ?uőŽ?xů ?zú×?|ýL?~˙?€��?€��?€��?€��?€��?€��?|ýL?uőŽ?nîˇ?hč§?aáą?[ŰĄ?TÔŞ?NΚ?GǤ?AÁ”?;ť„?4´?0°ň?*Şă?$¤Ó?ŸŠ?š€?•W?G? ‹Ź?‡j?ƒĎ?�€s>řřb>đń,>čč§>âă?>ŢŢU>ŘŘí>ÔŐR>ŇŇ5>ÎΚ>ĚĚÍ>ČÉ2>ĆÇe>ÄÄH>ÂÂz>ÂÂz>žžŕ>žžŕ>žžŕ>žžŕ>ŔŔ­>ŔŔ­>ÂÂz>ÄÄH>ĆÇe>ĘĘ˙>ĚĚÍ>ĐĐh>ÔŐR>ŘŘí>ŢŢU>äĺ >ęęt>đń,>öö”?�€s?„ś? ‰7?Ža?“Š?™š?  ?'§‡?.Ž}?5ľt?=˝ů?EĹÖ?MÍł?UՑ?^Ţü>”•>šš€>˘Ł>¨¨m>°°ň>¸¸(>ŔŔ­>ĆÇe>ÎΚ>Ö×>ŢŢU>ććÚ>îď_>öö”>ţ˙?„ś?ˆQ? Œ“?‘ź?•W?™š?žĂ?"˘^?'§‡?+ŤÉ?0°ň?5ľt?9šś?>žŕ?CÄ ?HȊ?MÍł?RŇÝ?MÍł?IĘ?EĹÖ?AÁ”?=˝ů?;ť„?7ˇé?4´?2˛Ŕ?.Ž}?,Ź°?*Şă?(¨m?&Ś ?#Łě?"˘^?  ?žĂ?œN?›g?š€?™š?˜ł?—Ě?–ć?–ć?•W?”p?”p?”p?“Š?”p?“Š?”p?”p?”p?•W?–ć?–ć?—Ě?˜ł?™š?š€?›g?œN?žĂ?  ?"˘^?#Łě?&Ś ?(¨m?*Şă?,Ź°?.Ž}?2˛Ŕ?4´?7ˇé?;ť„?=˝ů?AÁ”?EĹÖ?IĘ?MÍł?RŇÝ?MÍł?IĘ?EĹÖ?AÁ”?=˝ů?;ť„?7ˇé?4´?2˛Ŕ?.Ž}?,Ź°?*Şă?(¨m?&Ś ?#Łě?"˘^?  ?žĂ?œN?›g?š€?™š?˜ł?—Ě?–ć?–ć?•W?”p?”p?”p?“Š?”p?“Š?”p?”p?”p?•W?–ć?–ć?—Ě?˜ł?™š?š€?›g?œN?žĂ?  ?"˘^?#Łě?'§‡?+ŤÉ?.Ž}?2˛Ŕ?6ˇ?=˝ů?AÁ”?GǤ?MÍł?RŇÝ?YŮÓ?`ŕĘ?hč§?oďž?xů ?v÷<?uőŽ?tôÇ?sóŕ?rňú?rňú?qň?pń,?qň?pń,?qň?qň?qň?rňú?rňú?sóŕ?tôÇ?tôÇ?uőŽ?wř#?xů ?zú×?{ű˝?}ţ3?~˙?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?xů ?oďž?fćÚ?]Ţ?TÔŞ?KËć?BÂz?;ť„?2˛Ŕ?+ŤÉ?#Łě?œN?”p? z?‡j?Z>ôôÇ>čč§>ŢŢU>ÔŐR>ČÉ2>ŔŔ­>śś[>ŽŻ%>¨¨m>˘Ł>œœN>˜˜ł>––ć>’‘ű>.>.>ŽŽa>ŽŽa>ŽŽa>.>’‘ű>”•>˜˜ł>œœN>˘Ł>ŚŚ >ŽŻ%>´´>žžŕ>ČÉ2>ŇŇ5>ŕár>îď_>ţ˙?‡j?G?—Ě?  ?)Šü?3ł§?=˝ů?GǤ?RŇÝ>dĺ >tö>‚‚A>ŠŠĆ>”•>œœN>ŚŚ >°°ň>şťE>ÄÄH>ÎΚ>ŘŘí>âă?>îď_>řřb?‚A?ˆQ?Ža?”p?š€?  ?&Ś ?-­—?3ł§?:ş?AÁ”?HȊ?AÁ”?:ş?4´?.Ž}?(¨m?$¤Ó?ŸŠ?š€?–ć?’Ł?Ža? ŠĆ?‡j?ƒĎ?Z>üýL>řřb>ôôÇ>đń,>ěí‘>ęęt>čč§>ććÚ>äĺ >äĺ >äĺ >äĺ >äĺ >ććÚ>čč§>ęęt>ěí‘>đń,>ôôÇ>řřb>üýL?Z?ƒĎ?‡j? ŠĆ?Ža?’Ł?–ć?š€?ŸŠ?$¤Ó?(¨m?.Ž}?4´?:ş?AÁ”?HȊ?AÁ”?:ş?4´?.Ž}?(¨m?$¤Ó?ŸŠ?š€?–ć?’Ł?Ža? ŠĆ?‡j?ƒĎ?Z>üýL>řřb>ôôÇ>đń,>ěí‘>ęęt>čč§>ććÚ>äĺ >äĺ >äĺ >äĺ >äĺ >ććÚ>čč§>ęęt>ěí‘>đń,>ôôÇ>řřb>üýL?Z?ƒĎ?‡j? ŠĆ?Ža?’Ł?–ć?š€?ŸŠ?$¤Ó?(¨m?.Ž}?4´?:ş?AÁ”?HȊ?AÁ”?:ş?4´?.Ž}?(¨m?$¤Ó?ŸŠ?š€?–ć?’Ł?Ža? ŠĆ?‡j?ƒĎ?Z>üýL>řřb>ôôÇ>đń,>ěí‘>ęęt>čč§>ććÚ>äĺ >äĺ >äĺ >äĺ >äĺ >ććÚ>čč§>ęęt>ěí‘>đń,>ôôÇ>řřb>üýL?Z?ƒĎ?‡j? ŠĆ?Ža?’Ł?–ć?š€?  ?&Ś ?,Ź°?4´?;ť„?DÄđ?MÍł?WŘ?RŇÝ?NΚ?KËć?HȊ?EĹÖ?CÄ ?AÁ”??żĆ?=˝ů?<źj?;ť„?:ş?:ş?:ş?:ş?;ť„?<źj?=˝ů?>žŕ?@Ŕ­?AÁ”?DÄđ?FĆ˝?IĘ?MÍł?PŃ?TÔŞ?XŘí?]Ţ?aáą?fćÚ?lěę?`ŕĘ?V×?KËć?AÁ”?8¸Đ?-­—?&Ś ?Ü?•W?Ža?†ƒ?�€s>ôôÇ>ęęt>ŕár>Ö×>ĐĐh>ĚĚÍ>ĆÇe>ÄÄH>ÂÂz>ŔŔ­>ŔŔ­>ÂÂz>ÄÄH>ČÉ2>ĚĚÍ>ĐĐh>ŘŘí>ŢŢU>ććÚ>ňňú>ţ˙?†ƒ? Œ“?•W?Ü?&Ś ?0°ň?;ť„?HȊ ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/smooth2.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016342� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'smooth2 ' / Name of colour table HISTORY (r,g,b) colour table converted from: smooth2.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:06 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH>‡Š>‡Š>‡Š>‡Š>‡Š>‡Š>‡Š>‡Š>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>îď_>îď_>îď_>îď_>îď_>îď_>îď_>îď_?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?™š?™š?™š?™š?™š?™š?™š?™š?*Şă?*Şă?*Şă?*Şă?*Şă?*Şă?*Şă?*Şă?;ť„?;ť„?;ť„?;ť„?;ť„?;ť„?;ť„?;ť„?LĚÍ?LĚÍ?LĚÍ?LĚÍ?LĚÍ?LĚÍ?LĚÍ?LĚÍ?]Ţ?]Ţ?]Ţ?]Ţ?]Ţ?]Ţ?]Ţ?]Ţ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?nîˇ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=ˆŠH=ˆŠH>‡Š>‡Š>LĚÍ>LĚÍ>ˆˆř>ˆˆř>ŞŞ;>ŞŞ;>ĚĚÍ>ĚĚÍ>îď_>îď_?ˆQ?ˆQ?™š?™š?*Şă?*Şă?;ť„?;ť„?LĚÍ?LĚÍ?]Ţ?]Ţ?nîˇ?nîˇ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH=ˆŠH>‡Š>‡Š>‡Š>‡Š>‡Š>‡Š>‡Š>‡Š>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>LĚÍ>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ˆˆř>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>îď_>îď_>îď_>îď_>îď_>îď_>îď_>îď_?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ?ˆQ>îď_>îď_>îď_>îď_>ĚĚÍ>ĚĚÍ>ĚĚÍ>ĚĚÍ>ŞŞ;>ŞŞ;>ŞŞ;>ŞŞ;>ˆˆř>ˆˆř>ˆˆř>ˆˆř>LĚÍ>LĚÍ>LĚÍ>LĚÍ>‡Š>‡Š>‡Š>‡Š=ˆŠH=ˆŠH=ˆŠH=ˆŠH����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=ˆŠH=ˆŠH>‡Š>‡Š>LĚÍ>LĚÍ>ˆˆř>ˆˆř>ŞŞ;>ŞŞ;>ĚĚÍ>ĚĚÍ>îď_>îď_?ˆQ?ˆQ?™š?™š?*Şă?*Şă?;ť„?;ť„?LĚÍ?LĚÍ?]Ţ?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/smooth3.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016343� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'smooth3 ' / Name of colour table HISTORY (r,g,b) colour table converted from: smooth3.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:06 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;‚Ć<^*Ă<䣃=8›R=…ą…=¨§=Đr=ůĐŚ>šA>&L0>:ţ>O­m>a˝>r\>>‚Üą>5¨>—|>Ÿ ĺ>˘~R>˘Ł>˘Ł>˘Ł>˘Ł>˘Ł>˘fş> ­> Ą8> Ą8> Ą8> Ą8> Ą8>Î{?}ě?€��?YÍ? ÔA>ĹŰw>Đ3>ڌ>äĺ >ď>>ř%[?�öj?"ć? Nş?{5?§ą?Ô,? �¨?%,|?*X÷?/…s?4ąî?9ÝÂ?? =?Dőo?Jd?PŽ?U˝ů?ZéÍ?`1Ď?gô4?pwî?wܜ?|Ţ?S¤?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?•Ő?}Ł?xďÝ?r Ť?jJŒ?bˆ'?ZĹ?S´?K@O?CYŢ?:ş?4ąF?0ѡ?-ó?-ŒŇ?/‘ć?2Ç?7ĘC?<öž?B"’?GO?L{‰?Q¨?Vţr?];?b-ś?gZ2?l†­?q˛?vŢü?{Ţ@?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?w|F?AęÝ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=S÷Ď>Ęb$>ĚĚÍ>›2‹=ę@����������������������������������������������������������������������������������������������������������������������������:q,(<‘}k=u=lĘ.=ŸČó=É'‘=ô)ž>7‹>*\ć>?bˇ>VĄb>lĘ.>€źž>‹ľ>•“`>Ą¤ž>ŞŒ>´xB>žŃ9>É*0>ÓĐ>ŰŻ>äNQ>î‡Ó>řŕĘ?œŕ?h^? ôI?…?X%?x-?řM?!7ô?#Ł?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?#Łě?$U?%<6?'—?)žő?/ČK?5Đú?;ÚQ?Aă¨?GěW?NŸ?T˙C?[š?aĎ˙?h†?n$Ý?t-Œ?z6ă?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��<�sX<“ á<üă=5Ü=lĘ.=‘ű@=­‘h=É'‘=äÂř=ú}Ş> ô >ż>%Š3>3UG>AÄ>Kc >Xľ‰>f€>tK˛>€hÜ>†I>ŽĹm>“ńA>šĄ> L>ŚjU>­Oß>´5i>ť\>Ŕ/0>Čmr>΋Á>Ô°Ÿ>Úć†>ŕár>éC>îp;>ő+Ô>ü^?{t?“É?`? ŇÝ?FJ?š?…^?˛?w?ƒ<?!á ?$wš?'ŰM?+N?.Ŕ×?1Ҟ?4Ľz?8@?;‹?>ţr?Bq7?E[Ť?HUÚ?Kȟ?O †?Qśp?Uóś?Y”[?]!?`yć?cŞz?f@d?hÖő?lCÔ?ośš?s)_?vœ$?yÉq?\ň(=nš=@Áý=L‹=YÝÂ=uDť=˜iƒ=ČŽű=řůą> ťZ>!Ú{>6Œi>Lűü>cóŕ>xŁ/>†Ş>‘†>›\}>Ľ´$>° >şf>Ĺě>ŃÎ>Űqv>ĺĘm>îď_>ůf{?jŠ?–}? Âř?ďt?ď?GĂ?!t??& ş?+Í6?1}?7,?<Rç?Ac?FŤŢ?Kײ?Q.?V0Š?[]%?aPŰ?fś[?kâÖ?qR?v;Í?{Uď?Ľ?| Đ?wb?qčć?l^ł?fU\?`aŚ?[5+?U;Ž?OŰő?JŻy?E"§??U›?:)Ç?4ýL?/�i?)Łn?#ďJ?I?˝?ńA?ÄĆ?Ĝ?jč>űfů>đ#d>ĺĘm>Űqv>Ń~>Ĺě>şf>ŽđŽ>Ł˛W>˜Îp>At>„˘4>q9C>[ę >DôÇ>,Ďl>Í >­ë=ŕŢÓ=°”=€NĽ=)IĽ<­Ň;ľˆă����������������������������������������������������������������������������������������������������������������������������;Gâ‚<†/Z=˛=M ˇ=Šś=´ă=Ý}ż>�D(>‚>(Îp>=€^>QK>bŢ>wď>„…^>$ž>’Ľ¤>“Ó>‘&é>‹i˜>Ą>j-ś>R[>9ĺŸ>!ŔD> ›Đ=ę÷=ş˛=ƒÉď=$*í<Şŕ;çW“����������������������������������������=ž‘�>Š¨?Ž?V_?vŁY?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/staircase.fits��������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016725� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'staircase ' / Name of colour table HISTORY (r,g,b) colour table converted from: staircase.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:06 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?rňú?uőŽ?xů ?{ű˝?}ţ3?€��;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?sóŕ?v÷<?yůđ?|ýL?€��;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>ČÉ2?‡j?*Şă?MÍł?LĚÍ?€��> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8> Ą8>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,>đń,?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?  ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?pń,?sóŕ?v÷<?yůđ?|ýL?€��;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>ČÉ2?‡j?*Şă?MÍł?LĚÍ?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/stairs8.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016344� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'stairs8 ' / Name of colour table HISTORY (r,g,b) colour table converted from: stairs8.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:06 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?CÄ ?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙>ţ˙��������������������������������������������������������������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/stairs9.fits����������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016345� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'stairs9 ' / Name of colour table HISTORY (r,g,b) colour table converted from: stairs9.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:07 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ����>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?›g?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?HȊ?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę?lěę������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?'§‡?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?‘ź?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?v÷<?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ?1ąŮ��������������������������������������������������������������������������������������������������������������������>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>HÉ2>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú>ňňú����������������������������������������������������������������������������������������������������������������>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ>žžŕ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€��?€�� ����������������������������������������������������������������PDL-2.018/Graphics/LUT/tables/standard.fits���������������������������������������������������������0000644�0601750�0601001�00000020700�12562522364�016547� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������SIMPLE = T BITPIX = -32 NAXIS = 2 / Number of axes NAXIS1 = 256 / Value NAXIS2 = 3 / r, g, and b columns BUNIT = 'Data Value ' OBJECT = 'standard ' / Name of colour table HISTORY (r,g,b) colour table converted from: standard.lasc HISTORY --- HISTORY ASCII files taken from the GAIA distribution of STARLINK HISTORY where they are released under the GNU copyleft HISTORY (http://star-www.rl.ac.uk/ and http://star-www.dur.ac.uk/~pdraper/) HISTORY Converted to FITS format using PDL::IO::Misc::wfits HISTORY on Tue Feb 1 13:17:07 2000 HISTORY Data is stored as a 2D image (nx3): HISTORY the columns are the r, g, and b values HISTORY and are floats (BITPIX=-32) in the range 0 to 1, inclusive. HISTORY Should have stored as a FITS table, but there is currently no FITS tableHISTORY reader (or writer) in the PDL distribution. END ;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŞŞ;>ŽŻ%>˛˛Ŕ>śś[>şťE>žžŕ>ÂÂz>ĆÇe>ĘĘ˙>ÎΚ>ŇŇ5>Ö×>ÚÚş>ŢŢU>âă?>ććÚ>ęęt>îď_>ňňú>öö”>úű>ţ˙?Z?ƒĎ?…?‡j? ‰7? ‹Ź? z?G?‘ź?“Š?•W?—Ě?™š?›g?Ü?ŸŠ?!Ąw?#Łě?%Ľš?'§‡?)Šü?+ŤÉ?-­—?/Żd?1ąŮ?3ł§?5ľt?7ˇé?9šś?;ť„?=˝ů??żĆ?AÁ”?CÄ ?EĹÖ?GǤ?IĘ?KËć?MÍł?Oρ?QŃö?SÓĂ?UՑ?WŘ?YŮÓ?[ŰĄ?]Ţ?_ßă?aáą?cä&?eĺó?gçŔ?ię6?kě?míĐ?oďž?qň?sóŕ?uőŽ?wř#?yůđ?{ű˝?}ţ3?€��;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŞŞ;>ŽŻ%>˛˛Ŕ>śś[>şťE>žžŕ>ÂÂz>ĆÇe>ĘĘ˙>ÎΚ>ŇŇ5>Ö×>ÚÚş>ŢŢU>âă?>ććÚ>ęęt>îď_>ňňú>öö”>úű>ţ˙?Z?ƒĎ?…?‡j? ‰7? ‹Ź? z?G?‘ź?“Š?•W?—Ě?™š?›g?Ü?ŸŠ?!Ąw?#Łě?%Ľš?'§‡?)Šü?+ŤÉ?-­—?/Żd?1ąŮ?3ł§?5ľt?7ˇé?9šś?;ť„?=˝ů??żĆ?AÁ”?CÄ ?EĹÖ?GǤ?IĘ?KËć?MÍł?Oρ?QŃö?SÓĂ?UՑ?WŘ?YŮÓ?[ŰĄ?]Ţ?_ßă?aáą?cä&?eĺó?gçŔ?ię6?kě?míĐ?oďž?qň?sóŕ?uőŽ?wř#?yůđ?{ű˝?}ţ3;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ>ŞŞ;>ŽŻ%>˛˛Ŕ>śś[>şťE>žžŕ>ÂÂz>ĆÇe>ĘĘ˙>ÎΚ>ŇŇ5>Ö×>ÚÚş>ŢŢU>âă?>ććÚ>ęęt>îď_>ňňú>öö”>úű>ţ˙?Z?ƒĎ?…?‡j? ‰7? ‹Ź? z?G?‘ź?“Š?•W?—Ě?™š?›g?Ü?ŸŠ?!Ąw?#Łě?%Ľš?'§‡?)Šü?+ŤÉ?-­—?/Żd?1ąŮ?3ł§?5ľt?7ˇé?9šś?;ť„?=˝ů??żĆ?AÁ”?CÄ ?EĹÖ?GǤ?IĘ?KËć?MÍł?Oρ?QŃö?SÓĂ?UՑ?WŘ?YŮÓ?[ŰĄ?]Ţ?_ßă?aáą?cä&?eĺó?gçŔ?ię6?kě?míĐ?oďž?qň?sóŕ?uőŽ?wř#?yůđ?{ű˝?}ţ3;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;;€sX<�sX<@­<€ˆQ< Ľ'<ŔÁý<ŕŢÓ=�}Ô=Œ?= Ľ'=0ł’=@Áý=PĐh=`ŢÓ=pí>=€ƒ=ˆŠH=‘}=˜˜ł= Ÿč=¨§=°ŽS=¸şÇ=ŔÁý=ČÉ2=ĐĐh=Řם=ŕŢÓ=čëF=đň|=řůą>�€s>„>‡Š> ‹D>‘}>•>˜ł>œN> Ÿč>$Łƒ>(Š˝>,­X>0°ň>4´>8¸(><ťĂ>@Áý>Dŗ>HÉ2>LĚÍ>PĐh>TÔ>Xם>\Ý×>`ár>dĺ >hč§>lěB>pďÝ>tö>xůą>|ýL>€€s>‚‚A>„„>†‡+>ˆˆř>ŠŠĆ>ŒŒ“>ŽŽa>.>’‘ű>”•>––ć>˜˜ł>šš€>œœN>žž> Ą8>˘Ł>¤¤Ó>ŚŚ >¨¨m>ŞŞ;>ŹŹ ����������������������������������������������������������������PDL-2.018/Graphics/Makefile.PL����������������������������������������������������������������������0000644�0601750�0601001�00000002627�13036512174�014117� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; my @subdirs = qw(PGPLOT LUT IIS Limits); # we try and build unless WITH_3D == 0 my $t = $PDL::Config{WITH_3D}; if ( defined($t) and not $t ) { print " WITH_3D: WITH_3D => 0, not building TriD or OpenGL. Set WITH_3D => 1 if this is incorrect.\n"; } elsif ( $PDL::Config{USE_POGL} ) { print " WITH_3D: USE_POGL => 1, will build TriD using OpenGL.\n"; $PDL::Config{WITH_3D} = 1; unshift @subdirs,"TriD"; } else { print " WITH_3D: USE_POGL => 0, setting WITH_3D => 0. Will not build TriD graphics.\n"; $PDL::Config{WITH_3D}=0; # don't build TriD if no POGL } my @pm_names = qw (Graphics2D.pm State.pm); my %pm = map { my $h = '$(INST_LIBDIR)/'; $h .= 'PDL/' if $_ !~ /PDL.pm$/; $h .= 'Graphics/' if $_ =~ /State.pm$/; ( $_, $h . $_ ); } ( @pm_names); my %man3pods = map { my $h = '$(INST_MAN3DIR)/'; $h .= 'PDL::' if $_ !~ /PDL.pm$/; ( $_, $h . substr($_,0,length($_)-3) . '.$(MAN3EXT)' ); } @pm_names; WriteMakefile( 'NAME' => 'PDL', 'VERSION_FROM' => '../Basic/Core/Version.pm', 'PM' => \%pm, 'MAN3PODS' => \%man3pods, 'DIR' => [@subdirs], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); ���������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/��������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013130� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/Makefile.PL���������������������������������������������������������������0000644�0601750�0601001�00000000427�12562522364�015125� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Graphics::PGPLOT', 'VERSION_FROM' => '../../Basic/Core/Version.pm', 'DIR' => ['Window'], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/PGPLOT.pm�����������������������������������������������������������������0000644�0601750�0601001�00000037360�13036512175�014520� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Graphics functions for the PDL module, this module # requires the PGPLOT module be previously installed. # PGPLOT functions are also made available to the caller. =head1 NAME PDL::Graphics::PGPLOT - PGPLOT enhanced interface for PDL =head1 SYNOPSIS pdl> $a = pdl [1..100] pdl> $b = sqrt($a) pdl> line $b pdl> hold Graphics on HOLD pdl> $c = sin($a/10)*2 + 4 pdl> line $c =head1 DESCRIPTION C<PDL::Graphics::PGPLOT> is a convenience interface to the PGPLOT commands, implemented using the object oriented PGPLOT plotting package in L<PDL::Graphics::PGPLOT::Window|PDL::Graphics::PGPLOT::Window>. See the documentation for that package for in-depth information about the usage of these commands and the options they accept. The list of currently availably commands: imag - Display an image (uses pgimag()/pggray() as appropriate) im - Shorthand to display an image with aspect ratio of 1 fits_imag - Display a FITS image with appropriate transforms & labels cont - Display image as contour map fits_cont - Display a FITS image in scientific coordinates as a contour map vect - Display 2 images as a vector field fits_vect - Display 2 FITS images in sci. coordinates as a vector field ctab - Load an image colour table ctab_info - Get information about currently loaded colour table line - Plot vector as connected points points - Plot vector as points errb - Plot error bars bin - Plot vector as histogram (e.g. bin(hist($data)) ) hi2d - Plot image as 2d histogram (not very good IMHO...) poly - Draw a polygon text - Write text in the plot area label_axes - Print axis titles legend - Create a legend with different texts, linestyles etc. cursor - Interactively read cursor positions. circle - Draw a circle ellipse - Draw an ellipse. Device manipulation commands: hold - Hold current plot window range - allows overlays etc. release - Release back to autoscaling of new plot window for each command rel - short alias for 'release' env - Define a plot window, put on 'hold' dev - Explicitly set a new PGPLOT graphics device new_window - Create a new plot window (use of dev is recommended) focus_window - Change focus to a new window window_list - Get a list of currently existing plot windows close_window - Close an open window =head1 FUNCTIONS The following is a list of the functions that are private to this package, for the other functions please read the L<PDL::Graphics::PGPLOT::Window|PDL::Graphics::PGPLOT::Window> documentation. =head2 dev =for ref Open PGPLOT graphics device =for usage Usage: dev $device, [$nx,$ny, $opt]; C<$device> is a PGPLOT graphics device such as "/xserve" or "/ps", if omitted defaults to last used device (or value of env var C<PGPLOT_DEV> if first time). C<$nx>, C<$ny> specify sub-panelling. The function returns the id of the newly created window - this can subsequently be used as argument to C<focus_window> to select the window. The result of this command can be modified using options. The options recognised are the same as for C<new_window> - which primarily and in addition it is possible to set the default values for a window that are defined in L<PDL::Graphics::PGPLOTOptions|PDL::Graphics::PGPLOTOptions>, see this for details but see below for a synopsis. In addition C<dev> recognises the option C<NewWindow> which allows the user to specify that a C<dev> command is to create a new window rather than closing the previous. This allows a large number of output destinations to be open at the same time, which occasionally can be convenient. Here is a quick summary of the most useful additional options that can be given: =over =item Device Alternative to C<$device>. =item AspectRatio The aspect ratio of the output window =item WindowWidth The width of the plot window in inches =item AxisColour The axis colour to be used as default for plots in this window. In the same way it is possible to set the default character size (C<CharSize>) and axis and box styles. See L<PDL::Graphics::PGPLOTOptions|PDL::Graphics::PGPLOTOptions> for details. =item WindowName The name of a window. This name can subsequently be used to refer to the window instead of its ID, making interactive use somewhat more intuitive. =back =for example To open a X-window output that will stay on screen: $win = dev('/xs'); To open two windows, one small and square, one large and wide: $win1 = dev('/xs', {Aspect => 1, WindowWidth => 4}); $win2 = dev('/xs', {Aspect => 0.5, WindowWidth => 10}); =cut package PDL::Graphics::PGPLOT; # Just a plain function exporting package use PDL::Core qw/:Func :Internal/; # Grab the Core names use PDL::Graphics::PGPLOTOptions qw(default_options); use PDL::Graphics::PGPLOT::Window; use PGPLOT; use Exporter; use strict; use vars qw (@ISA @EXPORT); @ISA = ('Exporter'); @EXPORT = qw( dev hold release rel env bin errb line points fits_imag imag imag1 fits_cont cont fits_vect vect draw_wedge ctab ctab_info hi2d poly CtoF77coords new_window focus_window window_list close_window label_axes text legend cursor circle ellipse rectangle tpoints tline retrieve_state replay turn_off_recording turn_on_recording clear_state autolog get_current_window transform ); *rel = *release; # Alias *image = *imag; ############################################################################ ############################################################# # This is a new version of PGPLOT which uses PDL::Options for # option parsing. ############################################################# # Option explanation: # # Each routine has a set of options, and there is also a set of # global options that may or may not affect a particular routine. # The global options are defined here in the start of the code. # # This require a minor adjustment to the PDL::Options code since # otherwise we would need to define the global options everywhere. # # The actual setting of default parameters is split off in a separate # file PDL::Graphics::PGPLOTOptions - which also exports default_options # used below. # The list of default global opttions, synonyms and translations. # END { # Destructor to close plot when perl exits _close_windows(); } ############################################################# # We now want to be able to have several plotting windows # # The current set of windows is stored in these # # variables - accessed by the local subs. Added JB 12/7/00 # # # # This has lead to a substantial rewrite of the code since # # all the real work is now done in the Window object which # # this routine only provides a convenient (and backwards # # compatible) interface to. # ############################################################# my @_WINDOWS=(); # The list of windows to access - the value is the options. my %_WINDOWNAMES = (); # A map of names for each window to their number. my $CW = undef; =head2 new_window =for ref Open a PGPLOT graphics device =for usage $win = new_window($dev, $nx, $ny, $opt); This function is identical to L<dev|dev> except that it always creates a new window. This means that the user is required to close all windows explicitly using L<close_window|close_window>. All functionality is otherwise like C<dev> so see the documentation for L<dev|dev> for details of use. =cut sub new_window { my ($dev, $nx, $ny, $opt)=@_; if (ref($dev) eq 'HASH') { $opt = $dev; ($dev, $nx, $ny)=(undef, undef, undef); } elsif (ref($nx) eq 'HASH') { $opt = $nx; ($nx, $ny)=(undef, undef); } $opt={} unless defined($opt); # This will cause problems if people both pass dev, nx & ny _and_ # passes them in an options hash with poor spelling - don't do that.. $opt->{Device}=$dev if defined($dev); $opt->{NXPanel}=$nx if defined($nx); $opt->{NYPanel}=$ny if defined($ny); # Now insert the necessary information in the variables above. # barf "Options must be an anonymous hash!\n" if defined($_[0]) && # ref($_[0]) ne 'HASH'; my $win = PDL::Graphics::PGPLOT::Window->new($opt); my ($name, $id) = ($win->name(), $win->id()); $_WINDOWS[$id] = $name; $_WINDOWNAMES{$name}=$win; $_WINDOWNAMES{$id}=$name; # Reverse lookup for speed $CW = $win; if (wantarray) { return ($id, $name, $win); } else { return $id; } } # Close all windows. sub _close_windows { close_window({All=>1}); # Do all windows... } =head2 close_window =for ref Close a PGPLOT output device =for usage Usage: close_window($id) This function closes a PGPLOT output device created with C<dev> or C<new_window>. It requires the id of the window to close. If C<$id> is left undefined, the currently focussed window is deleted and focus is transferred to the lowest numbered window in existence. If many windows have been created and deleted this might not be what you expect, so it is recommended to make an explicit call to L<focus_window|focus_window> after any call to C<close_window>. =cut sub close_window { my ($name)=@_; if (ref($name) eq 'HASH') { # Hack - to avoid checking window names.. for (my $id=0; $id<=$#_WINDOWS; $id++) { next unless defined($_WINDOWS[$id]); my $n = $_WINDOWS[$id]; $_WINDOWNAMES{$n}->close(); delete $_WINDOWNAMES{$n}; delete $_WINDOWNAMES{$id}; } @_WINDOWS=(); # Remove all windows. $CW = undef; # No current window } else { # # Delete a specific window # my $id = _get_windownumber($name); my $CWid = $CW->id(); my $n= $_WINDOWNAMES{$id}; # In case the name was not passed.. $_WINDOWNAMES{$n}->close(); delete $_WINDOWNAMES{$n}; delete $_WINDOWNAMES{$id}; $_WINDOWS[$id]=undef; #splice(@_WINDOWS, $id, 1); if ($CWid == $id) { # Now determine the current window, viz the lowest numbered # window existing. $CW = undef; for (my $i=0; $i<=$#_WINDOWS; $i++) { if (defined($_WINDOWS[$i])) { $CW = $_WINDOWNAMES{$_WINDOWS[$i]}; last; } } } # Since we set the corresponding array elements to undef - we # have to check if we have in fact deleted the whole shebang in # which case @_WINDOWS should be reset. @_WINDOWS=() if (!defined($CW)); } } # Utility function - allowing both numbers and names to be used. =head2 _get_windownumber Internal function to obtain the ID of a window. This allows the user to refer to a window with its name. =cut sub _get_windownumber { my ($name)=@_; if (!defined($name) || $name eq '') { return -1 unless defined($CW); return $CW->id(); } my $windownumber = -1; if (!exists($_WINDOWNAMES{$name}) || !ref($_WINDOWNAMES{$name})) { # Then it ought to be a number if ($name =~ m/^\d+$/) { $windownumber = $name; } else { print "Valid window names: \n"; foreach my $k (keys %_WINDOWNAMES) { print "$k\n"; } barf ("I cannot switch to window $name - no such name\n"); } } else { $windownumber = $_WINDOWNAMES{$name}->id(); } barf("Invalid windownumber ($name)\n") if !defined($_WINDOWS[$windownumber]); return $windownumber; } { my $dev_options = undef; sub dev { # This delayed creation of the options variable is for increased speed. # Although for dev() this is unnecessary... if (!defined($dev_options)) { $dev_options = PDL::Options->new({NewWindow => 0}); $dev_options->warnonmissing(0); # Turn off warnings. } # Get the input options. my ($dev, $nx, $ny, $u_opt)=@_; if (ref($nx) eq 'HASH') { $u_opt = $nx; ($nx, $ny)=(undef, undef); } $u_opt = {} if !defined($u_opt); my $opt = $dev_options->options($u_opt); # Then we want to close the current one before opening a new one. if (!$opt->{NewWindow}) { my ($state,$len); pgqinf('STATE',$state,$len); close_window() if $state eq 'OPEN'; } my $win=new_window(@_); return $win; } } =head2 focus_window =for ref Switch to another output window. =for usage Usage: focus_window($id); This command is used to switch output focus to another window created by L<dev|dev> or L<new_window|new_window>. The window can be referred to either by its ID or by its name. =for example $win1 = dev('/xs', {WindowName => 'X-output'}); $win2 = dev('test.ps/ps', {WindowName => 'PS-output'}); focus_window('X-output'); # Or focus_window($win1); <.. Commands ..> focus_window($win2); # Or focus_window('PS-output'); <.. Commands ..> =cut # Switch to a new window. sub focus_window { my ($name)=@_; my $windownumber = _get_windownumber($name); die "No such window ($name)\n" if $windownumber < 0; $CW = $_WINDOWNAMES{$_WINDOWS[$windownumber]}; print "Window focus switched to Window nr $windownumber ($_WINDOWNAMES{$windownumber})\n" if $PDL::verbose; $CW->focus(); } =head2 window_list =for ref Return a list of ID numbers and names of the windows currently opened using L<dev|dev> or L<new_window|new_window>. =for usage Usage: ($numbers, $names)=window_list(); C<$numbers> and C<$names> are anonymous arrays giving the ID numbers and names of the open windows respectively. =cut # And getting a list of windows sub window_list { my @numbers=(); my @names=(); foreach (keys %_WINDOWNAMES) { if (ref($_WINDOWNAMES{$_}) eq 'PDL::Graphics::PGPLOT::Window') { push @names, $_; } else { push @numbers, $_; } } return (wantarray ? (\@numbers, \@names) : \@numbers); } sub label_axes { # We do not label axes when there is no plot window. return if !defined($CW); $CW->label_axes(@_); } sub turn_on_recording { if (!defined($CW)) { warn "You can only turn on recording when you have a device open!\n"; return; } $CW->turn_on_recording(); } sub turn_off_recording { if (!defined($CW)) { warn "You can only turn off recording when you have a device open!\n"; return; } $CW->turn_off_recording(); } sub retrieve_state { if (!defined($CW)) { warn "You can only retrieve the state when a device is open\n"; return; } $CW->retrieve_state(); } sub replay { if (!defined($CW)) { warn "You can only replay plotting commands when a device is open!\n"; return; } $CW->replay(@_); } sub clear_state { if (!defined($CW)) { warn "You can only clear the state when a device is open\n"; return; } $CW->clear_state(); } sub autolog { # for this one we use the class method to set autolog globally dev() if !defined($CW); PDL::Graphics::PGPLOT::Window->autolog(@_); } sub text { barf 'Open a plot window first!' if !defined($CW); $CW->text(@_); } sub cursor { barf 'Open a plot window first!' if !defined($CW); $CW->cursor(@_); } sub legend { barf 'Open a plot window first!' if !defined($CW); $CW->legend(@_); } # should add these routines to EXPORT array as we create # each routine # foreach my $func ( qw( env bin cont fits_cont errb line tline points tpoints imag fits_imag imag1 draw_wedge ctab ctab_info hi2d poly vect fits_vect CtoF77coords circle ellipse rectangle ) ) { eval <<"ENDOFFUNC"; sub $func { dev() if !defined(\$CW); \$CW->${func}(\@_); } ENDOFFUNC } sub transform { barf 'Open a plot window first!' if !defined($CW); $CW->transform(@_); } sub hold { return if !defined($CW); $CW->hold(); print "Graphics on HOLD\n" if $PDL::verbose;}; sub release { return if !defined($CW); $CW->release(); print "Graphics RELEASED\n" if $PDL::verbose;}; #sub held { return 0 if !defined($CW); return $CW->held()}; #sub current_device { return $CW->device(); }; sub get_current_window { return $CW; } # return current window or undef if none exists 1; # Exit with OK status ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/PGPLOTOptions.pm����������������������������������������������������������0000644�0601750�0601001�00000032501�13036512175�016064� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Graphics::PGPLOTOptions - Setting PGPLOT options =head1 SYNOPSIS use PGPLOTOptions qw('default_options'); =head1 DESCRIPTION This package contains one function (at present) which returns PDL::Option objects for default settings for plot windows and plot commands. This should be complemented by functions that could affect this such as file reading commands etc. =head1 OPTIONS The following is a listing of options that are set in this file and what they do and what their default value is =head2 Window specific options These options modify the appearance of windows and can also modify the default settings for creation of plot axes etc. =over =item Device The default PGPLOT device to use. The default value is set to the PGPLOT_DEV environment variable if set, otherwise to '?'. =item AxisColour The colour with which to draw axes. Default value=3 (Green) =item HardLW, HardCH, HardFont, HardAxisColour, HardColour The linewidth, character height, font and axis colour to use on hardcopy devices. The default values are HardLW=1, HardCH=1.4, HardFont=2 (Roman), HardAxisColour=1 (Black) and HardColour=1 as well. The latter is the default plot colour to use on hardcopy devices. =item Axis The axis style to use. See the L<PDL::Graphics::PGPLOT::Window> documentation for details. It defaults to 'Normal' which is a labelled box. Valid arguments are 'Empty', 'Box', 'Normal', 'Axes', 'Grid', 'LogX', 'LogY', 'LogXY'. =item AspectRatio The aspect ratio of the output device. The default value is device dependent. =item WindowWidth The width of the output window in inches and defaults to as big as possible. =item WindowXSize and WindowYSize These are alternatives to AspectRatio and WindowWidth. =item WindowName The name of the window - can later be retrieved using name(). It defaults to 'Window'+Window ID. =item NXPanel The number of panels in the X-direction - defaults to 1 =item NYPanel The number of panels in the Y-direction - defaults to 1 =item Justify A boolean value which, if true, causes both axes to drawn to the same scale; see the PGPLOT C<pgenv()> command for more information. =item TightLabels Boolean value which, if true, causes axis labels to be pulled slightly closer to the main viewport than usual. That's handy for making multi-panel plots. Undef (the default) is equivalent to 0 for panels with NYPanels <= 1 and 1 for panels with NYPanels > 1. =item TitleSize The relative size of a plot or image title, compared to other annotations. Defaults to 1.0 (original behavior) but can be set to, e.g., 1.5 to emphasize graph titles in a multipanel plot. =item Border Adjust the spacing around the plot. See the documentation in L<PDL::Graphics::PGPLOT::Window> for details. =item CharSize The default charsize for the plot - used when annotating the axes for instance. It defaults to 1. =item PlotPosition The position of the plot in normalised coordinates. =item Erase Explicitly erase the plotting surface, normally required when making new plots with PlotPosition. =back =head2 Plot specific options For the moment see the C<PDL::Graphics::PGPLOT::Window> documentation for these. =cut package PDL::Graphics::PGPLOTOptions; # use PDL::Core qw/:Func :Internal/; use Exporter; use strict; use vars qw(@ISA @EXPORT_OK); @ISA = ('Exporter'); @EXPORT_OK = qw(default_options set_pgplot_options); # # To be able to set options outside of PGPLOT in the .perldlrc I will # have to define these local variables. # my %options = ( Device => undef, AxisColour => 3, BackgroundColour => -1, # Text background colour HardLW => 1, HardCH => 1.4, HardFont => 2, HardAxisColour => 1, HardColour => 1, Axis => 'BCNST', # see kludge in Window::imag if you change this AspectRatio => undef, WindowWidth => undef, WindowXSize => undef, WindowYSize => undef, Size => undef, Unit=> undef, WindowName => '', NXPanel => 1, NYPanel => 1, Justify => 0, # Justification of boxes & axes Scale=> undef, # device pixels per data pixel Pitch=> undef, # Horizontal data pixels per <unit> Unit => undef, # Unit for pitch Pix => undef, # Pixel aspect ratio Align => undef, # Alignment of viewport within plot area DirAxis=> undef, # Default direction of axes Border => 0, CharSize => 1, Symbol => 17, Colour => 5, ErrTerm => 1, LineStyle => 1, Font => 1, Fill => 1, ITF => 0, Transform => undef, LineWidth => 1, XRange => undef, YRange => undef, Arrow => {FS => 1, Angle => 45.0, Vent => 0.3, ArrowSize => undef}, Hatch => {Angle => 45.0, Separation => 1.0, Phase => 0.0}, XTitle => '', YTitle => '', Title => '', ); sub default_options { my $DEV=undef; # Use the standard PGPLOT environment variable. $DEV = $ENV{"PGPLOT_DEV"} if defined $ENV{"PGPLOT_DEV"}; # However if the user has specified the Perl-ish variable use that. $DEV = $options{Device} if defined($options{Device}); $DEV = "?" if !defined($DEV) || $DEV eq ""; # Safe default # Options specific (primarily) to window creation my $wo = { Device => $DEV, ### Tidy this up. AxisColour => $options{AxisColour}, # Axis colour HardLW => $options{HardLW}, # Line width for hardcopy devices, HardCH => $options{HardCH}, # Character height for hardcopy devices HardFont => $options{HardFont}, # For for hardcopy devices HardAxisColour => $options{HardAxisColour}, # Black colour as default on hardcopy devices. HardColour => $options{HardColour}, # Black as default plot colour on hardcopy devices. Axis => $options{Axis}, # The type of box AspectRatio => $options{AspectRatio}, # The aspect ratio of the plot window. WindowWidth => $options{WindowWidth}, # The width of the plot window in inches. WindowXSize => $options{WindowXSize}, # The X&Y size of a window, these will be WindowYSize => $options{WindowYSize}, # used to give the aspect ratio if defined. Size => $options{Size}, # alternative window size spec Unit => $options{Unit}, # Units for size spec WindowName => $options{WindowName}, # The window name given NXPanel => $options{NXPanel}, # The number of plotting panels NYPanel => $options{NYPanel}, # Ditto. TightLabels => undef, TitleSize => 1.0, Justify => $options{Justify}, # Justification of boxes & axes Scale => $options{Justify}, # device pixels per data pixel Pitch => $options{Pitch}, # Horizontal data pixels per unit Unit => $options{Unit}, # PGPLOT unit for pitch Pix => $options{Pix}, # Pixel aspect ratio Align => $options{Align}, # Alignment of vp in plot area DirAxis => $options{DirAxis}, # The default axis direction Border => $options{Border}, CharSize => $options{CharSize}, # Character size for annotation Erase => 0, Recording => 0, # Off by default. PlotPosition => 'Default' # The position of the plot on the page. }; # Options specific to plotting commands my $o = { Symbol => $options{Symbol}, # Symbol for points Colour => $options{Colour}, # Colour for plots CharSize => $options{CharSize}, # Character height ErrTerm => $options{ErrTerm}, # Size of error-bar terminators Erase => 0, # Whether to erase a panel when switching. Panel => undef, # What panel to switch to. LineStyle => $options{LineStyle}, # Solid linestyle Font => $options{Font}, # Normal font Fill => $options{Fill}, # Solid fill ITF => $options{ITF}, # Linear ITF Axis => $options{Axis}, # Standard axis-type Transform => $options{Transform}, # The transform used for plots. Justify => $options{Justify}, # Justification of boxes & axes Scale => $options{Justify}, # device pixels per data pixel Pitch => $options{Pitch}, # Horizontal data pixels per unit Unit => $options{Unit}, # PGPLOT unit for pitch Pix => $options{Pix}, # Pixel aspect ratio Align => $options{Align}, # Alignment of vp in plot area DirAxis => $options{DirAxis}, # The default axis direction LineWidth => $options{LineWidth}, TightLabels => $options{TightLabels}, TitleSize => $options{TitleSize}, XRange => $options{XRange}, YRange => $options{YRange}, BackgroundColour => $options{BackgroundColour}, # The following two should really be implemented as an Options # object, but that will make I/O of options somewhat difficult. # Note that the arrowsize is implemented as a synonym for the # charsize this should not cause any problems but might be worth # noting... # In addition to this the arrowsize below is also set to be undefined # by default which will automatically use the character size. # All these problems are historical.. Arrow => $options{Arrow}, Hatch => $options{Hatch}, XTitle => $options{XTitle}, # Label for X-axis YTitle => $options{YTitle}, # Label for Y-axis Title => $options{Title}, # Title for plot }; # Now for the synonyms my $s = {Color => 'Colour', 'Line-style' => 'LineStyle', 'Line-width' => 'LineWidth', 'Hatching' => 'Hatch', FillType => 'Fill', 'ArrowSize' => 'CharSize', AxisColor => 'AxisColour', HardAxisColor => 'HardAxisColour', HardColor => 'HardColor', BackgroundColor => 'BackgroundColour'}; # # And now for the lookup tables.. # my $t = { Colour => { 'White' => 0, 'Black' => 1, 'Red' => 2, 'Green' => 3, 'Blue' => 4, 'Cyan' => 5, 'Magenta' => 6, 'Yellow' => 7, 'Orange' => 8, 'DarkGray' => 14, 'DarkGrey' => 14, 'LightGray' => 15, 'LightGrey' => 15, 'CosmicSpectrum' => [0.269, 0.388, 0.342] }, BackgroundColour => { 'White' => 0, 'Black' => 1, 'Red' => 2, 'Green' => 3, 'Blue' => 4, 'Cyan' => 5, 'Magenta' => 6, 'Yellow' => 7, 'Orange' => 8, 'DarkGray' => 14, 'DarkGrey' => 14, 'LightGray' => 15, 'LightGrey' => 15 }, Symbol => { 'Square' => 0, 'Dot' => 1, 'Plus' => 2, 'Asterisk' => 3, 'Circle' => 4, 'Cross' => 5, 'Triangle' => 7, 'Earth' => 8, 'Sun' => 9, 'Diamond' => 11, 'Star' => 12, Default => 17 }, ITF => { 'Linear' => 0, 'Log' => 1, 'Sqrt' => 2 }, LineStyle => { 'Solid' => 1, 'Dashed' => 2, 'Dot-Dash' => 3, 'Dotted' => 4, 'Dash-Dot-Dot' => 5, '-' => 1, '--' => 2, '.-' => 3, '.' => 4, '-..' => 5 }, Font => { Normal => 1, Roman => 2,Italic => 3, Script => 4 }, Fill => { Solid => 1, Outline => 2, Hatched => 3, Cross_Hatched => 4, CrossHatched => 4 }, }; my $wt = { # valid values for axis parameter (eg env()) Axis => { Empty => '', Box => 'BC', Normal => 'BCNST', Axes => 'ABCNST', Grid => 'ABCGNST', LogX => ['BCLNST', 'BCNST'], LogY => ['BCNST', 'BCLNST'], LogXY => ['BCLNST', 'BCLNST'], '-2' => '', '-1' => 'BC', '0' => 'BCNST', '1' => 'ABCNST', '2' => 'ABCGNST', '10' => ['BCLNST', 'BCNST'], '20' => ['BCNST', 'BCLNST'], '30' => ['BCLNST', 'BCLNST'] }, AxisColour => { 'White' => 0, 'Black' => 1, 'Red' => 2, 'Green' => 3, 'Blue' => 4, 'Cyan' => 5, 'Magenta' => 6, 'Yellow' => 7, 'Orange' => 8, 'DarkGray' => 14, 'DarkGrey' => 14, 'LightGray' => 15, 'LightGrey' => 15 }, HardFont => { Normal => 1, Roman => 2,Italic => 3, Script => 4 }, HardAxisColour => { 'White' => 0, 'Black' => 1, 'Red' => 2, 'Green' => 3, 'Blue' => 4, 'Cyan' => 5, 'Magenta' => 6, 'Yellow' => 7, 'Orange' => 8, 'DarkGray' => 14, 'DarkGrey' => 14, 'LightGray' => 15, 'LightGrey' => 15 } }; # Set up the two primary sets of options for PGPLOT commands. my $window_options = PDL::Options->new($wo); $window_options->translation($wt); my $general_options = PDL::Options->new($o); $general_options->translation($t); $general_options->synonyms($s); return ($general_options, $window_options); } =head2 set_pgplot_options This function allows the user to set the default PGPLOT options. It is particularly useful in the C<.perldlrc> file since one can do use PDL::Graphics::PGPLOTOptions ('set_pgplot_options'); set_pgplot_options('Device' => '/xs', 'HardLW' => 3); for instance to set the default values. The main drawback is that the routine is rather unflexible with no synonyms or case-insensitivity. =cut sub set_pgplot_options { my %o; if (ref($_[0]) eq 'HASH') { %o = %{$_[0]}; } else { %o = @_; } foreach my $k (keys %o) { if (exists($options{$k})) { $options{$k} = $o{$k}; } elsif ($k =~ /Color/) { my $knew = $k; $knew =~ s/Color/Colour/; if (!exists($options{$knew})) { warn "Option $k is not recognised!\n"; } else { $options{$knew} = $o{$k}; } } else { warn "Option $k is not recognised!\n"; } } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/Window/�������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402045�014376� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/Window/Makefile.PL��������������������������������������������������������0000644�0601750�0601001�00000000477�12562522364�016401� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Graphics::PGPLOT::Window', 'VERSION_FROM' => '../../../Basic/Core/Version.pm', 'INC' => '-I../../../Basic/Core/', # for ppport.h (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/Window/typemap������������������������������������������������������������0000644�0601750�0601001�00000000140�12562522364�016014� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������TYPEMAP float T_NV float * T_FLOATS INPUT T_FLOATS $var = (float *)(SvPV(SvRV($arg), PL_na)) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/Window/Window.pm����������������������������������������������������������0000644�0601750�0601001�00000627450�13036512175�016236� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Graphics::PGPLOT::Window - A OO interface to PGPLOT windows =head1 SYNOPSIS pdl> use PDL::Graphics::PGPLOT::Window pdl> $win = pgwin(Device => '/xs'); pdl> $a = pdl [1..100] pdl> $b = sqrt($a) pdl> $win->line($b) pdl> $win->hold() pdl> $c = sin($a/10)*2 + 4 pdl> $win->line($c) In the following documentation the commands are not shown in their OO versions. This is for historical reasons and should not cause too much trouble. =head1 DESCRIPTION This package offers a OO interface to the PGPLOT plotting package. This is intended to replace the traditional interface in L<PDL::Graphics::PGPLOT|PDL::Graphics::PGPLOT> and contains interfaces to a large number of PGPLOT routines. Below the usage examples for each function tend to be given in the non-OO version for historical reasons. This will slowly be changed, but in the meantime refer to the section on OO-interface below to see how to convert the usage information below to OO usage (it is totally trivial). PDL::Graphics::PGPLOT::Window is an interface to the PGPLOT graphical libraries. It currently supports PGPLOT-5.2 and PGPLOT-5.2-cd2. The -cd2 version includes RGB output and anti-aliasing. High-level plotting commands: imag - Display an image (uses pgimag/pggray/pgrgbi as appropriate) fits_imag - Display a FITS image in scientific coordinates cont - Display image as contour map fits_cont - Display a FITS image in scientific coordinates as a contour map vect - Display 2 images as a vector field fits_vect - Display 2 FITS images in sci. coordinates as a vector field ctab - Load an image colour table ctab_info - Get information about currently loaded colour table line - Plot vector as connected points tline - Plot a collection of vectors as lines lines - Plot a polyline, multicolor vector [threadable] points - Plot vector as points tpoints - Plot a collection of vectors as points [threadable] errb - Plot error bars bin - Plot vector as histogram (e.g. bin(hist($data)) ) hi2d - Plot image as 2d histogram (not very good IMHO...) tcircle - Plot vectors as circles [threadable] label_axes - Print axis titles legend - Create a legend with different texts, linestyles etc. Low-level plotting commands: arrow - Draw an arrow poly - Draw a polygon rectangle - Draw a rectangle text - Write text in the plot area cursor - Interactively read cursor positions. circle - Draw a circle ellipse - Draw an ellipse. Device manipulation commands: new - Construct a new output device pgwin - Exported hook to new() close - Close a PGPLOT output device. hold - Hold current plot window range - allows overlays etc. release - Release back to freshly autoscaling for each command. held - Indicates whether the current window is held. focus - Set focus to the given device. erase - Erase the current window (or panel). options - Get the options set for the present output device. id - The ID for the device. device - The device type. name - The window name. Notes: C<$transform> for image/cont etc. is used in the same way as the C<TR()> array in the underlying PGPLOT FORTRAN routine but is, fortunately, zero-offset. The L<transform()|/transform> routine can be used to create this piddle. For completeness: The transformation array connect the pixel index to a world coordinate such that: X = tr[0] + tr[1]*i + tr[2]*j Y = tr[3] + tr[4]*i + tr[5]*j =head2 Variable passing and extensions In general variables are passed to the pgplot routines by using C<get_dataref> to get the reference to the values. Before passing to pgplot routines however, the data are checked to see if they are in accordance with the format (typically dimensionality) required by the PGPLOT routines. This is done using the routine C<checkarg> (internal to PGPLOT). This routine checks the dimensionality of the input data. If there are superfluous dimensions of size 1 they will be trimmed away until the dimensionality is correct. Example: Assume a piddle with dimensions (1,100,1,1) is passed to C<line>, which expects its inputs to be vectors. C<checkarg> will then return a piddle with dimensions (100). If instead the same piddle was passed to C<imag>, which requires 2D piddles as output, C<checkarg> would return a piddle with dimensionality (100, 1) (Dimensions are removed from the I<start>) Thus, if you want to provide support for another PGPLOT function, the structure currently look like this (there are plans to use the Options package to simplify the options parsing): # Extract the hash(es) on the commandline ($arg, $opt)=_extract_hash(@_); <Check the number of input parameters> <deal with $arg> checkarg($x, 3); # For a hypothetical 3D routine. &catch_signals; ... pgcube($n, $x->get_dataref); &release_signals; 1; (the catch_signals/release_signals pair prevent problems with the perl-PGPLOT interface if the user hits c-C during an operation). =head2 Setting options All routines in this package take a hash with options as an optional input. This options hash can be used to set parameters for the subsequent plotting without going via the PGPLOT commands. This is implemented such that the plotting settings (such as line width, line style etc.) are affected only for that plot, any global changes made, say, with C<pgslw()> are preserved. Some modifications apply when using the OO interface, see below. =head2 Alphabetical listing of standard options The following options are always parsed. Whether they have any importance depend on the routine invoked - e.g. line style is irrelevant for C<imag>, or the C<justify> option is irrelevant if the display is on 'hold'. This is indicated in the help text for the commands below. The options are not case sensitive and will match for unique substrings, but this is not encouraged as obscure options might invalidate what you thought was a unique substring. In the listing below examples are given of each option. The actual option can then be used in a plot command by specifying it as an argument to the function wanted (it can be placed anywhere in the command list). E.g: $opt={COLOR=>2}; line $x, $y, $opt; # This will plot a line with red color If you are plotting to a hardcopy device then a number of options use a different name: HardLW instead of LineWidth HardCH instead of CharSize HardFont instead of Font HardAxisColour instead of AxisColour HardColour instead of Colour [although I'm not sure when HardColour is actually used] =over 4 =item align If C<pix> is set, then images and plots are not stretched to fill the plot area. the C<align> string tells how to align them within the available area. 'L' and 'R' shove the plot against the left and right edges, respectively; 'B' and 'T' shove the plot against the bottom and top edges. The default is to center the image. e.g. 'BL' puts the image on the bottom left corner, while 'CT' centers the image horizontally while placing it at the top of the available plot area. This defaults to 'BT' for non-justified images, to 'CC' for justified images. =item arrow This options allows you to set the arrow shape, and optionally size for arrows for the vect routine. The arrow shape is specified as a hash with the key FS to set fill style, ANGLE to set the opening angle of the arrow head, VENT to set how much of the arrow head is cut out and SIZE to set the arrowsize. The following $opt = {ARROW => {FS=>1, ANGLE=>60, VENT=>0.3, SIZE=>5}}; will make a broad arrow of five times the normal size. Alternatively the arrow can be specified as a set of numbers corresponding to an extension to the syntax for pgsah. The equivalent to the above is $opt = {ARROW => pdl([1, 60, 0.3, 5})}; For the latter the arguments must be in the given order, and if any are not given the default values of 1, 45, 0.3 and 1.0 respectively will be used. =item arrowsize The arrowsize can be specified separately using this option to the options hash. It is useful if an arrowstyle has been set up and one wants to plot the same arrow with several sizes. Please note that it is B<not> possible to set arrowsize and character size in the same call to a plotting function. This should not be a problem in most cases. $opt = {ARROWSIZE => 2.5}; =item axis Set the axis value (see L</env>). If you pass in a scalar you set the axis for the whole plot. You can also pass in an array ref for finer control of the axes. If you set the option to a scalar value, you get one of a few standard layouts. You can specify them by name or by number: EMPTY (-2) draw no box, axes or labels BOX (-1) draw box only NORMAL (0) draw box and label it with coordinates AXES (1) same as NORMAL, but also draw (X=0,Y=0) axes GRID (2) same as AXES, but also draw grid lines LOGX (10) draw box and label X-axis logarithmically LOGY (20) draw box and label Y-axis logarithmically LOGXY (30) draw box and label both axes logarithmically When using logarithmic axes (C<LOGX>, C<LOGY> and C<LOGXY>) you normally need to log the data yourself, e.g. line $x->log10, $y, {axis=>'LOGX'}; For your convenience you can put PDL::Graphics::PGPLOT into autolog mode. In this mode a call to C<line> or C<points> will log the data for you and you can pass in the unmodified data, e.g. autolog(1); # enable automatic logarithm calculation line $x, $y, {axis=>'LOGX'}; # automatically displays logged x data You can use the function interface to enable autologging: autolog(1); or use it with a window reference (mode switching on a per window basis) $win->autolog(1); C<autolog> without arguments returns the current autolog setting (0=off, 1=on). If you set the C<AXIS> option to an array ref, then you can specify the box/axis options separately for the horizontal (ordinate; X coordinate; 0th element) and vertical (abscissa; Y coordinate; 1st element)) axes. Each element of the array ref should contain a PGPLOT format string. Presence or absence of specific characters flags particular options. For normal numeric labels, the options are: A : draw axis for this dimension. B : draw bottom (X) or left (Y) edge of frame. C : draw top (X) or right (Y) edge of frame. G : draw Grid of vertical (X) or horizontal (Y) lines. I : Invert ticks: draw them outside the plot rather than inside. L : Label the axis Logarithmically. P : Extend ("Project") major tick marks outside the box. M : Numeric labels go in the alternate place above (X) or to the right (Y) of the viewport. N : Numeric labels go in the usual location below (X) or to the left (Y) of the viewport T : Draw major tick marks at the major coordinate interval. S : Draw minor tick marks (subticks). V : Orient numeric labels Vertically. Only applicable to Y. (The default is to write them parallel to the axis.) 1 : Force decimal labelling, instead of automatic choice 2 : Force exponential labeling, instead of automatic. If you don't specify any axis value at all, the default is ['BCNST','BCNST'] for plots and ['BCINST','BCINST'] for images. (These list ref elements are handed on directly to the low-level PGPLOT routines). In addition, you can specify that your axis labels should be printed as days, hours, minutes, and seconds (ideal for julian dates and delta-t, or for angular quantities). You do that by setting additional character flags on the affected axis: X : Use HH MM SS.S time labeling rather than conventional numeric labels. The ordinate is in secsonds. Hours roll over at 24. Y : Like 'X' but the hour field runs past 24 if necessary. Z : Like 'X' but with a days field too (only shown where nonzero). H : Label the numbers with superscript d, h, m, and s symbols. D : Label the numbers with superscript o, ', and '' symbols. F : Omit first (lowest/leftmost) label; useful for tight layouts. O : Omit leading zeroes in numbers under 10 (e.g. " 3h 3m 1.2s" rather than "03h 03m 01.2s"). For example, to plot a numeric quantity versus Julian day of the year in a standard boxed plot with tick marks, you can use ["BNCSTZHO","BCNST"]. =item border Normally the limits are chosen so that the plot just fits; with this option you can increase (or decrease) the limits by either a relative (ie a fraction of the original axis width) or an absolute amount. Either specify a hash array, where the keys are C<TYPE> (set to 'relative' or 'absolute') and C<VALUE> (the amount to change the limits by), or set to 1, which is equivalent to BORDER => { TYPE => 'rel', VALUE => 0.05 } =item charsize Set the character/symbol size as a multiple of the standard size. $opt = {CHARSIZE => 1.5} The HardCH option should be used if you are plotting to a hardcopy device. =item colour (or color) Set the colour to be used for the subsequent plotting. This can be specified as a number, and the most used colours can also be specified with name, according to the following table (note that this only works for the default colour map): 0 - WHITE 1 - BLACK 2 - RED 3 - GREEN 4 - BLUE 5 - CYAN 6 - MAGENTA 7 - YELLOW 8 - ORANGE 14 - DARKGRAY 16 - LIGHTGRAY However there is a much more flexible mechanism to deal with colour. The colour can be set as a 3 or 4 element anonymous array (or piddle) which gives the RGB colours. If the array has four elements the first element is taken to be the colour index to change. For normal work you might want to simply use a 3 element array with R, G and B values and let the package deal with the details. The R,G and B values go from 0 to 1. In addition the package will also try to interpret non-recognised colour names using the default X11 lookup table, normally using the C<rgb.txt> that came with PGPLOT. For more details on the handling of colour it is best that the user consults the PGPLOT documentation. Further details on the handling of colour can be found in the documentation for the internal routine L</_set_colour>. The HardColour option should be used if you are plotting to a hardcopy device [this may be untrue?]. =item diraxis This sets the direction of the axes of a plot or image, when you don't explicitly set them with the XRange and YRange options. It's particularly useful when you want (for example) to put long wavelengths (larger numbers) on the left hand side of your plot, or when you want to plot an image in (RA,dec) coordinates. You can use either a scalar or a two-element perl array. If you set it to 0 (the default) then PDL will guess which direction you want to go. If you set it to a positive number, the axis will always increase to the right. If you set it to a negative number, the axis will always increase to the left. For example, [0,0] is the default, which is usually right. [1,1] tells PGPLOT to always increase the axis values up and to the right. For a plot of intensity (y-axis) versus wavelength (x-axis) you could say [-1,1]. This option is really only useful if you want to allow autoranging but need to set the direction that the axis goes. If you use the ranging options (C<XRange> and C<YRange>), you can change the direction by changing the order of the maximum and minimum values. That direction will override C<DirAxis>. =item filltype Set the fill type to be used by L</poly>, L</circle>, L</ellipse>, and L</rectangle> The fill can either be specified using numbers or name, according to the following table, where the recognised name is shown in capitals - it is case-insensitive, but the whole name must be specified. 1 - SOLID 2 - OUTLINE 3 - HATCHED 4 - CROSS_HATCHED $opt = {FILLTYPE => 'SOLID'}; (see below for an example of hatched fill) =item font Set the character font. This can either be specified as a number following the PGPLOT numbering or name as follows (name in capitals): 1 - NORMAL 2 - ROMAN 3 - ITALIC 4 - SCRIPT (Note that in a string, the font can be changed using the escape sequences C<\fn>, C<\fr>, C<\fi> and C<\fs> respectively) $opt = {FONT => 'ROMAN'}; gives the same result as $opt = {FONT => 2}; The HardFont option should be used if you are plotting to a hardcopy device. =item hatching Set the hatching to be used if either fillstyle 3 or 4 is selected (see above) The specification is similar to the one for specifying arrows. The arguments for the hatching is either given using a hash with the key ANGLE to set the angle that the hatch lines will make with the horizontal, SEPARATION to set the spacing of the hatch lines in units of 1% of C<min(height, width)> of the view surface, and PHASE to set the offset the hatching. Alternatively this can be specified as a 1x3 piddle C<$hatch=pdl[$angle, $sep, $phase]>. $opt = {FILLTYPE => 'HATCHED', HATCHING => {ANGLE=>30, SEPARATION=>4}}; Can also be specified as $opt = {FILL=> 'HATCHED', HATCH => pdl [30,4,0.0]}; For another example of hatching, see L</poly>. =item justify If C<justify> is set true, then the plot axes are shrunk to fit the plot or image and it specifies the aspect ratio of pixel coordinates in the plot or image. Setting justify=>1 will produce a correct-aspect-ratio, shrink-wrapped image or plot; setting justify=>0.5 will do the same thing but with a short and fat plot. The difference between C<justify> and C<pix> is that C<pix> does not affect the shape of the axes themselves. =item linestyle Set the line style. This can either be specified as a number following the PGPLOT numbering: 1 - SOLID line 2 - DASHED 3 - DOT-DASH-dot-dash 4 - DOTTED 5 - DASH-DOT-DOT-dot or using name (as given in capitals above). Thus the following two specifications both specify the line to be dotted: $opt = {LINESTYLE => 4}; $varopt = {LINESTYLE => 'DOTTED'}; The names are not case sensitive, but the full name is required. =item linewidth Set the line width. It is specified as a integer multiple of 0.13 mm. $opt = {LINEWIDTH => 10}; # A rather fat line The HardLW option should be used if you are plotting to a hardcopy device. =item pitch Sets the number of data pixels per inch on the output device. You can set the C<unit> (see below) to change this to any other PGPLOT unit (millimeters, pixels, etc.). Pitch is device independent, so an image should appear exactly the same size (e.g. C<Pitch=E<gt>100> is 100 dpi) regardless of output device. =item pix Sets the pixel aspect ratio height/width. The height is adjusted to the correct ratio, while maintaining any otherwise-set pitch or scale in the horizontal direction. Larger numbers yield tall, skinny pixels; smaller numbers yield short, fat pixels. =item scale Sets the number of output display pixels per data pixel. You can set the C<unit> (see below) to change this to number of PGPLOT units (inches, millimeters, etc.) per data pixel. C<scale> is deprecated, as it is not device-independent; but it does come in handy for quick work on digital displays, where aliasing might otherwise interfere with image interpretation. For example, C<scale=E<gt>1> displays images at their native resolution. =item Panel It is possible to define multiple plot ``panels'' with in a single window (see the L<NXPanel and NYPanel options in the constructor|/new>). You can explicitly set in which panel most plotting commands occur, by passing either a scalar or an array ref into the C<Panel> option. There is also a L<panel|PDL::Graphics::PGPLOT/panel> method, but its use is deprecated because of a wart with the PGPLOT interface. =item plotting & imaging range Explicitly set the plot range in x and y. X-range and Y-range are set separately via the aptly named options C<XRange> and C<YRange>. If omitted PGPLOT selects appropriate defaults (minimum and maximum of the data range in general). These options are ignored if the window is on hold. line $x, $y, {xr => [0,5]}; # y-range uses default line $x, $y, {XRange => [0,5], YRange => [-1,3]}; # fully specified range imag $im, {XRange => [30,50], YRange=>[-10,30]}; fits_imag $im, {XRange=>[-2,2], YRange=>[0,1]}; Imaging requires some thought if you don't want to lose a pixel off the edge of the image. Pixels are value-centered (they are centered on the coordinate whose value they represent), so the appropriate range to plot the entirety of a 100x100 pixel image is C<[-0.5,99.5]> on each axis. =back =head1 OBJECT-ORIENTED INTERFACE This section will briefly describe how the PDL::Graphics::PGPLOT::Window package can be used in an object-oriented (OO) approach and what the advantages of this would be. We will start with the latter =over =item Multiple windows. For the common user it is probably most interesting to use the OO interface when handling several open devices at the same time. If you have one variable for each plot device it is easier to distribute commands to the right device at the right time. This is the angle we will take in the rest of this description. =item Coding and abstraction At a more fundamental level it is desirable to approach a situation where it is possible to have a generic plotting interface which gives access to several plotting libraries, much as PGPLOT gives access to different output devices. Thus in such a hypothetical package one would say: my $win1 = Graphics::new('PGPLOT', {Device => '/xs'}); my $win2 = Graphics::new('gnuplot', {Background => 'Gray'}; From a more practical point of of view such abstraction also comes in handy when you write a large program package and you do not want to import routines nilly-willy in which case an OO approach with method calls is a lot cleaner. The pgwin exported constructor, arguably, breaks this philosophy; hopefully it will ``wither away'' when other compatible modules are available. =back Anyway, enough philosophizing, let us get down to Earth and give some examples of the use of OO PGPLOT. As an example we will take Odd (which happens to be a common Norwegian name) who is monitoring the birth of rabbits in O'Fib-o-nachy's farm (alternatively he can of course be monitoring processes or do something entirely different). Odd wants the user to be able to monitor both the birth rates and accumulated number of rabbits and the spatial distribution of the births. Since these are logically different he chooses to have two windows open: $rate_win = PDL::Graphics::PGPLOT::Window->new(Device => '/xw', Aspect => 1, WindowWidth => 5, NXPanel => 2); $area_win = PDL::Graphics::PGPLOT::Window->new(Device => '/xw', Aspect => 1, WindowWidth => 5); See the documentation for L<new|/new> below for a full overview of the options you can pass to the constructor. Next, Odd wants to create plotting areas for subsequent plots and maybe show the expected theoretical trends $rate_win->env(0, 10, 0, 1000, {XTitle => 'Days', YTitle => '#Rabbits'}); $rate_win->env(0, 10, 0, 100, {Xtitle=>'Days', Ytitle => 'Rabbits/day'}); $area_win->env(0, 1, 0, 1, {XTitle => 'Km', Ytitle => 'Km'}); # And theoretical prediction. $rate_win->line(sequence(10), fibonacci(10), {Panel => [1, 1]}); That is basically it. The commands should automatically focus the relevant window. Due to the limitations of PGPLOT this might however lead you to plot in the wrong panel... The package tries to be smart and do this correctly, but might get it wrong at times. =head1 STATE and RECORDING A new addition to the graphics interface is the ability to record plot commands. This can be useful when you create a nice-looking plot on the screen that you want to re-create on paper for instance. Or if you want to redo it with slightly changed variables for instance. This is still under development and views on the interface are welcome. The functionality is somewhat detached from the plotting functions described below so I will discuss them and their use here. Recording is off by default. To turn it on when you create a new device you can set the C<Recording> option to true, or you can set the C<$PDL::Graphics::PGPLOT::RECORDING> variable to 1. I recommend doing the latter in your C<.perldlrc> file at least since you will often have use for recording in the perldl or pdl2 script. =head2 Use of recording The recording is meant to help you recreate a plot with new data or to a different device. The most typical situation is that you have created a beautiful plot on screen and want to have a Postscript file with it. In the dreary old world you needed to go back and execute all commands manually, but with this wonderful new contraption, the recorder, you can just replay your commands: dev '/xs', {Recording => 1} $x = sequence(10) line $x, $x**2, {Linestyle => 'Dashed'} $s = retrieve_state() # Get the current tape out of the recorder. dev '/cps' replay $s This should result in a C<pgplot.ps> file with a parabola drawn with a dashed line. Note the command C<retrieve_state> which retrieves the current state of the recorder and return an object (of type PDL::Graphics::State) that is used to replay commands later. =head2 Controlling the recording Like any self-respecting recorder you can turn the recorder on and off using the C<turn_on_recording> and C<turn_off_recording> respectively. Likewise you can clear the state using the C<clear_state> command. $w=PDL::Graphics::PGPLOT::Window->new(Device => '/xs'); $w->turn_on_recording; $x=sequence(10); $y=$x*$x; $w->line($x, $y); $w->turn_off_recording; $w->line($y, $x); $w->turn_on_recording; $w->line($x, $y*$x); $state = $w->retrieve_state(); We can then replay C<$state> and get a parabola and a cubic plot. $w->replay($state); =head2 Tips and Gotchas! The data are stored in the state object as references to the real data. This leads to one good and one potentially bad consequence: =over =item The good is that you can create the plot and then subsequently redo the same plot using a different set of data. This is best explained by an example. Let us first create a simple gradient image and get a copy of the recording: $im = sequence(10,10) imag $im $s=retrieve_state Now this was a rather dull plot, and in reality we wanted to show an image using C<rvals>. Instead of re-creating the plot (which of course here would be the simplest option) we just change C<$im>: $im -= sequence(10,10) $im += rvals(10,10) Now replay the commands replay $s And hey presto! A totally different plot. Note however the trickery required to avoid losing reference to C<$im> =item This takes us immediately to the major problem with the recording though. Memory leakage! Since the recording keeps references to the data it can keep data from being freed (zero reference count) when you expect it to be. For instance, in this example, we lose totally track of the original $im variable, but since there is a reference to it in the state it will not be freed $im = sequence(1000,1000) imag $im $s = retrieve_state $im = rvals(10,10) Thus after the execution of these commands we still have a reference to a 1000x1000 array which takes up a lot of memory... The solution is to call C<clear> on the state variable: $s->clear() (This is done automatically if the variable goes out of scope). I forsee this problem to most acute when working on the C<perldl> or C<pdl2> command line, but since this is exactly where the recording is most useful the best advice is just to be careful and call clear on state variables. If you are working with scripts and use large images for instance I would instead recommend that you do not turn on recording unless you need it. =back =head1 FUNCTIONS A more detailed listing of the functions and their usage follows. For all functions we specify which options take effect and what other options exist for the given function. The function descriptions below are all given for the non-OO usage for historical reasons, but since the conversion to an OO method is trivial there is no major need for concern. Whenever you see a function example of the form Usage: a_simple_function($x, $y, $z [, $opt]); and you wish to use the OO version, just let your mind read the above line as: Usage: $win->a_simple_function($x, $y, $z [, $opt]); where C<$win> is a PDL::Graphics::PGPLOT::Window object. That is all. =head2 Window control functions. =head2 pgwin =for ref Exported constructor for PGPLOT object/device/plot window. =for usage Usage: pgwin($opt); Usage: pgwin($option->$value,...); Usage: pgwin($device); Parameters are passed on to new() and can either be specified by hash reference or as a list. See the documentation fo PDL::Graphics::PGPLOT::Window::new for details. Because pgwin is a convenience function, you can specify the device by passing in a single non-ref parameter. For even further convenience, you can even omit the '/' in the device specifier, so these two lines deliver the same result: $a = pgwin(gif); $a = new PDL::Graphics::PGPLOT::Window({Dev=>'/gif'}); =head2 new =for ref Constructor for PGPLOT object/device/plot window. =for usage Usage: PDL::Graphics::PGPLOT::Window->new($opt); Usage: PDL::Graphics::PGPLOT::Window->new($option=>$value,...); Options to new() can either be specified via a reference to a hash $win = PDL::Graphics::PGPLOT::Window->new({Dev=>'/xserve',ny=>2}); or directly, as an array # NOTE: no more {} ! $win = PDL::Graphics::PGPLOT::Window->new(Dev=>'/xserve',ny=>2); The following lists the recognised options: =over =item AspectRatio The aspect ratio of the image, in the sense vertical/horizontal. See the discussion on size setting. =item Device The type of device to use. The syntax of this is the one used by PGPLOT. =item Hold Hold the plot window so that subsequent plots can plot over existing plots. This can be adjusted with the C<hold()> and C<release()> methods. =item NXPanel The number of panels in the X-direction =item NYPanel The number of panels in the Y-direction =item Size Yet another way to identify the plot window size -- this takes a scalar or an array ref containing one, two, or three numbers. One number gives you a square window. Two gives you a rectangular window C<(X,Y)>. Three lets you specify the unit compactly (e.g. C<< [<X>,<Y>,1] >> for inches, C<< [<X>,<Y>,2] >> for mm) but is deprecated in favor of using the C<Unit> option. See the discussion on size setting. =item Unit The unit to use for size setting. PGPLOT accepts inch, mm, or pixel. The default unit is inches for historical reasons, but you can choose millimeters or (God forbid) pixels as well. String or numeric specifications are OK (0=normalized, 1=inches, 2=mm, 3=pixels). Normalized units make no sense here and are not accepted. Ideally someone will one day hook this into the CPAN units parser so you can specify window size in rods or attoparsecs. =item WindowName The name to give to the window. No particular use is made of this at present. It would be great if it was possible to change the title of the window frame. =item WindowWidth The width of the window in inches (or the specified Unit). See the discussion on size setting. =item WindowXSize and WindowYSize The width and height of the window in inches (or the specified Unit). See the discussion on size setting. =back An important point to note is that the default values of most options can be specified by passing these to the constructor. All general options (common to several functions) can be adjusted in such a way, but function specific options can not be set in this way (this is a design limitation which is unlikely to be changed). Thus the following call will set up a window where the default axis colour will be yellow and where plot lines normally have red colour and dashed linestyle. $win = PDL::Graphics::PGPLOT::Window->new(Device => '/xs', AxisColour => 'Yellow', Colour => 'Red', LineStyle => 'Dashed'); Size setting: There are a gazillion ways to set window size, in keeping with TIMTOWTDI. In general you can get away with passing any unique combination of an C<< <X> >> size, a C<< <Y> >>size, and/or an aspect ratio. In increasing order of precedence, the options are: (C<Units>, C<AspectRatio>, C<WindowWidth>, C<< Window<X,Y>Size >>, C<Size>). So if you specify an AspectRatio *and* an X and a Y coordinate, the AspectRatio is ignored. Likewise, if you specify Units and a three-component Size, the Units option is ignored in favor of the numeric unit in the Size. If you don't specify enough information to set the size of the window, you get the default pane size and shape for that device. =head2 close =for ref Close a plot window =for usage Usage: $win->close() Close the current window. This does not necessarily mean that the window is removed from your screen, but it does ensure that the device is closed. A message will be printed to STDOUT giving the name of the file created if the plot was made to a hardcopy device and C<$PDL::verbose> is true. =head2 held =for ref Check if a window is on hold =for usage $is_held = $win->held(); Function to check whether the window is held or not. =head2 hold =for ref Hold the present window. =for usage Usage: $win->hold() Holds the present window so that subsequent plot commands overplots. =head2 panel =for ref Switch to a different panel =for usage $win->panel(<num>); Move to a different panel on the plotting surface. Note that you will need to erase it manually if that is what you require. This routine currently does something you probably don't want, and hence is deprecated for most use: if you say $win->panel(1); $win->imag($image); then $image will actually be displayed in panel B<2>. That's because the main plotting routines such as line and imag all advance the panel when necessary. Instead, it's better to use the Panel option within plotting commands, if you want to set the panel explicitly. =head2 release =for ref Release a plot window. =for usage $win->release() Release a plot window so that subsequent plot commands move to the next panel or erase the plot and create a new plot. =head2 erase =for ref Erase plot =for usage $win->erase($opt); Erase a plot area. This accepts the option C<Panel> or alternatively a number or array reference which makes it possible to specify the panel to erase when working with several panels. =head2 Plotting functions =head2 env =for ref Define a plot window, and put graphics on 'hold' =for usage $win->env( $xmin, $xmax, $ymin, $ymax, [$justify, $axis] ); $win->env( $xmin, $xmax, $ymin, $ymax, [$options] ); C<$xmin>, C<$xmax>, C<$ymin>, C<$ymax> are the plot boundaries. C<$justify> is a boolean value (default is B<0>); if true the axes scales will be the same (see C<justify>). C<$axis> describes how the axes should be drawn (see C<axis>) and defaults to B<0>. If the second form is used, $justify and $axis can be set in the options hash, for example: $win->env( 0, 100, 0, 50, {JUSTIFY => 1, AXIS => 'GRID', CHARSIZE => 0.7} ); In addition the following options can also be set for C<env>: =over =item PlotPosition The position of the plot on the page relative to the view surface in normalised coordinates as an anonymous array. The array should contain the lower and upper X-limits and then the lower and upper Y-limits. To place two plots above each other with no space between them you could do $win->env(0, 1, 0, 1, {PlotPosition => [0.1, 0.5, 0.1, 0.5]}); $win->env(5, 9, 0, 8, {PlotPosition => [0.1, 0.5, 0.5, 0.9]}); =item Axis, Justify, Border See the description of general options for these options. =item AxisColour Set the colour of the coordinate axes. =item XTitle, YTitle, Title, Font, CharSize Axes titles and the font and size to print them. =back =head2 label_axes =for ref Label plot axes =for usage $win->label_axes(<xtitle>, <ytitle>, <plot title>, $options); Draw labels for each axis on a plot. =head2 imag =for ref Display an image (uses C<pgimag()>/C<pggray()> as appropriate) =for usage $win->imag ( $image, [$min, $max, $transform], [$opt] ) NOTES C<$transform> for image/cont etc. is used in the same way as the C<TR()> array in the underlying PGPLOT FORTRAN routine but is, fortunately, zero-offset. The L<transform()|/transform> routine can be used to create this piddle. If C<$image> is two-dimensional, you get a grey or pseudocolor image using the scalar values at each X,Y point. If C<$image> is three-dimensional and the third dimension has order 3, then it is treated as an RGB true-color image via L<rgbi|rgbi>. There are several options related to scaling. By default, the image is scaled to fit the PGPLOT default viewport on the screen. Scaling, aspect ratio preservation, and 1:1 pixel mapping are available. (1:1 pixel mapping is useful for avoiding display artifacts, but it's not recommended for final output as it's not device-independent.) Here's an additional complication: the "pixel" stuff refers not (necessarily) to normal image pixels, but rather to I<transformed> image pixels. That is to say, if you feed in a transform matrix via the C<TRANSFORM> option, the C<PIX>, C<SCALE>, etc. options all refer to the transformed coordinates and not physical image pixels. That is a Good Thing because it, e.g., lets you specify plate scales of your output plots directly! See fits_imag for an example application. If you do not feed in a transform matrix, then the identity matrix is applied so that the scaling options refer to original data pixels. To draw a colour bar (or wedge), either use the C<DrawWedge> option, or the C<draw_wedge()> routine (once the image has been drawn). Options recognised: =over 3 =item ITF the image transfer function applied to the pixel values. It may be one of 'LINEAR', 'LOG', 'SQRT' (lower case is acceptable). It defaults to 'LINEAR'. =item MIN Sets the minimum value to be used for calculation of the color-table stretch. =item MAX Sets the maximum value for the same. =item RANGE A more compact way to specify MIN and MAX, as a list: you can say "Range=>[0,10]" to scale the color table for brightness values between 0 and 10 in the iamge data. =item CRANGE Image values between MIN and MAX are scaled to an interval in normalized color domain space, on the interval [0,1], before lookup in the window's color table. CRANGE lets you use only a part of the color table by specifying your own range -- e.g. if you say "CRange=>[0.25,0.75]" then only the middle half of the pseudocolor space will be used. (See the writeup on ctab().) =item TRANSFORM The PGPLOT transform 'matrix' as a 6x1 vector for display =item DrawWedge set to 1 to draw a colour bar (default is 0) =item Wedge see the draw_wedge() routine =back The following standard options influence this command: AXIS, BORDER, JUSTIFY, SCALE, PIX, PITCH, ALIGN, XRANGE, YRANGE =for example To see an image with maximum size in the current window, but square pixels, say: $win->imag( $a, { PIX=>1 } ); An alternative approach is to try: $win->imag( $a, { JUSTIFY=>1 } ); To see the same image, scaled 1:1 with device pixels, say: $win->imag( $a, { SCALE=>1 } ); To see an image made on a device with 1:2 pixel aspect ratio, with X pixels the same as original image pixels, say $win->imag( $a, { PIX=>0.5, SCALE=>2 } ); To display an image at 100 dpi on any device, say: $win->imag( $a, { PITCH=>100 } ); To display an image with 100 micron pixels, say: $win->imag( $a, { PITCH=>10, UNIT=>'mm' } ); =head2 imag1 =for ref Display an image with correct aspect ratio =for usage $win->imag1 ( $image, [$min, $max, $transform], [$opt] ) This is syntactic sugar for $win->imag( { PIX=>1, ALIGN=>'CC' } ); =head2 rgbi =for ref Display an RGB color image The calling sequence is exactly like L</imag>, except that the input image must have three dimensions: C<N x M x 3>. The last dimension is the (R,G,B) color value. This routine requires B<pgplot 5.3devel> or later. Calling rgbi explicitly is not necessary, as calling image with an appropriately dimensioned RGB triplet makes it fall through to rgbi. =head2 fits_imag =for ref Display a FITS image with correct axes =for usage $win->fits_imag( image, [$min, $max], [$opt] ); NOTES =over 3 =item Titles: Currently fits_imag also generates titles for you by default and appends the FITS header scientific units if they're present. So if you say $pdl->hdr->{CTYPE1} = "Flamziness"; $pdl->hdr->{CUNIT1} = "milliBleems"; $win->fits_imag($pdl); then you get an X title of "Flamziness (milliBleems)". But you can (of course) override that by specifying the XTitle and YTitle switches: $win->fits_imag($pdl,{Xtitle=>"Arbitrary"}); will give you "Arbitrary" as an X axis title, regardless of what's in the header. =item Scaling and aspect ratio: If CUNIT1 and CUNIT2 (or, if they're missing, CTYPE1 and CTYPE2) agree, then the default pixel aspect ratio is 1 (in scientific units, NOT in original pixels). If they don't agree (as for a spectrum) then the default pixel aspect ratio is adjusted automatically to match the plot viewport and other options you've specified. You can override the image scaling using the SCALE, PIX, or PITCH options just as with L<the imag() method|/imag> -- but those parameters refer to the scientific coordinate system rather than to the pixel coordinate system (e.g. C<PITCH=E<gt>100> means "100 scientific units per inch", and C<SCALE=E<gt>1> means "1 scientific unit per device pixel"). See L<the imag() writeup|/imag> for more info on these options. The default value of the C<ALIGN> option is 'CC' -- centering the image both vertically and horizontally. =item Axis direction: By default, fits_imag tries to guess which direction your axes are meant to go (left-to-right or right-to-left) using the CDELT keywords: if C<< CDELT >> is negative, then rather than reflecting the image fits_imag will plot the X axis so that the highest values are on the left. This is the most convenient behavior for folks who use calibrated (RA,DEC) images, but it is technically incorrect. To force the direction, use the DirAxis option. Setting C<< DirAxis=>1 >> (abbreviated C<< di=>1 >>) will force the scientific axes to increase to the right, reversing the image as necessary. =item Color wedge: By default fits_imag draws a color wedge on the right; you can explicitly set the C<DrawWedge> option to 0 to avoid this. Use the C<WTitle> option to set the wedge title. =item Alternate WCS coordinates: The default behaviour is to use the primary/default WCS information in the FITS header (i.e. the C<CRVAL1>,C<CRPIX1>,... keywords). The Greisen et al. standard (L<http://fits.cv.nrao.edu/documents/wcs/wcs.html>) allows alternative/additional mappings to be included in a header; these are denoted by the letters C<A> to C<Z>. If you know that your image contains such a mapping then you can use the C<WCS> option to select the appropriate letter. For example, if you had read in a Chandra image created by the CIAO software package then you can display the image in the C<physical> coordinate system by saying: $win->fits_imag( $pdl, { wcs => 'p' } ); The identity transform is used if you select a mapping for which there is no information in the header. Please note that this support is B<experimental> and is not guaranteed to work correctly; please see the documentation for the L<_FITS_tr|/_FITS_tr> routine for more information. =back =head2 fits_rgbi =for ref Display an RGB FITS image with correct axes =for usage $win->fits_rgbi( image, [$min,$max], [$opt] ); Works exactly like L<fits_imag|/fits_imag>, but the image must be in (X,Y,RGB) form. Only the first two axes of the FITS header are examined. =head2 fits_cont =for ref Draw contours of an image, labelling the axes using the WCS information in the FITS header of the image. =for usage $win->fits_cont( image, [$contours, $transform, $misval], [$opt] ) Does the same thing for the L<cont|/cont> routine that L<fits_imag|/fits_imag> does for the L<imag|/imag> routines. =head2 draw_wedge =for ref Add a wedge (colour bar) to an image. =for usage $win->draw_wedge( [$opt] ) Adds a wedge - shows the mapping between colour and value for a pixel - to the current image. This can also be achieved by setting C<DrawWedge> to 1 when calling the C<imag> routine. The colour and font size are the same as used to draw the image axes (although this will probably fail if you did it yourself). To control the size and location of the wedge, use the C<Wedge> option, giving it a hash reference containing any of the following: =over 4 =item Side Which side of the image to draw the wedge: can be one of 'B', 'L', 'T', or 'R'. Default is B<'R'>. =item Displacement How far from the edge of the image should the wedge be drawn, in units of character size. To draw within the image use a negative value. Default is B<1.5>. =item Width How wide should the wedge be, in units of character size. Default is B<2>. =item Label A text label to be added to the wedge. If set, it is probably worth increasing the C<Width> value by about 1 to keep the text readable. Default is B<''>. This is equivalent to the C<WTitle> option to L<imag|imag>, L<fits_imag|fits_imag>, and similar methods. =item ForeGround (synonym Fg) The pixel value corresponding to the "maximum" colour. If C<undef>, uses the value used by C<imag> (recommended choice). Default is C<undef>. =item BackGround (synonym Bg) The pixel value corresponding to the "minimum" colour. If C<undef>, uses the value used by C<imag> (recommended choice). Default is C<undef>. =back =for example $a = rvals(50,50); $win = PDL::Graphics::PGPLOT::Window->new(); $win->imag( $a, { Justify => 1, ITF => 'sqrt' } ); $win->draw_wedge( { Wedge => { Width => 4, Label => 'foo' } } ); # although the following might be more sensible $win->imag( $a, { Justify => 1, ITF => 'sqrt', DrawWedge => 1, Wedge => { Width => 4, Label => 'foo'} } ); =head2 ctab =for ref Load an image colour table. Usage: =for usage ctab ( $name, [$contrast, $brightness] ) # Builtin col table ctab ( $ctab, [$contrast, $brightness] ) # $ctab is Nx4 array ctab ( $levels, $red, $green, $blue, [$contrast, $brightness] ) ctab ( '', $contrast, $brightness ) # use last color table Note: See L<PDL::Graphics::LUT|PDL::Graphics::LUT> for access to a large number of colour tables. Notionally, all non-RGB images and vectors have their colors looked up in the window's color table. Colors in images and such are scaled to a normalized pseudocolor domain on the line segment [0,1]; the color table is a piecewise linear function that maps this one-dimensional scale to the three-dimensional normalized RGB color space [0,1]^3. You can specify specific indexed colors by appropriate use of the (levels,red,green,blue) syntax -- but that is deprecated, since the actual available number of colors can change depending on the output device. (Someone needs to write a specific hardware-dependent lookup table interface). See also L<imag|imag> for a description of how to use only part of the color table for a particular image. =head2 ctab_info =for ref Return information about the currently loaded color table =head2 autolog =for ref Turn on automatic logarithmic scaling in C<line> and C<points> =for usage Usage: autolog([0|1]); Setting the argument to 1 turns on automatic log scaling and setting it to zero turns it off again. The function can be used in both the object oriented and standard interface. To learn more, see the documentation for the L<axis option|axis>. =for example my $win = PDL::Graphics::PGPLOT::Window->new(dev=>'/xserve'); my $x=sequence(10); my $y=$x*$x+1; $win->autolog(1); $win->line($x,$y, {Axis => 'LogY'}); =head2 line =for ref Plot vector as connected points If the 'MISSING' option is specified, those points in the C<$y> vector which are equal to the MISSING value are not plotted, but are skipped over. This allows one to quickly draw multiple lines with one call to C<line>, for example to draw coastlines for maps. =for usage Usage: line ( [$x,] $y, [$opt] ) The following standard options influence this command: AXIS, BORDER, COLO(U)R, LINESTYLE, LINEWIDTH, MISSING, JUSTIFY, SCALE, PITCH, PIX, ALIGN =for example $x = sequence(10)/10.; $y = sin($x)**2; # Draw a red dot-dashed line line $x, $y, {COLOR => 'RED', LINESTYLE=>3}; =head2 lines =for ref Plot a list of vectors as discrete sets of connected points This works much like L<line|line>, but for discrete sets of connected points. There are two ways to break lines: you can pass in x/y coordinates just like in L<line|line>, but with an additional C<pen> piddle that indicates whether the pen is up or down on the line segment following each point (so you set it to zero at the end of each line segment you want to draw); or you can pass in an array ref containing a list of single polylines to draw. Happily, there's extra meaning packed into the C<pen> piddle: it multiplies the COLO(U)R that you set, so if you feed in boolean values you get what you expect -- but you can also feed in integer or floating-point values to get multicolored lines. Furthermore, the sign bit of C<pen> can be used to draw hairline segments: if C<pen> is negative, then the segment is drawn as though it were positive but with LineWidth and HardLW set to 1 (the minimum). Equally happily, even if you are using the array ref mechanism to break your polylines you can feed in an array ref of C<pen> values to take advantage of the color functionality or further dice your polylines. Note that, unlike L<line|line>, C<lines> has no no specify-$y-only calling path. That's because C<lines> is intended more for line art than for plotting, so you always have to specify both $x and $y. Infinite or bad values are ignored -- that is to say, if your vector contains a non-finite point, that point breaks the vector just as if you set pen=0 for both that point and the point before it. =for usage Usage: $w->lines( $x, $y, [$pen], [$opt] ); $w->lines( $xy, [$pen], [$opt] ); $w->lines( \@xvects, \@yvects, [\@pen], [$opt] ); $w->lines( \@xyvects, [\@pen], [$opt] ); The following standard options influence this command: AXIS, BORDER, COLO(U)R, LINESTYLE, LINEWIDTH, MISSING, JUSTIFY, SCALE, PITCH, PIX, ALIGN CAVEAT: Setting C<pen> elements to 0 prevents drawing altogether, so you can't use that to draw in the background color. =head2 points =for ref Plot vector as points =for usage Usage: points ( [$x,] $y, [$symbol(s)], [$opt] ) Options recognised: SYMBOL - Either a piddle with the same dimensions as $x, containing the symbol associated to each point or a number specifying the symbol to use for every point, or a name specifying the symbol to use according to the following (recognised name in capital letters): 0 - SQUARE 1 - DOT 2 - PLUS 3 - ASTERISK 4 - CIRCLE 5 - CROSS 7 - TRIANGLE 8 - EARTH 9 - SUN 11 - DIAMOND 12- STAR PLOTLINE - If this is >0 a line will be drawn through the points. The following standard options influence this command: AXIS, BORDER, CHARSIZE, COLOUR, LINESTYLE, LINEWIDTH, JUSTIFY, SCALE, PIX, PITCH, ALIGN C<SymbolSize> allows adjusting the symbol size, it defaults to CharSize. The C<ColorValues> option allows one to plot XYZ data with the Z axis mapped to a color value. For example: use PDL::Graphics::LUT; ctab(lut_data('idl5')); # set up color palette to 'idl5' points ($x, $y, {ColorValues => $z}); =for example $y = sequence(10)**2+random(10); # Plot blue stars with a solid line through: points $y, {PLOTLINE => 1, COLOUR => BLUE, symbol => STAR}; # case insensitive =head2 errb =for ref Plot error bars (using C<pgerrb()>) Usage: =for usage errb ( $y, $yerrors, [$opt] ) errb ( $x, $y, $yerrors, [$opt] ) errb ( $x, $y, $xerrors, $yerrors, [$opt] ) errb ( $x, $y, $xloerr, $xhierr, $yloerr, $yhierr, [$opt]) Any of the error bar parameters may be C<undef> to omit those error bars. Options recognised: TERM - Length of terminals in multiples of the default length SYMBOL - Plot the datapoints using the symbol value given, either as name or number - see documentation for 'points' The following standard options influence this command: AXIS, BORDER, CHARSIZE, COLOUR, LINESTYLE, LINEWIDTH, JUSTIFY, SCALE, PIX, PITCH, ALIGN =for example $y = sequence(10)**2+random(10); $sigma=0.5*sqrt($y); errb $y, $sigma, {COLOUR => RED, SYMBOL => 18}; # plot X bars only errb( $x, $y, $xerrors, undef ); # plot negative going bars only errb( $x, $y, $xloerr, undef, $yloerr, undef ); =head2 cont =for ref Display image as contour map =for usage Usage: cont ( $image, [$contours, $transform, $misval], [$opt] ) Notes: C<$transform> for image/cont etc. is used in the same way as the C<TR()> array in the underlying PGPLOT FORTRAN routine but is, fortunately, zero-offset. The L<transform()|/transform> routine can be used to create this piddle. Options recognised: CONTOURS - A piddle with the contour levels FOLLOW - Follow the contour lines around (uses pgcont rather than pgcons) If this is set >0 the chosen linestyle will be ignored and solid line used for the positive contours and dashed line for the negative contours. LABELS - An array of strings with labels for each contour LABELCOLOUR - The colour of labels if different from the draw colour This will not interfere with the setting of draw colour using the colour keyword. MISSING - The value to ignore for contouring NCONTOURS - The number of contours wanted for automatical creation, overridden by CONTOURS TRANSFORM - The pixel-to-world coordinate transform vector The following standard options influence this command: AXIS, BORDER, COLOUR, LINESTYLE, LINEWIDTH, JUSTIFY, SCALE, PIX, PITCH, ALIGN =for example $x=sequence(10,10); $ncont = 4; $labels= ['COLD', 'COLDER', 'FREEZING', 'NORWAY'] # This will give four blue contour lines labelled in red. cont $x, {NCONT => $ncont, LABELS => $labels, LABELCOLOR => RED, COLOR => BLUE} =head2 bin =for ref Plot vector as histogram (e.g. C<bin(hist($data))>) =for usage Usage: bin ( [$x,] $data ) Options recognised: CENTRE - (default=1) if true, the x values denote the centre of the bin otherwise they give the lower-edge (in x) of the bin CENTER - as CENTRE The following standard options influence this command: AXIS, BORDER, COLOUR, JUSTIFY, LINESTYLE, LINEWIDTH =head2 hi2d =for ref Plot image as 2d histogram (not very good IMHO...) =for usage Usage: hi2d ( $image, [$x, $ioff, $bias], [$opt] ) Options recognised: IOFFSET - The offset for each array slice. >0 slants to the right <0 to the left. BIAS - The bias to shift each array slice up by. The following standard options influence this command: AXIS, BORDER, JUSTIFY, SCALE, PIX, PITCH, ALIGN Note that meddling with the C<ioffset> and C<bias> often will require you to change the default plot range somewhat. It is also worth noting that if you have TriD working you will probably be better off using L<mesh3d|PDL::Graphics::TriD/mesh3d> or a similar command - see the L<PDL::Graphics::TriD|PDL::Graphics::TriD> module. =for example $r=sequence(100)/50-1.0; $y=exp(-$r**2)*transpose(exp(-$r**2)) hi2d $y, {IOFF => 1.5, BIAS => 0.07}; =head2 arrow =for ref Plot an arrow =for usage Usage: arrow($x1, $y1, $x2, $y2, [, $opt]); Plot an arrow from C<$x1, $y1> to C<$x2, $y2>. The arrow shape can be set using the option C<Arrow>. See the documentation for general options for details about this option (and the example below): =for example Example: arrow(0, 1, 1, 2, {Arrow => {FS => 1, Angle => 1, Vent => 0.3, Size => 5}}); which draws a broad, large arrow from (0, 1) to (1, 2). =head2 rect =for ref Draw a non-rotated rectangle Usage: rect ( $x1, $x2, $y1, $y2 ) Options recognised: The following standard options influence this command: AXIS, BORDER, COLOUR, FILLTYPE, HATCHING, LINESTYLE, LINEWIDTH JUSTIFY, SCALE, PIX, PITCH, ALIGN =head2 poly =for ref Draw a polygon =for usage Usage: poly ( $x, $y ) Options recognised: The following standard options influence this command: AXIS, BORDER, COLOUR, FILLTYPE, HATCHING, LINESTYLE, LINEWIDTH JUSTIFY, SCALE, PIX, PITCH, ALIGN =for example # Fill with hatching in two different colours $x=sequence(10)/10; # First fill with cyan hatching poly $x, $x**2, {COLOR=>5, FILL=>3}; hold; # Then do it over again with the hatching offset in phase: poly $x, $x**2, {COLOR=>6, FILL=>3, HATCH=>{PHASE=>0.5}}; release; =head2 circle =for ref Plot a circle on the display using the fill setting. =for usage Usage: circle($x, $y, $radius [, $opt]); All arguments can alternatively be given in the options hash using the following options: =over =item XCenter and YCenter The position of the center of the circle =item Radius The radius of the circle. =back =head2 ellipse =for ref Plot an ellipse, optionally using fill style. =for usage Usage: ellipse($x, $y, $a, $b, $theta [, $opt]); All arguments can alternatively be given in the options hash using the following options: =over =item MajorAxis The major axis of the ellipse - this must be defined or C<$a> must be given. =item MinorAxis The minor axis, like A this is required. =item Theta (synonym Angle) The orientation of the ellipse - defaults to 0.0. This is given in radians. =item XCenter and YCenter The coordinates of the center of the ellipse. These must be specified or C<$x> and C<$y> must be given. =item NPoints The number of points used to draw the ellipse. This defaults to 100 and might need changing in the case of very large ellipses. =back The routine also recognises the same standard options as accepted by L<poly|/poly>. =head2 rectangle =for ref Draw a rectangle. =for usage Usage: rectangle($xcenter, $ycenter, $xside, $yside, [, $angle, $opt]); This routine draws a rectangle with the chosen fill style. Internally it calls L<poly|/poly> which is somewhat slower than C<pgrect> but which allows for rotated rectangles as well. The routine recognises the same options as C<poly> and in addition the following: =over =item XCenter and YCenter The position of the center of the rectangle. XCentre and YCentre are valid synonyms. =item XSide and YSide The length of the X and Y sides. If only one is specified the shape is taken to be square with that as the side-length, alternatively the user can set Side =item Side The length of the sides of the rectangle (in this case a square) - syntactic sugar for setting XSide and YSide identical. This is overridden by XSide or YSide if any of those are set. =item Angle (synonym Theta) The angle at which the rectangle is to be drawn. This defaults to 0.0 and is given in radians. =back =head2 vect =for ref Display 2 images as a vector field =for usage Usage: vect ( $w, $a, $b, [$scale, $pos, $transform, $misval], { opt } ); $w->vect($a,$b,[$scale,$pos,$transform,$misval], { opt }); Notes: C<$transform> for image/cont etc. is used in the same way as the C<TR()> array in the underlying PGPLOT FORTRAN routine but is, fortunately, zero-offset. The L<transform()|/transform> routine can be used to create this piddle. This routine will plot a vector field. C<$a> is the horizontal component and C<$b> the vertical component. The scale factor converts between vector length units and scientific positional units. You can set the scale, position, etc. either by passing in parameters in the normal parameter list or by passing in options. Options recognised: SCALE - Set the scale factor for vector lengths. POS - Set the position of vectors. <0 - vector head at coordinate >0 - vector base at coordinate =0 - vector centered on the coordinate TRANSFORM - The pixel-to-world coordinate transform vector MISSING - Elements with this value are ignored. The following standard options influence this command: ARROW, ARROWSIZE, AXIS, BORDER, CHARSIZE, COLOUR, LINESTYLE, LINEWIDTH, =for example $a=rvals(11,11,{Centre=>[5,5]}); $b=rvals(11,11,{Centre=>[0,0]}); vect $a, $b, {COLOR=>YELLOW, ARROWSIZE=>0.5, LINESTYLE=>dashed}; =head2 fits_vect =for ref Display a pair of 2-D piddles as vectors, with FITS header interpretation =for usage Usage: fits_vect ($a, $b, [$scale, $pos, $transform, $misval] ) C<fits_vect> is to L<vect|/vect> as L<fits_imag|/fits_imag> is to L<imag|imag>. =head2 transform =for ref Create transform array for contour and image plotting =for usage $win->transform([$xdim,$ydim], $options); (For information on coordinate transforms, try L<PDL::Transform|PDL::Transform>.) This function creates a transform array in the format required by the image and contouring routines. You must call it with the dimensions of your image as arguments or pass these as an anonymous hash - see the example below. =over =item Angle The rotation angle of the transform, in radians. Positive numbers rotate the image clockwise on the screen. =item ImageDimensions The dimensions of the image the transform is required for. The dimensions should be passed as a reference to an array. =item Pixinc The increment in output coordinate per pixel. =item ImageCenter (or ImageCentre) The centre of the image as an anonymous array B<or> as a scalar, in scientific coordinates. In the latter case the x and y value for the center will be set equal to this scalar. This is particularly useful in the common case when the center is (0, 0). (ImageCenter overrides RefPos if both are specified). =item RefPos (or ReferencePosition) If you wish to set a pixel other than the image centre to a given value, use this option. It should be supplied with a reference to an array containing 2 2-element array references, e.g. RefPos => [ [ $xpix, $ypix ], [ $xplot, $yplot ] ] This will label pixel C<($xpix,$ypix)> as being at position C<($xplot,$yplot)>. For example RefPos => [ [100,74], [ 0, 0 ] ] sets the scientific coordinate origin to be at the center of the (100,74) pixel coordinate. The pixel coordinates are pixel-centered, and start counting from 0 (as all good pixel coordinates should). =back Example: $im = rvals(100, 100); $w = PDL::Graphics::PGPLOT::Window->new(Device => '/xs'); $t = $w->transform(dims($im), {ImageCenter => 0, Pixinc => 5}); $w->imag($im, {Transform => $t}); =head2 tline =for ref Threaded line plotting =for usage $win->tline($x, $y, $options); This is a threaded interface to C<line>. This is convenient if you have a 2D array and want to plot out every line in one go. The routine will apply any options you apply in a "reasonable" way. In the sense that it will loop over the options wrapping over if there are less options than lines. Example: $h={Colour => ['Red', '1', 4], Linestyle => ['Solid' ,'Dashed']}; $tx=zeroes(100,5)->xlinvals(-5,5); $ty = $tx + $tx->yvals; $win->tline($tx, $ty, $h); =head2 tpoints =for ref A threaded interface to points =for usage Usage: tpoints($x, $y, $options); This is a threaded interface to C<points>. This is convenient if you have a 2D array and want to plot out every line in one go. The routine will apply any options you apply in a "reasonable" way. In the sense that it will loop over the options wrapping over if there are less options than lines. Example: $h={Colour => ['Red', '1', 4], Linestyle => ['Solid' ,'Dashed']}; $tx=zeroes(100,5)->xlinvals(-5,5); $ty = $tx + $tx->yvals; tpoints($tx, $ty, $h); =head2 tcircle =for ref A threaded interface to circle =for usage Usage: tcircle($x, $y, $r, $options); This is a threaded interface to C<circle>. This is convenient if you have a list of circle centers and radii and want to draw every circle in one go. The routine will apply any options you apply in a "reasonable" way, in the sense that it will loop over the options wrapping over if there are less options than circles. Example: $x=sequence(5); $y=random(5); $r=sequence(5)/10 + 0.1; $h={justify => 1,Color => ['red','green','blue'], filltype => ['solid','outline','hatched','cross_hatched']}; tcircle($x, $y, $r, $h); Note that C<$x> and C<$y> must be the same size (>1D is OK, though meaningless as far as C<tcircle> is concerned). C<$r> can be the same size as C<$x> OR a 1-element piddle OR a single perl scalar. =head2 Text routines =head2 text =for ref Write text in a plot window at a specified position. =for usage Usage: text ($text, $x, $y [, $opt]) Options recognised: =over =item C<ANGLE> The angle in degrees between the baseline of the text and the horisontal (increasing counter-clockwise). This defaults to 0. =item C<JUSTIFICATION> The justification of the text relative to the position specified. It defaults to 0.0 which gives left-justified text. A value of 0.5 gives centered text and a value of 1.0 gives right-justified text. =item C<XPos>, C<YPos>, C<Text> These gives alternative ways to specify the text and position. =item C<BackgroundColour> This sets the background colour for the text in case an opaque background is desired. You can also use the synonyms C<Bg> and C<BackgroundColor>. =back The following standard options influence this command: COLOUR, CHARSIZE =for example line sequence(10), sequence(10)**2; text 'A parabola', 3, 9, {Justification => 1, Angle=>atan2(6,1)}; =head2 legend =for ref Add a legend to a plot =for usage Usage: legend($text, $x, $y, [, $width], $opt]); This function adds a legend to an existing plot. The action is primarily controlled by information in the options hash, and the basic idea is that C<$x> and C<$y> determines the upper left hand corner of the box in which the legend goes. If the width is specified either as an argument or as an option in the option hash this is used to determine the optimal character size to fit the text into part of this width (defaults to 0.5 - see the description of C<TextFraction> below). The rest of the width is filled out with either lines or symbols according to the content of the C<LineStyle>, C<Symbol>, C<Colour> and C<LineWidth> options. The local options recognised are as follows: =over =item C<Text> An anonymous array of annotations, can also be specified directly. =item C<XPos> and C<YPos> The X and Y position of the upper left-hand corner of the text. =item C<Width> and C<Height> The width and/or height of each line (including symbol/line). This is used to determine the character size. If any of these are set to 'Automatic' the current character size will be used. =item C<TextFraction> The text and the symbol/line is set inside a box. C<TextFraction> determines how much of this box should be devoted to text. This defaults to 0.5. You can also use C<Fraction> as a synonym to this. =item C<TextShift> This option allows for fine control of the spacing between the text and the start of the line/symbol. It is given in fractions of the total width of the legend box. The default value is 0.1. =item C<VertSpace> or C<VSpace> By default the text lines are separated by one character height (in the sense that if the separation were 0 then they would lie on top of each other). The C<VertSpace> option allows you to increase (or decrease) this gap in units of the character height; a value of 0.5 would add half a character height to the gap between lines, and -0.5 would remove the same distance. The default value is 0. =item C<BackgroundColour> This sets the background colour for the text in case an opaque background is desired. You can also use the synonyms C<Bg> and C<BackgroundColor>. =back =for example line $x, $y, {Color => 'Red', LineStyle => 'Solid'}; line $x2, $y2, {Color => 'Blue', 'LineStyle' => 'Dashed', LineWidth => 10}; legend ['A red line', 'A blue line'], 5, 5, {LineStyle => ['Solid', 'Dashed'], Colour => ['Red', 'Blue'] LineWidth => [undef, 10]}; # undef gives default. =head2 Cursor routines =head2 cursor =for ref Interactively read cursor positions. =for usage Usage: ($x, $y, $ch, $xref, $yref) = cursor($opt) This routine has no standard input parameters, but the type of cursor can be set by setting the option C<Type> as a key in the anonymous hash C<$opt>. The first three return values from the function are always defined and gives the position selected by the user and the character pressed. Depending on the cursor type selected the last two arguments might also be defined and these give a reference position. For instance if the cursor is selected to be C<Rectangle> then the reference position gives one of the corners of the rectangle and C<$x> and C<$y> the diagonally opposite one. Options recognised: =over =item XRef, YRef The reference position to be used =item Type The type of cursor. This can be selected using a number between 0 and 7 as in PGPLOT, or alternatively you can specify these as, C<Default> (0), C<RadialLine> (1), C<Rectangle> (2), C<TwoHorizontalLines> (3), C<TwoVerticalLines> (4), C<HorizontalLine> (5), C<VerticalLine> (6) and C<CrossHair> (7) respectively. The default cursor is just the normal mouse cursor. For the C<RadialLine> you I<must> specify the reference point, whereas for the C<Two(Vertical|Horizontal)Lines> cursor the X or Y reference point, respectively, must be specified. =back =for example To select a region on a plot, use the rectangle cursor: ($x, $y, $ch, $xref, $yref) = cursor({Type => 'Rectangle'}); poly pdl($x, $xref, $xref, $x, $x), pdl($y, $y, $yref, $yref, $y); To select a region of the X-axis: ($x1, $y1, $ch) = cursor({Type => 'VerticalLine'}); ($x2, $y2, $ch) = cursor({Type => 'TwoVerticalLines', XRef => $x1}); =head1 Internal routines =cut #' package PDL::Graphics::PGPLOT::Window; require Exporter; use PDL::Core qw/:Func :Internal/; # Grab the Core names use PDL::Basic; use PDL::Ufunc; use PDL::Primitive; use PDL::Types; use PDL::Options; use PDL::Graphics::State; use PDL::Graphics::PGPLOTOptions qw(default_options); use PDL::Slices; use PDL::NiceSlice; use SelfLoader; use PGPLOT; require DynaLoader; @ISA = qw( Exporter SelfLoader DynaLoader ); @EXPORT = qw( pgwin ); bootstrap PDL::Graphics::PGPLOT::Window; $PDL::Graphics::PGPLOT::RECORDING = 0; # By default recording is off.. #### # Helper routines to handle signal avoidance: # cpgplot doesn't take well to being interrupted, so we mask out INT # signals during most of the routines. But we do want to handle # those INTs, so we need a handler that marks 'em. # # You call catch_signals with no arguments. INT and __DIE__ signals # are sent to the signal_catcher, and released, not necessarily in # the order they occurred, by release_signals. # # To avoid problems with nested &catch_signals and &release_signals calls, # a variable keeps track of balancing the two. Ideally, no signals would # actually be released until you undo all of 'em -- but the code is meant # to be forgiving, so the third caught INT signal in a row gets released, # to be trapped in the usual way. # # catch_signals catches the __DIE__ pseudosignal, but barf() doesn't # throw it -- so remember to release signals before barfing! # # The mechanism is a little over-powered for what we need -- but, hey, # if you want to defer any other signal you can simply add it to the # list in catch_signals. # # Don't try to parse arguments within catch_signals -- the omitted-() call # is extra fast but doesn't set @_! # # --CED 9-Aug-2002 #### =head2 signal_catcher, catch_signals, release_signals To prevent pgplot from doing a fandango on core, we have to block interrupts during PGPLOT calls. Specifically, INT needs to get caught. These internal routines provide a mechanism for that. You simply bracket any PGPLOT calls with C<&catch_signals> above and C<&release_signals> below, and the signal_catcher will queue up any signals (like INT -- the control-C interrupt) until the C<&release_signals> call. Any exit path from your hot code must include C<&release_signals>, or interrupts could be deferred indefinitely (which would be a bug). This includes calls to C<&barf> -- even barfs from someone you called! So avoid calling out of the local module if possible, and use release_and_barf() instead of barf() from within this module. Perl 5.6.1 interrupt handling has a bug that this code tickles -- sometimes the re-emitted signals vanish into hyperspace. Perl 5.8 seems NOT to have that problem. =cut my %sig_log; my %sig_handlers; my $sig_nest = 0; sub signal_catcher { my($sig) = shift; if($sig_nest == 0) { $sig_nest = 1; print STDERR "PDL::Graphics::PGPLOT: Warning - who left the light on when they left?\n"; &release_signals; } if($sig eq '__DIE__') { return unless defined $^S; # Don't do anything during parsing of an eval $sig_nest = 1; # Unwrap all nests when dying &release_signals; &{$SIG{__DIE__}}($sig) if defined($SIG{__DIE__}); return; } # Print message if debugging is on or on multiple INT signals if($PDL::debug || ($sig_log{$sig} && ($sig eq 'INT'))) { if($sig_log{$sig}==1) { print STDERR "PDL::Graphics::PGPLOT: deferred $sig for PGPLOT; one more aborts operation\n"; } else { print STDERR "PDL::Graphics::PGPLOT: deferred $sig signal for PGPLOT operation (l=$sig_nest)\n" } } # Handle multiple INT signals (user pressing ^C a bunch) if(defined($sig_log{$sig}) && ($sig_log{$sig}>1) && ($sig eq 'INT')) { print STDERR "Aborting PGPLOT operation".($PDL::debug ? " (may mess up future PGPLOT commands)\n" : "\n"); $sig_nest = 1; &release_signals ; } else { $sig_log{$sig}++; } } sub catch_signals { my(@sigs) = ('INT'); local($_); if($sig_nest == 0) { foreach $_(@sigs) { no warnings; # mask out warning in case $SIG{$_} is undef or "". next if ($SIG{$_} == \&signal_catcher); $sig_handlers{$_}=$SIG{$_}; $SIG{$_}=\&signal_catcher; } } $sig_nest++; # Keep track of nested calls. } sub release_signals { local($_); $sig_nest-- if($sig_nest > 0); return if($sig_nest > 0); # restore original handlers foreach $_(keys %sig_handlers) { no warnings; # allow assignment even if sig_handlers{$_} is undef $SIG{$_}=$sig_handlers{$_}; delete $sig_handlers{$_}; } # release signals foreach $_(keys %sig_log) { next unless $sig_log{$_}; $sig_log{$_} = 0; kill $_,$$; } } sub release_and_barf { $sig_nest = 1; &release_signals; barf(@_); } # # Note: Here the general and window creation specific options are read in # from PGPLOTOptions. The $GeneralOptions variable is most importantly # used in the new() routine to set the general options for the window. # # These are somewhat confusingly named perhaps. The WindowOptions are the # options that affect window creation and setup such as width, shape etc. # The GeneralOptions are options that affect all function calls in the package # (or at least most) since it affects the default colour, character size etc. # The problematic aspect here is the treatment of hardcopy settings. For # historical reasons these are set in the WindowOptions variable but they # should affect settings in the GeneralOptions variable... # Ideally this should be re-coded, but to save some time I have instead opted # for a patchy solution where they are specially treated in the new_window # routine. # # Added 28/9/01 JB # Delay the intialization of the window options so that it is possible # to set the defaults in the .perldlrc file my ($GeneralOptions, $WindowOptions) = (undef, undef); my $PREVIOUS_DEVICE = undef; my $PI = 4*atan2(1,1); my $PREVIOUS_ENV = undef; my $AUTOLOG = 0; sub autolog { my $class = shift; my $ret; if (ref $class) { $ret = $class->{Autolog} || $AUTOLOG; $class->{Autolog} = shift if @_ > 0; } else { $ret = $AUTOLOG; $AUTOLOG = shift if @_ > 0; } return $ret; } sub checklog { my ($self,$x,$y) = @_; $x = $x->log10->float if defined $x && $self->autolog && $self->{Logx}; $y = $y->log10->float if defined $y && $self->autolog && $self->{Logy}; # print STDERR "Logx: ",$self->{Logx},"\n"; # print STDERR "Logy: ",$self->{Logy},"\n"; return ($x,$y); } sub pgwin { my(@a) = @_; # Since this is a convenience function, be convenient. If only # one parameter is passed in, assume that it's a device. if(!$#a && !(ref $a[0])){ $a[0] = "/$a[0]" unless($a[0] =~ m:/:); unshift(@a,'Dev') } # If two parameters are passed in, and the second one is a hash, # then the first one is a device. if(scalar(@a) == 2 && ref $a[1] eq 'HASH') { $a[0] = "/$a[0]" unless($a[0] =~ m:/:); $a[1]->{Dev} = $a[0]; @a = %{$a[1]}; } # Furthermore, if an odd number of parameters are passed in, # then the first one is a device and the rest is intended to # be a parameters hash... if(scalar(@a) % 2) { $a[0] = "/$a[0]" unless($a[0] =~ m/:/); unshift(@a,'Dev'); } return PDL::Graphics::PGPLOT::Window->new(@a); } sub new { my $type = shift; # Set the default options! ($GeneralOptions, $WindowOptions) = default_options(); # Turn off warnings for missing options... $GeneralOptions->warnonmissing(0); $WindowOptions->warnonmissing(0); # options are either given in a hash reference, or as a list # (which is converted to a hash reference to make the code easier) my $u_opt; if ( ref($_[0]) eq "HASH" ) { $u_opt = shift; } else { $u_opt = { @_ }; } # $u_opt={} unless defined($u_opt); my $opt = $WindowOptions->options($u_opt); $WindowOptions->full_options(0); my $user_options = $WindowOptions->current(); $WindowOptions->full_options(1); # If the user set DEVICE then that overrides anything else... if (exists $user_options->{Device}) { $dev = $opt->{Device} } elsif (!defined($dev) || $dev eq "") { # Fall back on the default if first time or use $DEV otherwise.. $dev = $PREVIOUS_DEVICE || $opt->{Device}; } $PREVIOUS_DEVICE = $dev; &catch_signals; my $this_opt = PDL::Options->new($opt); my $t=$WindowOptions->translation(); $this_opt->translation($t); my $s=$WindowOptions->synonyms(); $this_opt->synonyms($s); $this_opt->warnonmissing(0); # This is the setup for the plot options - which also can # be set on a per-window basis by the user. my $popt = $GeneralOptions->options($u_opt); my $this_plotopt = PDL::Options->new($popt); $t = $GeneralOptions->translation(); $this_plotopt->translation($t); $s = $GeneralOptions->synonyms(); $this_plotopt->synonyms($s); $this_plotopt->warnonmissing(0); # Modified 7/4/02 JB to add CTAB as an aspect of the window. my $self = { 'Options' => $this_opt, 'PlotOptions' => $this_plotopt, 'Hold' => $opt->{Hold} || 0, 'Name' => $opt->{WindowName} || '', 'ID' => undef, 'AspectRatio' => $opt->{AspectRatio}, 'WindowWidth' => $opt->{WindowWidth}, 'NX' => $opt->{NXPanel} || 1, 'NY' => $opt->{NYPanel} || 1, 'Device' => $opt->{Device} || $DEV, 'CurrentPanel' => 0, '_env_options' => undef, 'State' => undef, 'Recording' => $opt->{Recording} || $PDL::Graphics::PGPLOT::RECORDING, 'CTAB' => undef, # The default colour table }; if (defined($self->{Options})) { # Turn off warnings about missing options $self->{Options}->warnonmissing(0); } bless $self, ref($type) || $type; $self->_open_new_window($opt); # This weird setup is required to create the object. # We always have to create a state variable to avoid undefined errors. $self->{State}=PDL::Graphics::State->new(); &release_signals; return $self; } # # Graphics windows should be closed when they go out of scope. # Thanks to Doug Burke for pointing this out. # sub DESTROY { my $self=shift; $self->close() unless !defined($self->{ID}); } =head2 _open_new_window Open a new window. This sets the window ID, which is the one used when accessing a window later using C<pgslct>. It also sets the window name to something easily remembered if it has not been set before. =cut sub _open_new_window { my $self = shift; my(@parameters) = @_; &catch_signals; my $window_nr = pgopen($self->{Device}); release_and_barf("Opening new window (pgopen) failed: $window_nr\n") if ($window_nr < 0); $self->{ID} = $window_nr; $self->{Name} = "Window$window_nr" if $self->{Name} eq ""; $self->_setup_window(@parameters); &release_signals; } =head2 _setup_window This routine sets up a new window with its shape and size. This is also where the size options are actually parsed. These are then forgotten (well, they are stored in $self->{Options}) and the corresponding aspect ratio and window width is stored. See the discussion under new() for the logic. Finally the subpanels are set up using C<pgsubp> and colours and linewidth are adjusted according to whether we have a hardcopy device or not. =cut # bit: 2=>height; 1=>width; 0=>aspect $DefaultWindowWidth = 6; $DefaultWindowAspect=0.618; # These are thunks to handle regularizing window values in _setup_window. # Index is binary by validity of value. 0 = undefined (or 0), 1 = ok. # Bit 0 = aspect, bit 1 = width, bit 2 = height. Arguments in the same order. # Return value is ($aspect, $height). # # If nothing is defined we try to grab the latest values from PGPLOT itself. $__setup_subs = [ sub { my($vs_x1,$vs_x2,$vs_y1,$vs_y2); # 0 (000) pgqvsz(1,$vs_x1,$vs_x2,$vs_y1,$vs_y2); my($w) = ($vs_x2 - $vs_x1) || $DefaultWindowWidth; return ( ((($vs_y2 - $vs_y1) / $w) || $DefaultWindowAspect), $w ); }, sub { ($_[0], $DefaultWindowWidth / ($_[0]<1 ? 1 : $_[0])); },# 1 (001) sub { ($DefaultWindowAspect, $_[1]); }, # 2 (010) sub { @_; }, # 3 (011) sub { ($DefaultWindowAspect, $_[2] / $_[0]); }, # 4 (100) sub { ($_[0], $_[2] / $_[0] ) }, # 5 (101) sub { ($_[2] / $_[1], $_[1] ) }, # 6 (110) sub { ($_[2] / $_[1], $_[1] ) } # use W and H; ignore Aspect # 7 (111) ]; sub _setup_window { my $self = shift; my $opt = shift; # Get options as hash or as list if(ref $opt ne 'HASH') { $opt = {$opt,@_}; } &catch_signals; my $unit = _parse_unit($opt->{Unit}) || 1; my $aspect = $opt->{AspectRatio}; my($width,$height); $width = $opt->{WindowXSize} || $opt->{WindowWidth}; $height = $opt->{WindowYSize}; if(defined $opt->{Size}) { if(ref $opt->{Size} eq 'ARRAY') { $width = $opt->{Size}->[0]; $height = $opt->{Size}->[1] || $width; $unit = _parse_unit($opt->{Size}->[2]) if defined($opt->{Size}->[2]); } elsif(!(ref $opt->{Size})) { $width = $height = $opt->{Size}; } else { warn("Size must be a scalar or an array ref if specified! Ignoring...\n"); } } ($aspect,$width) = &{$__setup_subs->[ ((!!($aspect)) ) | ((!!($width ))<<1) | ((!!($height))<<2) ]}($aspect,$width,$height); $self->{AspectRatio} = $aspect; $self->{WindowWidth} = $width; # # PGPLOT seems not to include full unit support in (e.g.) the pgpap # command -- so check here and convert mm->inches if necessary. # This is a real kludge that should be replaced with Real Units Conversion # at a future date. # if($unit==2) { # mm -> inches $width /= 25.4; $height /= 25.4; } elsif($unit==3) { # pixels -> inches. Warning, not device independent! # What a kludge -- get window width in both pixels # and inches to figure out the scaling factor for # pgpap (which requires inches). my($x0,$x1,$y0,$y1); pgqvp(3,$x0,$x1,$y0,$y1); my($pixwidth) = $x1 - $x0; pgqvp(1,$x0,$x1,$y0,$y1); my($inwidth) = $x1 - $x0; my($pixperinch) = $pixwidth / $inwidth; $width /= $pixperinch; $height /= $pixperinch; } elsif($unit ==0 || $unit > 3) { warn("Invalid unit specification for window size; defaulting to inches.\n"); } # OK, we got a decent size. Now call pgpap to set the size in the # device, and (for interactive devices!) pgpag to get the size we # want -- otherwise the window just hangs around looking lame at the # default size instead of the size the user asked for. We also have # to turn PGASK off so the user doesn't get asked to hit "return". # Afterwards, we turn it back on because that's the default state. # (although it is set to 0 again pretty soon) # pgqinf('HARDCOPY',my $hcopy,my $len); pgpap($width, $aspect); if($hcopy eq 'NO') { pgask(0); pgpage(); pgask(1); } # Now do the sub-division into panels. my $nx = $self->{NX}; my $ny = $self->{NY}; if ($nx < 0) { warn "We do not support the alternative numbering of panels of PGPLOT!\n"; $nx = abs($nx); $self->{NX}=abs($self->{NX}); } pgsubp($nx, $ny); # Setup the colours my $o = $self->{Options}->current(); pgask(0); if ($hcopy eq "YES") { # This has changed to set the defaults instead. pgslw($o->{HardLW}); pgsch($o->{HardCH}); pgscf($o->{HardFont}); # To change defaults you first need to read them out and then # adjust them and set them again my $temp_wo = $self->{PlotOptions}->defaults(); $temp_wo->{Font}= $o->{HardFont}; $temp_wo->{CharSize}= $o->{HardCH}; $temp_wo->{LineWidth}= $o->{HardLW}; $temp_wo->{Colour}= $o->{HardColour}; $self->{PlotOptions}->defaults($temp_wo); my $temp_o=$self->{Options}->defaults(); $temp_o->{AxisColour}=$o->{HardAxisColour}; $temp_o->{CharSize}=$o->{HardCH}; $self->{Options}->defaults($temp_o); } else { # Set the global properties as for the hardcopy device. pgsch($o->{CharSize}); my $wo = $self->{PlotOptions}->defaults(); pgscf($wo->{Font}); pgslw($wo->{LineWidth}); } my $wo = $self->{PlotOptions}->defaults(); $self->_set_colour($wo->{Colour}); pgask(0); &release_signals; } sub _set_defaults { # Set up defaults # Now check if this is a hardcopy device, in which case we # set a variety of properties differently. my $self = shift; } =head2 _status This routine checks PGPLOT's status for the window. It returns OPEN if the window is open and CLOSED if it is closed. (Windows can be closed but still exist). =cut sub _status { &catch_signals; my $self=shift; $self->focus(); my ($state, $len); pgqinf('STATE',$state,$len); &release_signals; return $state; } =head2 _reopen This functions reopens a window. Since this is an internal function it does not have a lot of error-checking. Make sure the device is closed I<before> calling this routine. There is an unfortunate problem which pops up viz. that the window name cannot be changed at this point since we are offering that to the rest of the world. That might be sensible, but it means that the window name will not reflect the id of the window - use C<id()> for that (this is also why we do not call C<open_new_window> ) =cut sub _reopen { my @parameters = @_; my $self = shift; &catch_signals; my $window_nr = pgopen($self->{Device}); release_and_barf("Opening new window (pgopen) failed: $window_nr\n") if ($window_nr < 0); $self->{ID} = $window_nr; $self->_setup_window(@parameters); &release_signals; } =head2 _advance_panel This routine advances one plot panel, updating the CurrentPanel as well. If the advance will proceed past the page the page will be erased. Also note that when you advance one panel the hold value will be changed. =cut sub _advance_panel { &catch_signals; my $self = shift; my $new_panel = $self->{CurrentPanel}+1; if ($new_panel > ($self->{NX}*$self->{NY})) { # We are at the end of the page.. $new_panel = 1; $self->clear_state(); pgpage(); # $self->{_env_set}=[]; } $self->panel($new_panel); if ($self->held()) { $self->{Hold}=0; print "Graphic released (panel move)\n" if $PDL::verbose; } &release_signals; } =head2 _check_move_or_erase This routine is a utility routine which checks if we need to move panel, and if so will do this. It also checks if it is necessary to advance panels, and whether they need to be erased. =cut sub _check_move_or_erase { my $self=shift; my ($panel, $erase)=@_; &catch_signals; my $sid; pgqid($sid); # Only perform a pgslct if necessary. pgslct($self->{ID}) unless $sid == $self->{ID}; if (defined($panel)) { $self->panel($panel); } elsif (!$self->held()) { # If no hold has been set. $self->_advance_panel(); } $self->erase() if $erase; &release_signals; } =head2 _thread_options This function is a cludgy utility function that expands an options hash to an array of hashes looping over options. This is mainly of use for "threaded" interfaces to standard plotting routines. =cut sub _thread_options { my ($n, $h) = @_; # Loop over each option. my @hashes=(); # One for each option. my @keys = keys %$h; foreach my $k (@keys) { my @vals=(); my $v=$h->{$k}; $v = [$v] if ref($v) ne 'ARRAY'; while ($#vals+1 < $n) { splice(@vals, @vals, 0, @$v); } for (my $i=0; $i<$n; $i++) { $hashes[$i]->{$k}=$vals[$i]; } } return \@hashes; } ############################ # Replay related functions # ############################ my $DEBUGSTATE = 0; sub debug_state { $DEBUGSTATE = !$DEBUGSTATE; } sub replay { my $self = shift; my $state = shift || $self->{State}; &catch_signals; if (!defined($state)) { die "A state object must be defined to play back commands!\n"; } my @list = $state->get(); if ($#list < 0) { # If there are no commands, then the user might have forgotten to # turn on recording, let us remind him/her warn "Replaying an empty state - did you turn on recording?\n"; print "Hint: Put PDL::Graphics::PGPLOT::RECORDING=1 in your .perldlrc file\n" } foreach my $arg (@list) { my ($command, $commandname, $arg, $opt)=@$arg; &$command($self, @$arg, $opt); } &release_signals; } sub clear_state { my $self = shift; print "Clearing state!\n" if $DEBUGSTATE; $self->{State}->clear() if(defined($self) && defined($self->{State})); } sub turn_off_recording { my $self=shift; # Turning off does _NOT_ clear the state at the moment! $self->{Recording} =0; print "Turning off state!\n" if $DEBUGSTATE; } sub turn_on_recording { my $self=shift; # Previous calls are not recorded of course.. print "Turning on state!\n" if $DEBUGSTATE; $self->{Recording} = 1; $self->{State}=PDL::Graphics::State->new() unless defined($self->{State}); } sub _add_to_state { my $self=shift; my ($func, $arg, $opt)=@_; my ($pkg, $fname, $line, $funcname, $hasargs, $wantarray, $evaltext, $isrequire, $hints, $bitmask)=caller(1); # We only add if recording has been turned on. print "Adding to state ! $func, $arg, $opt\n" if $DEBUGSTATE; print "State = ".$self->{State}."\n" if $DEBUGSTATE; $self->{State}->add($func, $funcname, $arg, $opt) if $self->{Recording}; } sub retrieve_state { my $self=shift; my $state_copy = $self->{State}->copy(); print "Retriving state!\n" if $DEBUGSTATE; return $state_copy; } ##################################### # Window related "public" routines. # ##################################### sub close { my $self=shift; # let the user know that we've created a file if ( $self->_status() eq 'OPEN' ) { my @info = $self->info( 'HARDCOPY', 'FILE' ); print "Created: $info[1]\n" if $info[0] eq 'YES' and $PDL::verbose; pgclos(); } $self->{ID}=undef; $self->clear_state(); } =head2 options Access the options used when I<originally> opening the window. At the moment this is not updated when the window is changed later. =cut sub options { return $_[0]->{Options}; } =head2 id Access the window ID that PGPLOT uses for the present window. =cut sub id { return $_[0]->{ID}; } =head2 device This function returns the device type of the present window. =cut sub device { return $_[0]->{Device}; } =head2 name Accessor to set and examine the name of a window. =cut sub name { my $self=shift; if ($#_>=0) { $self->{Name}=$_[0]; } return $self->{Name}; } =head2 focus Set focus for subsequent PGPLOT commands to this window. =cut sub focus { my $self=shift; return if !defined($self->{ID}); &catch_signals; my $sid; pgqid($sid); # Only perform a pgslct if necessary. pgslct($self->{ID}) unless $sid == $self->{ID}; &release_signals; } sub hold { my $self=shift; $self->{Hold}=1; $self->_add_to_state(\&hold); return $self->{Hold}; } sub release { my $self=shift; $self->{Hold}=0; $self->_add_to_state(\&release); return $self->{Hold}; } sub held { my $self = shift; return $self->{Hold}; } =head2 info =for ref Get general information about the PGPLOT environment. =for usage @ans = $self->info( @item ); The valid values of C<@item> are as below, where case is not important: VERSION - What PGPLOT version is in use. STATE - The status of the output device, this is returns 'OPEN'. if the device is open and 'CLOSED' otherwise. USER - The username of the owner of the spawning program. NOW - The current date and time in the format 'dd-MMM-yyyy hh:mm'. Most people are likely to use Perl functions instead. DEVICE * - The current PGPLOT device or file, see also device(). FILE * - The filename for the current device. TYPE * - And the device type for the current device. DEV/TYPE * - This combines DEVICE and TYPE in a form that can be used as input to new. HARDCOPY * - This is flag which is set to 'YES' if the current device is a hardcopy device and 'NO' otherwise. TERMINAL * - This flag is set to 'YES' if the current device is the user's terminal and 'NO' otherwise. CURSOR * - A flag ('YES' or 'NO') to inform whether the current device has a cursor. Those items marced with a C<*> only return a valid answer if the window is open. A question mark (C<?>) is returned if the item is not recognised or the information is not available. =cut #' sub info { my $self = shift; my @inq; if ( wantarray() ) { @inq = @_; } else { push @ing, $_[0]; } &catch_signals; $self->focus(); my @ans; foreach my $inq ( @inq ) { my ( $state, $len ); pgqinf( uc($inq), $state, $len ); push @ans, $state; } &release_signals; return wantarray() ? @ans : $ans[0]; } # info() sub panel { my $self = shift; $self->focus(); my ($xpos, $ypos); if ($#_ == 1) { # We have gotten $x and $y.. ($xpos, $ypos)=@_; } elsif ($#_ == 0 && ref($_[0]) eq 'ARRAY' ) { ($xpos, $ypos)=@{$_[0]}; } elsif ($#_ == 0) { # We have been given a single number... This can be converted # to a X&Y position with a bit of calculation. The code is taken # from one2nd. release_and_barf("panel: Panel numbering starts at 1, not 0\n") if($_[0]<=0); my $i=$_[0]-1; # Offset code is 0-based (of course) $xpos = $i % $self->{NX}; $i = long($i/$self->{NX}); $ypos=$i % $self->{NY}; $xpos++; $ypos++; # Because PGPLOT starts at 1.. } else { release_and_barf <<'EOD'; Usage: panel($xpos, $ypos); or panel([$xpos, $ypos]); or panel($index); EOD } &catch_signals; # We do not subtract 1 from X because we would need to add it again to # have a 1-offset numbering scheme. $self->{CurrentPanel} = ($ypos-1)*$self->{NX}+($xpos); $self->_add_to_state(\&panel, $xpos, $ypos); pgpanl($xpos, $ypos); &release_signals; } { # To save space and time.. my $erase_options = undef; sub erase { my $self = shift; # Parse options my $u_opt = shift; if (defined($u_opt) && ref($u_opt) eq 'HASH') { $erase_options = PDL::Options->new({Panel => undef}) if !defined($erase_options); my $o = $erase_options->options($u_opt); # Change panel if requested $self->panel($o->{Panel}) if defined($o->{Panel}); } elsif (defined($u_opt)) { # The user has passed a number of reference to array.. $self->panel($u_opt); } &catch_signals; $self->focus(); # What should I do with the state here???? pgeras(); $self->_add_to_state(\&erase, [], $u_opt); # Remove hold. $self->{Hold}=0; } &release_signals; } ## ## Utility functions ## =head2 _extract_hash This routine takes and array and returns the first hash reference found as well as those elements that are I<not> hashes. Note the latter point because all other references to hashes in the array will be lost. =cut sub _extract_hash { my @opt=@_; # # Given a list, returns a list of hash references and all the rest. # my $count=0; my $hashes=[]; foreach (@opt) { push @$hashes, splice(@opt, $count, 1) if ref($_) eq 'HASH'; $count++ } return (\@opt, $$hashes[0]); } =head2 _parse_unit Convert a unit string or number into a PGPLOT-certified length unit specification, or return undef if it won't go. =cut @__unit_match = ( qr/^((\s*0)|(n(orm(al(ized)?)?)?))\s*$/i, qr/^((\s*1)|(i(n(ch(es)?)?)?))\s*$/i, qr/^((\s*2)|(m(m|(illimeter))?s?))\s*$/i, qr/^((\s*3)|(p(ix(el)?)?s?))\s*$/i ); sub _parse_unit { # I'm assuming returning undef when $u is undefined is a good thing to do (DJB; 06/28/02) my $u = shift || return undef; # print "parse_unit: got '$u'\n"; for my $i (0..$#__unit_match) { return $i if($u =~ m/$__unit_match[$i]/); } return undef; } =head2 _parse_options This is a convenience routine for parsing a set of options. It returns both the full set of options and those that the user has set. =cut sub _parse_options { my $self=shift; my ($opt, $oin)=@_; ## Should do something sensible if $opt is no options object f.i. if (defined($oin) && ref($oin) ne 'HASH') { my ($package, $file, $line, $sub)=caller(1); release_and_barf "_parse_options called by $sub with non-hash options element!"; } elsif (!defined($oin)) { my ($package, $file, $line, $sub)=caller(1); warn "_parse_options called by $sub without an options hash! - continuing\n"; $oin = {}; } my $o=$opt->options($oin); $opt->full_options(0); my $uo=$opt->current(); $opt->full_options(1); $opt->clear_current(); return ($o, $uo); } ################################################################ # # GRAPHICS FUNCTIONS below! # ################################################################ ############ Local functions ################# =head2 _save_status Saves the PGPLOT state so that changes to settings can be made and then the present state restored by C<_restore_status>. =cut sub _save_status { my $self=shift; &catch_signals; pgsave if $self->_status() eq 'OPEN'; &release_signals; } =head2 _restore_status Restore the PGPLOT state. See L</_save_status>. =cut sub _restore_status { my $self=shift; &catch_signals; pgunsa if $self->_status() eq 'OPEN'; &release_signals; } =head2 _checkarg This routine checks and optionally alters the arguments given to it. =cut sub _checkarg { # Check/alter arguments utility my $self = shift; my ($arg,$dims,$type,$nobarf) = @_; $type = $PDL_F unless defined $type; # nobarf added so the end-user can choose whether to die or not..x $nobarf = 0 unless defined($nobarf); my $ok = 1; $arg = topdl($arg); # Make into a pdl $arg = convert($arg,$type) if $arg->get_datatype != $type; if (($arg->getndims > $dims)) { # Get the dimensions, find out which are == 1. If it helps # chuck these off and return trimmed piddle. my $n=nelem(which(pdl($arg->dims)==1)); if (($arg->getndims-$n) > $dims) { $ok = 0; release_and_barf "Data is >".$dims."D" unless $nobarf; } else { my $count=0; my $qq; my $s=join ',', map {if ($_ == 1 && $count<$arg->getndims-$dims) {$qq='(0)'; $count++} else { $qq= ''; } ; $qq} $arg->dims; $arg=$arg->slice($s); } } $_[0] = $arg if $ok; # Alter return $ok; } # a hack to store information in the object. # Currently only used by imag() for storing information # useful to draw_wedge(). # # This routine needs changing: # . store values using PDL::Options, so you can update rather than overwrite # . associate the information with a particular window/panel/whatever # . clear information when plot erased (correct for current use by imag(), # but maybe not in more general cases?) # # The API is liable to change: you have been warned (Doug Burke) # sub _store { my $self = shift; release_and_barf 'Usage: _store( $self, $name, $item )' unless $#_ == 1; my $name = shift; my $object = shift; # create storage space, if needed $self->{_horrible_storage_space} = {} unless defined $self->{_horrible_storage_space}; # store data $self->{_horrible_storage_space}{$name} = $object; } # sub: _store() # retrieve information from storage space # - same caveats as with _store() # sub _retrieve { my $self = shift; release_and_barf 'Usage: _retrieve( $self, $name )' unless $#_ == 0; my $name = shift; release_and_barf "Internal error: no storage space in object" unless exists $self->{_horrible_storage_space}; if ( exists $self->{_horrible_storage_space}{$name} ) { return $self->{_horrible_storage_space}{$name}; } else { return undef; } } # sub: _retrieve() ################## # Options parser # ################## =head2 _set_colour This is an internal routine that encapsulates all the nastiness of setting colours depending on the different PGPLOT colour models (although HLS is not supported). The routine works in the following way: =over 8 =item * At initialisation of the plot device the work colour index is set to 16. The work index is the index the routine will modify unless the user has specified something else. =item * The routine should be used after standard interpretation and synonym matching has been used. So if the colour is given as input is an integer that colour index is used. =item * If the colour is a reference the routine checks whether it is an C<ARRAY> or a C<PDL> reference. If it is not an error message is given. If it is a C<PDL> reference it will be converted to an array ref. =item * If the array has four elements the first element is interpreted as the colour index to modify and this overrules the setting for the work index used internally. Otherwise the work index is used and incremented until the maximum number of colours for the output device is reached (as indicated by C<pgqcol>). Should you wish to change that you need to read the PGPLOT documentation - it is somewhat device dependent. =item * When the array has been recognised the R,G and B colours of the user-set index or work index is set using the C<pgscr> command and we are finished. =item * If the input colour instead is a string we try to set the colour using the PGPLOT routine C<pgscrn> with no other error-checking. This should be ok, as that routine returns a rather sensible error-message. =back =cut { my $work_ci = 16; sub _set_colour { my $self = shift; my ($col, $is_textbg) = @_; $is_textbg = 0 if !defined($is_textbg); &catch_signals; # The colour index to use for user changes. # This is increased until the max of the colour map. # I don't know if this can change, but let's not take any # chances. my ($min_col, $max_col); pgqcol($min_col, $max_col); # # Extended treatment of colours - added 2/10/01 JB. # if (ref($col)) { if ((ref($col) eq 'PDL') or (ref($col) eq 'ARRAY')) { my @colvals = (ref($col) eq 'PDL' ? list($col) : @{$col}); my ($r, $g, $b)=@colvals; my $index = $work_ci; if ($#colvals == 3) { # This is a situation where the first element is interpreted # as a PGPLOT colour index, otherwise we will use our own # strategy to step through indices. ($index, $r, $g, $b)=@colvals; } else { $work_ci += 1; # NB this does not work on devices with < 16 colours. $work_ci = 16 if $work_ci > $max_col; } pgscr($index, $r, $g, $b); if ($is_textbg) { pgstbg($index); } else { pgsci($index); } } else { warn "The colour option must be a number, string, array or PDL!\n"; } } else { # Now check if this is a name that could be recognised by pgscrn. # To simplify the logic we first check if $col is a digit. if ($col =~ m/^\s*\d+\s*$/) { if ($is_textbg) { pgstbg($col); } else { pgsci($col); } } else { # # Ok, we either have an untranslated colour name or something # bogus - let PGPLOT deal with that! # my $ier; pgscrn($work_ci, $col, $ier); if ($is_textbg) { pgstbg($work_ci); } else { pgsci($work_ci); } $work_ci += 1; # NB this does not work on devices with < 16 colours. $work_ci = 16 if $work_ci > $max_col; } } &release_signals; } } =head2 _standard_options_parser This internal routine is the default routine for parsing options. This routine deals with a subset of options that most routines will accept. =cut sub _standard_options_parser { # # Parse the options and act on the values set. # my $self=shift; my ($o)=@_; &catch_signals; # # The input hash has to contain the options _set by the user_ # $self->_set_colour($o->{Colour}) if (exists($o->{Colour})); pgsls($o->{LineStyle}) if exists($o->{LineStyle}); pgslw($o->{LineWidth}) if exists($o->{LineWidth}); pgscf($o->{Font}) if exists($o->{Font}); pgsch($o->{CharSize}) if exists($o->{CharSize}); pgsfs($o->{Fill}) if exists($o->{Fill}); # pgsch($o->{ArrowSize}) if exists($o->{ArrowSize}); # Two new options.. my $wo = $self->{PlotOptions}->defaults(); # Window defaults - for some routines below # We just need special treatment of the Arrow and Hatch options, # and they are complex for historical reasons... if (exists($o->{Arrow})) { # # Set the arrow. The size can be set either independently # using ARROWSIZE or in the hash # # Note the use of $wo to get the true default values here! my ($fs, $angle, $vent)=($wo->{Arrow}{FS}, $wo->{Arrow}{Angle}, $wo->{Arrow}{Vent}); my $arrowsize = $o->{CharSize}; # Default to the character size.. if (ref($o->{Arrow}) eq 'HASH') { while (my ($var, $value)=each %{$o->{Arrow}}) { # options are FS, ANGLE, VENT, SIZE # but SIZE may be ARROWSIZE [see ../PGPLOTOptions.pm] $fs=$value if $var =~ m/^F/i; $vent=$value if $var =~ m/^V/i; $angle=$value if $var =~ m/^AN/i; # not sure about how correct this is, but it stops 'use of undefined' # variable (for $angle) in pgsah() call below $arrowsize=$value if $var =~ m/^S/i or $var =~ m/^AR/i; } } else { $fs=$o->{Arrow}[0] if defined $o->{Arrow}[0]; $angle=$o->{Arrow}[1] if defined $o->{Arrow}[1]; $vent=$o->{Arrow}[2] if defined $o->{Arrow}[2]; $arrowsize=$o->{Arrow}[3] if defined $o->{Arrow}[3]; } pgsch($arrowsize) if defined($arrowsize); pgsah($fs, $angle, $vent); } if (exists($o->{Hatch})) { my $val = $o->{Hatch}; if (!defined($val) || lc($val) eq 'default') { pgshs(); # Default values are either specified by HATCH=>undef or HATCH=>'default' } else { # # Can either be specified as numbers or as a hash... # # Note the use of $wo to get the true default values!! # my ($angle, $separation, $phase)= ($wo->{Hatch}{Angle}, $wo->{Hatch}{Separation}, $wo->{Hatch}{Phase}); if (ref($val) eq 'HASH') { while (my ($var, $value) = each %{$val}) { $angle=$value if $var =~ m/^A/i; $separation=$value if $var =~ m/^S/i; $phase=$value if $var =~ m/^P/i; } } else { $angle=$$val[0] if defined($$val[0]); $separation=$$val[1] if defined($$val[1]); $phase=$$val[2] if defined($$val[2]); } if ($separation==0) { warn "The separation of hatch lines cannot be zero, the default of". $wo->{Hatch}{Separation} . " is used!\n"; $separation=$wo->{Hatch}{Separation}; } pgshs($angle,$separation, $phase); } } &release_signals; } # initenv( $xmin, $xmax, $ymin, $ymax, $just, $axis ) # initenv( $xmin, $xmax, $ymin, $ymax, $just ) # initenv( $xmin, $xmax, $ymin, $ymax, \%opt ) # # \%opt can be supplied but not be defined # we parse the JUSTIFY, AXIS, and BORDER options here, # rather than have a multitude of checks below # sub initenv{ my $self = shift; # Default box # We must check the status of the object, and if not ready it must # be re-opened... $self->_status(); my ($in, $u_opt)=_extract_hash(@_); &catch_signals; my ($xmin, $xmax, $ymin, $ymax, $just, $axis)=@$in; $u_opt={} unless defined($u_opt); ############################## # If the user specifies $just or $axis these values will # override any options given. $u_opt->{Justify} = $just if defined($just); $u_opt->{Axis} = $axis if defined($axis); ############################## # Now parse the input options. my $o = $self->{Options}->options($u_opt); # Merge in user options... if ($self->autolog) { # Bug fix JB, 03/03/05 - logging noisy/failed when running with -w or strict. # Hence the extra check on the content of Axis if (ref($o->{Axis}) eq 'ARRAY') { $self->{Logx} = ($o->{Axis}[0] =~ /L/) ? 1 : 0; $self->{Logy} = ($o->{Axis}[1] =~ /L/) ? 1 : 0; } elsif (ref($o->{Axis})) { release_and_barf "The axis option must be an array ref or a scalar!\n"; } else { $self->{Logx} = ($o->{Axis} == 10 || $o->{Axis} == 30) ? 1 : 0; #/BCLNST/) ? 1 : 0; $self->{Logy} = ($o->{Axis} == 20 || $o->{Axis} == 30) ? 1 : 0; #/BCLNST/) ? 1 : 0; } ($xmin,$xmax) = map { release_and_barf "plot boundaries not positive in logx-mode" if $_ <= 0; log($_)/log(10) } ($xmin,$xmax) if $self->{Logx}; ($ymin,$ymax) = map { release_and_barf "plot boundaries not positive in logy-mode" if $_ <= 0; log($_)/log(10) } ($ymin,$ymax) if $self->{Logy}; } # DJB 2003/12/01 - added some error checking for user errors like # setting xmin==xmax. yeah, should really check abs(x1-x2)<tolerance ;) # release_and_barf "x axis has min==max" if $xmin == $xmax; release_and_barf "y axis has min==max" if $ymin == $ymax; if($self->held()) { $self->focus(); } else { ########## # Save current colour and set the axis colours my ($col); pgqci($col); $self->_set_colour($o->{AxisColour}); # Save current font size and set the axis character size. my ($chsz); pgqch($chsz); pgsch($o->{CharSize}); if (ref($o->{Border}) eq 'HASH' || $o->{Border} != 0) { my $type = "REL"; my $delta = 0.05; if ( ref($o->{Border}) eq "HASH" ) { while (my ($bkey, $bval) = each %{$o->{Border}}) { $bkey = uc($bkey); if ($bkey =~ m/^TYP/) { $type = uc $bval; } elsif ($bkey =~ m/^VAL/) { $delta = $bval; } } # while: (bkey,bval) } # if: ref($val) eq "HASH" if ( $type =~ m/^REL/ ) { my $sep = ( $xmax - $xmin ) * $delta; $xmin -= $sep; $xmax += $sep; $sep = ( $ymax - $ymin ) * $delta; $ymin -= $sep; $ymax += $sep; } elsif ( $type =~ m/^ABS/ ) { $xmin -= $delta; $xmax += $delta; $ymin -= $delta; $ymax += $delta; } else { print "Warning: unknown BORDER/TYPE option '$type'.\n"; } } ############################## # pgpage doesn't behave quite right in the multi-panel case. Hence, # we call erase if there are multiple panels and pgpage if there is only # one. if (defined($o->{Erase}) && $o->{Erase}) { if ($self->{NX}*$self->{NY} > 1) { pgeras(); $self->clear_state(); # Added to deal with new pages. } else { $self->clear_state(); # Added to deal with new pages. pgpage(); } } ########## # Set up the viewport, and get its size in physical screen units. # This has to be done before the PIX/SCALE/PITCH stuff below in order # to make sure we can get physical dimensions of the viewport for scaling, # even though the JUSTIFY stuff redefines the viewport later. # if (!defined($o->{PlotPosition}) || $o->{PlotPosition} eq 'Default') { # Set standard viewport pgvstd(); } else { release_and_barf "The PlotPosition must be given as an array reference!" unless ref($o->{PlotPosition}) eq 'ARRAY'; my ($x0, $x1, $y0, $y1)=@{$o->{PlotPosition}}; print "pgsvp($wx0,$wx1,$wy0,$wy1);\n" if($PDL::Graphics::PGPLOT::debug); pgsvp ($x0, $x1, $y0, $y1); } ############################## # Parse out scaling options. The defaults for each value change # based on the others (e.g. specifying "SCALE" and no unit # gives pixels; but specifying "PITCH" and no unit gives dpi). # my($pix,$pitch,$unit); ($pix,$pitch,$unit) = (1,1.0/$o->{'Scale'},3) if($o->{'Scale'}); ($pix,$pitch,$unit) = (1,$o->{'Pitch'},1) if($o->{'Pitch'}); if(defined $o->{'Unit'}) { $unit = _parse_unit($o->{'Unit'}); release_and_barf("Unknown unit '$o->{'Unit'}'\n") unless(defined $unit); } $unit = 1 unless defined($unit); # Default to inch (any phys. unit will do) ############################## # Get size of viewport in physical screen units my ($x0,$x1,$y0,$y1); pgqvp($unit,$x0,$x1,$y0,$y1); # Pixel aspect ratio is always overridden by the pix option $pix = $o->{'Justify'} if $o->{'Justify'}; # Only override if nonzero! $pix = $o->{'Pix'} if defined $o->{'Pix'}; # Override if set. ### # Figure out the stretched pitch, if it isn't set. # my $have_pitch_and_pix = (defined($pix) & defined($pitch)); unless(defined $pitch) { my $p = pdl( ($xmax-$xmin) / ($x1-$x0), ($ymax-$ymin) / ($y1-$y0) * (defined($pix)?$pix:0)); $pitch = $p->abs->max; } $pix = abs(($y1 - $y0) / ($ymax - $ymin)) * $pitch unless defined($pix); ########## # Figure out the actual data coordinate corners of the screen, and/or # tweak the screen to match the data coordinate corners. This is important # because the PIX/SCALE/PITCH options set the scaling explicitly, and # the JUSTIFY option requires changing the viewport. # if($o->{Justify}) { ########## # Justify case ### # Work out the boundaries of the data in viewport space, given the # pitch and requested pixel aspect ratio. This is complicated a # little by the need to specify the viewport in surface normalized # coordinates: we have to retrieve surface normalized coords to tweak. my($ox0,$ox1,$oy0,$oy1); pgqvp(0,$ox0,$ox1,$oy0,$oy1); # Get surface normalized dims of current vp my($wxs, $wys) = ( ($ox1-$ox0) / ($x1-$x0) , ($oy1-$oy0) / ($y1-$y0) ); local($_) = $o->{Align} || "CC"; my($wx0,$wx1,$wy0,$wy1); my($xrange) = abs(($xmax-$xmin) * $wxs / $pitch ); ($wx0,$wx1) = (m/L/i) ? ( $ox0, $ox0 + $xrange ) : (m/R/i) ? ( $ox1 - $xrange, $ox1 ) : (0.5 * ( $ox0 + $ox1 - $xrange ), 0.5 * ( $ox0 + $ox1 + $xrange )); my($yrange) = abs(($ymax-$ymin) * $wys * $pix / $pitch ); ($wy0,$wy1) = (m/B/i) ? ( $oy0, $oy0 + $yrange ) : (m/T/i) ? ( $oy1 - $yrange, $oy1 ) : (0.5 * ( $oy0 + $oy1 - $yrange ), 0.5 * ( $oy0 + $oy1 + $yrange )); pgsvp(minmax(pdl($wx0,$wx1)),minmax(pdl($wy0,$wy1))); pgswin($xmin,$xmax,$ymin,$ymax); } elsif($have_pitch_and_pix) { ########## # Non-justify case with specified pitch and pixel aspect. my($xx0,$xx1,$yy0,$yy1); # These get the final data coords ### # Work out the boundaries of the viewport in data space, given the # pitch and requested pixel aspect ratio. local($_) = $o->{Align} || "BL"; ($xx0,$xx1) = (m/L/i) ? ($xmin, $xmin+($x1-$x0)*$pitch) : (m/R/i) ? ($xmax-($x1-$x0)*$pitch, $xmax) : (0.5*($xmin+$xmax - ($x1-$x0)*$pitch), 0.5*($xmin+$xmax + ($x1-$x0)*$pitch)); ($yy0,$yy1) = (m/B/i) ? ($ymin, $ymin+($y1-$y0)*$pitch/$pix) : (m/T/i) ? ($ymax-($y1-$y0)*$pitch/$pix, $ymax) : (0.5*($ymin+$ymax - ($y1-$y0)*$pitch/$pix), 0.5*($ymin+$ymax + ($y1-$y0)*$pitch/$pix)); # # Sort out the direction that each axis runs... # my ( $dax, $day ); unless(defined $o->{DirAxis}) { ($dax,$day) = (0,0); } elsif( ! ref $o->{DirAxis} ) { $dax=$day=$o->{DirAxis}; } elsif( ref $o->{DirAxis} eq 'ARRAY' ) { ($dax,$day) = @{$o->{DirAxis}}; } else { release_and_barf "DirAxis option must be a scalar or array\n"; } ##print "dax=$dax; day=$day\n"; ( $xx0, $xx1 ) = ( $xx1, $xx0 ) if ( ( $dax==0 and ($xmin-$xmax)*($xx0-$xx1)<0 ) or ( $dax < 0 ) ); ( $yy0, $yy1 ) = ( $yy1, $yy0 ) if ( ( $day==0 and ($ymin-$ymax)*($yy0-$yy1)<0 ) or ( $day < 0 ) ); pgswin($xx0, $xx1, $yy0, $yy1); } else { ### # Simplest case -- just do what the user originally said. # pgswin($xmin,$xmax,$ymin,$ymax); } if (ref($o->{Axis}) eq 'ARRAY') { print "found array ref axis option...\n" if($PDL::Graphics::PGPLOT::debug); pgtbox($o->{Axis}[0], 0.0, 0, $o->{Axis}[1], 0.0, 0); } else { pgtbox($o->{Axis}, 0.0, 0, $o->{Axis}, 0.0, 0); } $self->_set_env_options($xmin, $xmax, $ymin, $ymax, $o); $self->label_axes($u_opt->{XTitle}, $u_opt->{YTitle}, $u_opt->{Title}, $u_opt); # restore settings $self->_set_colour($col); pgsch($chsz); } # end of not-held case &release_signals; 1; } # This is a tidy little routine to set the env options and update the global # variable. sub _set_env_options { my $self=shift; my @opt=@_; $self->{_env_options} = [@opt]; $PREVIOUS_ENV = [@opt]; } sub redraw_axes { my $self = shift; &catch_signals; my $o; if (defined($self->{_env_options})) { # Use the previous settings for the plot box. my $e = $self->{_env_options}; $o=$$e[4]; } else { $o=$self->{Options}->defaults(); } my $col; pgqci($col); $self->_set_colour($o->{AxisColour}); my $chsz; pgqch($chsz); pgsch($o->{CharSize}); my $axval = $o->{Axis}; # Using the last for this window... $axval = 0 unless defined $axval; # safety check unless ( $self->{Hold} ) { if ( ref($axval) ) { pgtbox($$axval[0],0,0,$$axval[1],0,0); } else { pgtbox($axval,0,0,$axval,0,0); } } $self->_set_colour($col); pgsch($chsz); $self->_add_to_state(\&redraw_axes); &release_signals; } =head2 _image_xyrange Given a PGPLOT tr matrix and an image size, calculate the data world coordinates over which the image ranges. This is used in L<imag|imag> and L<cont|cont>. It keeps track of the required half-pixel offset to display images properly -- eg feeding in no tr matrix at all, nx=20, and ny=20 will will return (-0.5,19.5,-0.5,19.5). It also checks the options hash for XRange/YRange specifications and, if they are present, it overrides the appropriate output with the exact ranges in those fields. =cut sub _image_xyrange { my($tr,$nx,$ny,$opt) = @_; # Set identity $tr if no $tr is passed in. This looks funny # because it's designed for use with evil Fortran coordinates. if(!defined($tr)) { $tr = float [-1,1,0,-1,0,1]; } ############################## ## Because the transform is an inhomogeneous scale-and-rotate, ## the limiting points are always the corners of the original ## physical data plane after transformation. We just transform ## the four corners of the data (in evil homogeneous FORTRAN ## origin-at-1 coordinates) and find the minimum and maximum ## X and Y values of 'em all. my @xvals; if(ref $opt eq 'HASH' and defined $opt->{XRange}) { die "_image_xyrange: if XRange is specified it must be an array ref\n" if(ref $opt->{XRange} ne 'ARRAY'); @xvals = @{$opt->{XRange}}; } else { @xvals = ($tr->(0:2)*pdl[ [1, 0.5, 0.5], [1, 0.5, $nx+0.5], [1, $nx+0.5, 0.5], [1, $nx+0.5, $nx+0.5] ])->sumover->minmax; } my @yvals; if(ref $opt eq 'HASH' and defined $opt->{YRange}) { die "_image_xyrange: if YRange is specified it must be an array ref\n" if(ref $opt->{YRange} ne 'ARRAY'); @yvals = @{$opt->{YRange}}; } else { @yvals = ($tr->(3:5)*pdl[ [1, 0.5, 0.5], [1, 0.5, $ny+0.5], [1, $ny+0.5, 0.5], [1, $ny+0.5, $ny+0.5] ])->sumover->minmax; } if ( $tr->at(1) < 0 ) { @xvals = ( $xvals[1], $xvals[0] ); } if ( $tr->at(5) < 0 ) { @yvals = ( $yvals[1], $yvals[0] ); } return (@xvals,@yvals); } =head2 _FITS_tr Given a FITS image, return the PGPLOT transformation matrix to convert pixel coordinates to scientific coordinates. Used by L<fits_imag|/fits_imag>, L<fits_rgbi|/fits_rgbi>, and L<fits_cont|/fits_cont>, but may come in handy for other methods. =for example my $tr = _FITS_tr( $win, $img ); my $tr = _FITS_tr( $win, $img, $opts ); The return value (C<$tr> in the examples above) is the same as returned by the L<transform()|/transform> routine, with values set up to convert the pixel to scientific coordinate values for the two-dimensional image C<$img>. The C<$opts> argument is optional and should be a HASH reference; currently it only understands one key (any others are ignored): WCS => undef (default), "", or "A" to "Z" Both the key name and value are case insensitive. If left as C<undef> or C<""> then the primary coordinate mapping from the header is used, otherwise use the additional WCS mapping given by the appropriate letter. We make B<no> checks that the given mapping is available; the routine falls back to the unit mapping if the specified system is not available. The WCS option has only been tested on images from the Chandra X-ray satellite (L<http://chandra.harvard.edu/>) created by the CIAO software package (L<http://cxc.harvard.edu/ciao/>), for which you should set C<WCS =E<gt> "P"> to use the C<PHYSICAL> coordinate system. See L<http://fits.cv.nrao.edu/documents/wcs/wcs.html> for further information on the Representation of World Coordinate Systems in FITS. =cut { my $_FITS_tr_opt = undef; sub _FITS_tr { my $pane = shift; my $pdl = shift; my $opts = shift || {}; $_FITS_tr_opt = PDL::Options->new( { WCS => undef } ) unless defined $_FITS_tr_opt; my $user_opts = $_FITS_tr_opt->options( $opts ); # Can either be sent a piddle or a hash reference for the header # information # my $isapdl = UNIVERSAL::isa($pdl,'PDL'); my $hdr = $isapdl ? $pdl->hdr() : $pdl->hdr; print STDERR "Warning: null FITS header in _FITS_tr (do you need to set hdrcpy?)\n" unless (scalar(keys %$hdr) || (!$PDL::debug)); my ( $cdelt1, $cpix1, $cval1, $n1 ); my ( $cdelt2, $cpix2, $cval2, $n2 ); my $angle; # what WCS system to use? Not sure how well we are following the # Greisen et al proposal/standard here. # my $id = ""; if ( defined $$user_opts{WCS} ) { $id = uc( $$user_opts{WCS} ); die "WCS option must either be 'undef' or A-Z, not $id\n" unless $id =~ /^[A-Z]?$/; } print "Using the WCS '$id' mapping (if it exists)\n" if $PDL::verbose and $id ne ""; { # don't complain about missing fields in fits headers no warnings; if ( $isapdl ) { ( $n1, $n2 ) = $pdl->dims; } else { $n1 = $hdr->{NAXIS1}; $n2 = $hdr->{NAXIS2}; } $cdelt1 = $hdr->{"CDELT1$id"} || 1.0; $cpix1 = $hdr->{"CRPIX1$id"} || 1; $cval1 = $hdr->{"CRVAL1$id"} || 0.0; $cdelt2 = $hdr->{"CDELT2$id"} || 1.0; $cpix2 = $hdr->{"CRPIX2$id"} || 1; $cval2 = $hdr->{"CRVAL2$id"} || 0.0; # changed Jan 14 2004 DJB - previously used CROTA # keyword but that is not in the WCS standard # - I hope this doesn't break things # -- This broke a few things because CROTA is a pseudostandard # in the solar physics community. I added a fallback to # CROTA in case CROTA2 doesn't exist. --CED # 13-Apr-2010: changed sign of CROTA2 to match update to PDL::Transform in 2.4.3 --CED $angle = - ( (defined $hdr->{"CROTA2$id"}) ? $hdr->{"CROTA2$id"} : (defined $hdr->{"CROTA"}) ? $hdr->{"CROTA"} : 0) * 3.14159265358979323846264338/180; } # no warnings; # # Here's what we would do if PGPLOT worked as advertised... # return transform( $pane, { ImageDimensions => [ $n1, $n2 ], Angle => $angle, Pixinc => [ $cdelt1, $cdelt2 ], RefPos => [ [$cpix1-1, $cpix2-1], [$cval1,$cval2] ] } ); # # Here's a failed attempt to compensate for the PGPLOT-induced jitter # (look closely at the "demo transform" rotating screens and you'll # see a small movement...) # # $offset = sqrt(0.5)* max abs cos ( $angle + pdl(-1,1)*0.25*3.14159 ); # return transform( $pane, { # ImageDimensions => [ $n1, $n2 ], # Angle => $angle, # Pixinc => [ $cdelt1, $cdelt2 ], # RefPos => [ [$cpix1-1-$offset, $cpix2-1-$offset], [$cval1,$cval2] ] # } ); } # sub: _FITS_tr } # "closure" around _FITS_tr sub label_axes { # print "label_axes: got ",join(",",@_),"\n"; my $self = shift; my ($in, $opt)=_extract_hash(@_); &catch_signals; # :STATE RELATED: # THIS WILL PROBABLY NOT WORK as label_axes can be called both by # the user directly and by env... Let's see. $self->_add_to_state(\&label_axes, $in, $opt); release_and_barf 'Usage: label_axes( [$xtitle, $ytitle, $title], [$opt])' if $#$in > 3; my ($xtitle, $ytitle, $title)=@$in; $opt = {} if !defined($opt); # For safety. # Now the titles are set per plot so we use the general options to # parse the options (if they were set per window we would use # $self->{Options} my ($o, $u_opt) = $self->_parse_options($self->{PlotOptions}, $opt); # Added 25/8/01 JB to check whether label_axes is called before env.. # This is not fool-proof though... And it will give a warning if the # user creates her/his env box outside of this package. warn "label_axes called before env - weird results might occur!\n" unless defined($self->{_env_options}); $self->_save_status(); $self->_standard_options_parser($u_opt); $o->{Title}=$title if defined($title); $o->{XTitle}=$xtitle if defined($xtitle); $o->{YTitle}=$ytitle if defined($ytitle); # what width do we use? # - things are somewhat confused since we have # LineWidth and TextWidth (a recent addition) # and LineWidth is set by _setup_window() - so # _standard_options_parser() uses it - but # TextWidth isn't. # # so for now we over-ride the _standard_options_parser # setting if TextWidth exists # [DJB 2002 Aug 08] my $old_lw; if ( defined($o->{TextWidth}) ) { pgqlw($old_lw); pgslw($o->{TextWidth}); } # pglab by default goes too far from the plot! If NYPanels > 1 # then the bottom label of a higher plot tends to squash the plot # title for the plot below it. To remedy this problem I've # replaced the pglab call with a set of calls to pgmtxt, cribbed # from the pglab.f file. The parameters are shrunk inward if NYPanel > 1 # or if the option "TightLabels" is set. You can also explicitly set # it to 0 to get the original broken behavior. [CED 2002 Aug 29] $label_params = [ [2.0, 3.2, 2.2], # default [1.0, 2.7, 2.2], # tightened ] unless defined($label_params); my($p) = $label_params->[ ( ($self->{NY} > 1 && !defined $o->{TightLabels}) || $o->{TightLabels} ) ? 1 : 0 ]; my($sz); pgqch($sz); pgbbuf(); # Begin a buffered batch output to the device pgsch($sz * ( $o->{TitleSize} || 1 )); # The 'T' offset is computed so that the original # vertical center is maintained. pgmtxt('T', ($p->[0]+0.5)/( $o->{TitleSize} || 1 ) - 0.5 , 0.5, 0.5, $o->{Title}); pgebuf(); # Flush the buffer to avoid a pgplot bug that produced pgbbuf(); # doubled titles for some devices (notably the ppm device). pgsch($sz); pgmtxt('B', $p->[1], 0.5, 0.5, $o->{XTitle}); pgmtxt('L', $p->[2], 0.5, 0.5, $o->{YTitle}); pgebuf(); # pglab($o->{XTitle}, $o->{YTitle}, $o->{Title}); pgslw($old_lw) if defined $old_lw; $self->_restore_status; &release_signals; } ############ Exported functions ################# # Open/reopen the graphics device ################ Supports two new options:: ## NewWindow and WindowName sub CtoF77coords{ # convert a transform array from zero-offset to unit-offset images my $self = shift; my $tr = pdl(shift); # Copy set($tr, 0, at($tr,0)-at($tr,1)-at($tr,2)); set($tr, 3, at($tr,3)-at($tr,4)-at($tr,5)); return $tr; } # set the envelope for plots and put auto-axes on hold sub env { my $self=shift; # Inserted 28/2/01 - JB to avoid having to call release whenever # you want to move to the next panel after using env. $self->release() if $self->held(); # The following is necessary to advance the panel if wanted... my ($in, $opt)=_extract_hash(@_); $opt = {} if !defined($opt); my $o = $self->{PlotOptions}->options($opt); # # Inserted 06/08/01 - JB to be able to determine whether the user has # specified a particular PlotPosition in which case we do _not_ call # _check_move_or_erase... # my $o2 = $self->{Options}->options($opt); if (!defined($o2->{PlotPosition}) || $o2->{PlotPosition} eq 'Default') { $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); } release_and_barf 'Usage: env ( $xmin, $xmax, $ymin, $ymax, [$just, $axis, $opt] )' if ($#_==-1 && !defined($self->{_env_options}) && !defined($PREVIOUS_ENV)) || ($#_>=0 && $#_<=2) || $#_>6; my(@args); # Set the args. The logic here was extended 13/8 by JB to use the # previous setting of the plot env variables regardless of device # if the current device does not have a setting for env etc. if ($#_ == -1) { if (@{$self->{_env_options}}) { @args = @{$self->{_env_options}}; } elsif (defined($PREVIOUS_ENV)) { @args = @{$PREVIOUS_ENV}; } else { @args = (); } } else { @args = @_; } $self->initenv( @args ); ## The adding to state has to take place here to avoid being cleared ## buy the call to initenv... $self->_add_to_state(\&env, $in, $opt); $self->hold(); 1; } # Plot a histogram with pgbin() { my $bin_options = undef; sub bin { my $self = shift; if (!defined($bin_options)) { $bin_options = $self->{PlotOptions}->extend({Centre => 1}); $bin_options->add_synonym({Center => 'Centre'}); } my ($in, $opt)=_extract_hash(@_); $self->_add_to_state(\&bin, $in, $opt); &catch_signals; release_and_barf 'Usage: bin ( [$x,] $data, [$options] )' if $#$in<0 || $#$in>2; my ($x, $data)=@$in; $self->_checkarg($x,1); my $n = nelem($x); if ($#$in==1) { $self->_checkarg($data,1); release_and_barf '$x and $y must be same size' if $n!=nelem($data); } else { $data = $x; $x = float(sequence($n)); } # Parse options $opt={} unless defined($opt); my ($o, $u_opt) = $self->_parse_options($bin_options,$opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); unless ( $self->held() ) { my ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x); my ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($data); if ($xmin == $xmax) { $xmin -= 0.5; $xmax += 0.5; } if ($ymin == $ymax) { $ymin -= 0.5; $ymax += 0.5; } $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt ); } $self->_save_status(); my $centre = $o->{Centre}; # For the standard parser we only want the options that the user set! # $bin_options->full_options(0); # my $u_opt = $bin_options->current(); # $bin_options->full_options(1); # Let's also parse the options if any. $self->_standard_options_parser($u_opt); pgbin($n, $x->get_dataref, $data->get_dataref, $centre); $self->_restore_status(); &release_signals; 1; } } { use strict; my $transform_options = undef; sub transform { # Compute the transform array needed in contour and image plotting my $self = shift; if (!defined($transform_options)) { $transform_options = $self->{PlotOptions}->extend({Angle => undef, ImageDims => undef, Pixinc => undef, ImageCenter => undef, RefPos => undef }); $transform_options->synonyms({ ImageDimensions => 'ImageDims', ImageCentre => 'ImageCenter', ReferencePosition => 'RefPos', }); } # parse the input my ($in, $opt)=_extract_hash(@_); my ($x_pix, $y_pix)= @$in; # handle options $opt = {} if !defined($opt); my ($o, $u_opt) = $self->_parse_options($transform_options, $opt); $self->_standard_options_parser($u_opt); my ($angle, $x_pixinc, $y_pixinc, $xref_pix, $yref_pix, $xref_wrld, $yref_wrld); if (defined($o->{Angle})) { $angle = $o->{Angle}; } else { $angle = 0; } if (defined($o->{Pixinc})) { if (ref($o->{Pixinc}) eq 'ARRAY') { ($x_pixinc, $y_pixinc) = @{$o->{Pixinc}}; } else { $x_pixinc = $y_pixinc = $o->{Pixinc}; } } else { $x_pixinc = $y_pixinc = 1; } if ( defined $o->{ImageDims} ) { if ( ref($o->{ImageDims}) eq 'ARRAY' ) { ($x_pix, $y_pix) = @{$o->{ImageDims}}; } else { release_and_barf "Image dimensions must be given as an array reference!"; } } # The user has to pass the dimensions of the image somehow, so this # is a good point to check whether he/she/it has done so. unless (defined($x_pix) && defined($y_pix)) { release_and_barf "You must pass the image dimensions to the transform routine\n"; } # The RefPos option gives more flexibility than # ImageCentre, since ImageCentre => [ a, b ] is the same # as PosReference => [ [(nx-1)/2,(ny-1/2)], [a,b] ]. # We use ImageCentre in preference to PosReference # if (defined $o->{ImageCenter}) { print "transform() ignoring RefPos as seen ImageCentre\n" if defined $o->{RefPos} and $PDL::verbose; my $ic = $o->{ImageCenter}; if (ref($ic) eq 'ARRAY') { ($xref_wrld, $yref_wrld) = @{$ic}; } else { $xref_wrld = $yref_wrld = $ic; } $xref_pix = ($x_pix - 1)/2; $yref_pix = ($y_pix - 1)/2; } elsif ( defined $o->{RefPos} ) { my $aref = $o->{RefPos}; release_and_barf "RefPos option must be sent an array reference.\n" unless ref($aref) eq 'ARRAY'; release_and_barf "RefPos must be a 2-element array reference\n" unless $#$aref == 1; my $pixref = $aref->[0]; my $wrldref = $aref->[1]; release_and_barf "Elements of RefPos must be 2-element array references\n" unless $#$pixref == 1 and $#$wrldref == 1; ($xref_pix, $yref_pix) = @{$pixref}; ($xref_wrld, $yref_wrld) = @{$wrldref}; } else { $xref_wrld = $yref_wrld = 0; $xref_pix = ($x_pix - 1)/2; $yref_pix = ($y_pix - 1)/2; } # The elements of the transform piddle, # here labelled t0 to t5, relate to the # following maxtix equation: # # world = zp + matrix * pixel # # world - the position of the point in the world, # ie plot, coordinate system # pixel - the position of the point in pixel # coordinates (bottom-left is 0,0 pixel) # zp - (t0) # (t3) # matrix - (t1 t2) # (t4 t5) # my $ca = cos( $angle ); my $sa = sin( $angle ); my $t1 = $x_pixinc * $ca; my $t2 = $y_pixinc * $sa; my $t4 = -$x_pixinc * $sa; my $t5 = $y_pixinc * $ca; return pdl( $xref_wrld - $t1 * $xref_pix - $t2 * $yref_pix, $t1, $t2, $yref_wrld - $t4 * $xref_pix - $t5 * $yref_pix, $t4, $t5 ); } } # display a contour map of an image using pgconb() { my $cont_options = undef; sub cont { my $self=shift; if (!defined($cont_options)) { $cont_options = $self->{PlotOptions}->extend({Contours => undef, Follow => 0, Labels => undef, LabelColour => undef, Missing => undef, NContours => undef, FillContours => undef}); my $t = { LabelColour => { 'White' => 0, 'Black' => 1, 'Red' => 2, 'Green' => 3, 'Blue' => 4, 'Cyan' => 5, 'Magenta' => 6, 'Yellow' => 7, 'Orange' => 8, 'DarkGray' => 14, 'DarkGrey' => 14, 'LightGray' => 15, 'LightGrey' => 15 } }; $cont_options->add_translation($t); } my ($in, $opt)=_extract_hash(@_); $self->_add_to_state(\&cont, $in, $opt); release_and_barf 'Usage: cont ( $image, %options )' if $#$in<0; &catch_signals; # Parse input my ($image, $contours, $tr, $misval) = @$in; $self->_checkarg($image,2); my($nx,$ny) = $image->dims; my ($ncont)=9; # The number of contours by default # First save the present status $self->_save_status(); # Then parse the common options # # These will be all options. $opt = {} if !defined($opt); my ($o, $u_opt) = $self->_parse_options($cont_options, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); $self->_standard_options_parser($u_opt); my ($labelcolour); pgqci($labelcolour); # Default let the labels have the chosen colour. my ($labels, $fillcontours, $angle); my $usepgcont = 0; $contours = $o->{Contours} if defined($o->{Contours}); $ncont = $o->{NContours} if defined($o->{NContours}); $misval = $o->{Missing} if defined($o->{Missing}); $tr = $o->{Transform} if defined($o->{Transform}); $labelcolour = $o->{LabelColour} if defined($o->{LabelColour}); $labels = $o->{Labels} if defined($o->{Labels}); $usepgcont = $o->{Follow} if defined($o->{Follow}); $fillcontours = $o->{FillContours} if defined($o->{FillContours}); if (defined($tr)) { $self->_checkarg($tr,1); release_and_barf '$transform incorrect' if nelem($tr)!=6; } else { $tr = float [0,1,0, 0,0,1]; } $tr = $self->CtoF77coords($tr); if (!$self->held()) { $self->initenv( _image_xyrange($tr,$nx,$ny,$o), $o ); } if (!defined($contours)) { my($minim, $maxim)=minmax($image); $contours = xlinvals(zeroes($ncont), $minim, $maxim) } else { $ncont = nelem($contours); } $self->_checkarg($contours,1); print "Contouring $nx x $ny image from ",min($contours), " to ", max($contours), " in ",nelem($contours)," steps\n" if $PDL::verbose; if (defined($fillcontours)) { pgbbuf(); if (ref $fillcontours ne PDL) { $fillcontours = zeroes($ncont - 1)->xlinvals(0,1)->dummy(0,3); } elsif ($fillcontours->getndims == 1) { $fillcontours = $fillcontours->dummy(0,3); } elsif (($fillcontours->getdim(1) != $ncont - 1) || ($fillcontours->getdim(0) != 3)) { release_and_barf "Argh, wrong dims in filled contours!"; } my ($cr, $cg, $cb, $i); pgqcr(16, $cr, $cg, $cb); # Save color index 16 # Loop over filled contours (perhaps should be done in PP for speed) # Do not shade negative and 0-levels for ($i = 0; $i < ($ncont - 1); $i++) { pgscr(16, list $fillcontours->(:,$i)); pgsci(16); pgconf($image->get_dataref, $nx, $ny, 1, $nx, 1, $ny, list($contours->($i:($i+1))), $tr->get_dataref); } pgscr(16, $cr, $cg, $cb); # Restore color index 16 pgebuf(); } elsif (defined($misval)) { pgconb( $image->get_dataref, $nx,$ny,1,$nx,1,$ny, $contours->get_dataref, nelem($contours), $tr->get_dataref, $misval); } elsif (abs($usepgcont) == 1) { pgcont( $image->get_dataref, $nx,$ny,1,$nx,1,$ny, $contours->get_dataref, $usepgcont*nelem($contours), $tr->get_dataref); } else { pgcons( $image->get_dataref, $nx,$ny,1,$nx,1,$ny, $contours->get_dataref, nelem($contours), $tr->get_dataref); } # Finally label the contours. if (defined($labels) && $#$labels+1==nelem($contours)) { my $label=undef; my $count=0; my $minint=long($nx/10)+1; # At least stretch a tenth of the array my $intval=long($nx/3)+1; # my $dum; pgqci($dum); $self->_set_colour($labelcolour); foreach $label (@{$labels}) { pgconl( $image->get_dataref, $nx,$ny,1,$nx,1,$ny, $contours->(($count)), $tr->get_dataref, $label, $intval, $minint); $count++; } $self->_set_colour($dum); } elsif (defined($labels)) { # # We must have had the wrong number of labels # warn <<EOD You must specify the same number of labels as contours. Labelling has been ignored. EOD } # Restore attributes $self->redraw_axes unless $self->held(); # Redraw box $self->_restore_status(); &release_signals; 1; } } # Plot errors with pgerrb() { my $errb_options = undef; sub errb { my $self = shift; if (!defined($errb_options)) { $errb_options = $self->{PlotOptions}->extend({Term => 1}); $errb_options->add_synonym({Terminator => 'Term'}); } my ($in, $opt)=_extract_hash(@_); $self->_add_to_state(\&bin, $in, $opt); &catch_signals; $opt = {} if !defined($opt); release_and_barf <<'EOD' if @$in==0 || @$in==1 || @$in > 7; Usage: $w-> errb ( $y, $yerrors [, $options] ) $w-> errb ( $x, $y, $yerrors [, $options] ) $w-> errb ( $x, $y, $xerrors, $yerrors [, $options]) $w-> errb ( $x, $y, $xloerr, $xhierr, $yloerr, $yhierr [, $options]) EOD my @t=@$in; my $n; # it's possible the user slipped in undefs as the data position. # that's illegal and won't be caught in next loop barf "Must specify data position" if ! defined $t[0] || ( @t > 2 && ! defined $t[1] ); # loop over input data; skip undefined values, as they are # used to flag missing error bars. all data should have the # same dims as the first piddle. for ( my $i = 0 ; $i < @t ; $i++ ) { next if ! defined $t[$i]; $self->_checkarg($t[$i], 1); $n = nelem($t[$i]) if $i == 0; barf "Args must have same size" if nelem($t[$i]) != $n; } my $x = @t < 3 ? float(sequence($n)) : shift @t; my $y = shift @t; # store data in a hash to automate operations my %d; $d{x}{data} = $x; $d{y}{data} = $y; ( $d{y}{err} ) = @t if @t == 1; ( $d{x}{err}, $d{y}{err} ) = @t if @t == 2; ( $d{x}{loerr}, $d{x}{hierr}, $d{y}{loerr}, $d{y}{hierr} ) = @t if @t == 4; my ($o, $u_opt) = $self->_parse_options($errb_options, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); unless( $self->held() ) { # Allow for the error bars my ( $xmin, $xmax, $ymin, $ymax ); # Bug fix, JB 03/03/05 - user input ranges were not considered. my @axes_to_do = (); if (ref($o->{XRange})) { ($d{'x'}{min}, $d{'x'}{max})=@{$o->{XRange}}; if ($d{'x'}{xmin} == $d{'x'}{max}) { $d{'x'}{min} -= 0.5; $d{'x'}{max} += 0.5; } } else { push @axes_to_do, 'x'; } if (ref($o->{YRange})) { ($d{'y'}{min}, $d{'y'}{max})=@{$o->{YRange}}; if ($d{'y'}{xmin} == $d{'y'}{max}) { $d{'y'}{min} -= 0.5; $d{'y'}{max} += 0.5; } } else { push @axes_to_do, 'y'; } # loop over the axes to calculate plot limits for my $ax (@axes_to_do) { $axis = $d{$ax}; $range = uc $ax . 'range'; # user may have specified range limits already; pull them in ($axis->{min},$axis->{max}) = @{$o->{$range}} if ref $o->{$range} eq 'ARRAY'; # skip if user specified range limits unless ( exists $axis->{min} ) { my ( $min, $max ); # symmetric error bars if ( defined $axis->{err} ) { $min = min( $axis->{data} - $axis->{err} ); $max = max( $axis->{data} + $axis->{err} ); } # assymetric error bars else { # lo error bar specified if ( defined $axis->{loerr} ) { $min = min( $axis->{data} - $axis->{loerr} ); } # hi error bar specified if ( defined $axis->{hierr} ) { $max = max( $axis->{data} + $axis->{hierr} ); } } # handle the case where there is no error bar. $min = $axis->{data}->min unless defined $min; $max = $axis->{data}->max unless defined $max; # default range for infinitesimal data range if ($min == $max) { $min -= 0.5; $max += 0.5; } $axis->{min} = $min; $axis->{max} = $max; } } $self->initenv( $d{x}{min}, $d{x}{max}, $d{y}{min}, $d{y}{max}, $opt ); } $self->_save_status(); # Let us parse the options if any. my $term=$o->{Term}; my $symbol; my $plot_points=0; # We won't normally plot the points if (defined($u_opt->{Symbol})) { $symbol = $u_opt->{Symbol}; $plot_points=1; } # Parse other standard options. $self->_standard_options_parser($u_opt); # map our combination of errors onto pgerrb's DIR parameter. note that # DIR(Y) = DIR(X) + 1 for similar error bar configurations $d{x}{dir} = 0; $d{y}{dir} = 1; # loop over axes, plotting the appropriate error bars for my $axis ( $d{x}, $d{y} ) { my $dir = $axis->{dir}; # symmetric error bars if ( defined $axis->{err} ) { pgerrb(5 + $dir, $n, $x->get_dataref, $y->get_dataref, $axis->{err}->get_dataref,$term); } # assymetric error bars else { if ( defined $axis->{hierr} ) { pgerrb(1 + $dir, $n, $x->get_dataref, $y->get_dataref, $axis->{hierr}->get_dataref,$term); } if ( defined $axis->{loerr} ) { pgerrb(3 + $dir, $n, $x->get_dataref, $y->get_dataref, $axis->{loerr}->get_dataref,$term); } } } if ($plot_points) { if (exists($opt->{SymbolSize})) { # Set symbol size (2001.10.22 kwi) pgsch($opt->{SymbolSize}); } $symbol=long($symbol); my $ns=nelem($symbol); pgpnts($n, $x->get_dataref, $y->get_dataref, $symbol->get_dataref, $ns) } $self->_restore_status(); &release_signals; 1; } } # # A "threaded" line - I cannot come up with a more elegant way of doing # this without re-coding bits of thread_over but it might very well be # that you may :) # my $line_options = undef; sub tline { my $self = shift; my ($in, $opt)=_extract_hash(@_); $self->_add_to_state(\&tline, $in, $opt); $opt={} if !defined($opt); release_and_barf 'Usage tline ([$x], $y, [, $options])' if $#$in < 0 || $#$in > 2; my ($x, $y)=@$in; if (!defined($line_options)) { $line_options=$self->{PlotOptions}->extend({Missing => undef}); } if ($#$in==0) { $y = $x; $x = $y->xvals(); } &catch_signals; # This is very very kludgy, but it was the best way I could find.. my $o = _thread_options($y->getdim(1), $opt); # We need to keep track of the current status of hold or not since # the tline function automatically enforces a hold to allow for overplots. my $tmp_hold = $self->held(); unless ( $self->held() ) { my ($o, $u_opt) = $self->_parse_options($line_options,$opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); # use Data::Dumper; # print Dumper $o; # print Dumper $u_opt; my ($ymin, $ymax, $xmin, $xmax); # Make sure the missing value is used as the min or max value if (defined $o->{Missing} ) { ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($y->where($y != $o->{Missing})); ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x->where($x != $o->{Missing})); } else { ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($y); ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x); } if ($xmin == $xmax) { $xmin -= 0.5; $xmax += 0.5; } if ($ymin == $ymax) { $ymin -= 0.5; $ymax += 0.5; } # use Data::Dumper; # print "tline options: ", Dumper($opt), "\n"; $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt); $self->hold; # we hold for the duration of the threaded plot } _tline($x, $y, PDL->sequence($y->getdim(1)), $self, $o); $self->release unless $tmp_hold; &release_signals; } PDL::thread_define('_tline(a(n);b(n);ind()), NOtherPars => 2', PDL::over { my ($x, $y, $ind, $self, $opt)=@_; # use Data::Dumper; # print Dumper $opt->[$ind->at(0)]; $self->line($x, $y,$opt->[$ind->at(0)] || {}); # }); # # A "threaded" point - I cannot come up with a more elegant way of doing # this without re-coding bits of thread_over but it might very well be # that you may :) # my $points_options = undef; sub tpoints { my $self = shift; my ($in, $opt)=_extract_hash(@_); $self->_add_to_state(\&tpoints, $in, $opt); $opt={} if !defined($opt); release_and_barf 'Usage tpoints ([$x], $y, [, $options])' if $#$in < 0 || $#$in > 2; my ($x, $y)=@$in; &catch_signals; if ($#$in==0) { $y = $x; $x = $y->xvals(); } # This is very very cludgy, but it was the best way I could find.. my $o = _thread_options($y->getdim(1), $opt); # We need to keep track of the current status of hold or not since # the tline function automatically enforces a hold to allow for overplots. my $tmp_hold = $self->held(); unless ( $self->held() ) { if (!defined($points_options)) { $points_options = $self->{PlotOptions}->extend({PlotLine => 0}); } my ($o, $u_opt) = $self->_parse_options($points_options,$opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); # use Data::Dumper; # print Dumper $o; # print Dumper $u_opt; my ($ymin, $ymax, $xmin, $xmax); # Make sure the missing value is used as the min or max value if (defined $o->{Missing} ) { ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($y->where($y != $o->{Missing})); ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x->where($x != $o->{Missing})); } else { ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($y); ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x); } if ($xmin == $xmax) { $xmin -= 0.5; $xmax += 0.5; } if ($ymin == $ymax) { $ymin -= 0.5; $ymax += 0.5; } $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt); $self->hold; # we hold for the duration of the threaded plot } _tpoints($x, $y, PDL->sequence($y->getdim(1)), $self, $o); $self->release unless $tmp_hold; &release_signals; } PDL::thread_define('_tpoints(a(n);b(n);ind()), NOtherPars => 2', PDL::over { my ($x, $y, $ind, $self, $opt)=@_; $self->points($x, $y, $opt->[$ind->at(0)] || {}); }); # Plot a line with pgline() { my $line_options = undef; # # lines: CED 17-Dec-2002 # sub lines { my $self = shift; if(!defined($line_options)) { $line_options = $self->{PlotOptions}->extend({Missing=>undef}); } my($in,$opt) = _extract_hash(@_); # Parse out the options and figure out which syntax is being used # This is a pain to look at but the computer does it behind your back so # what do you care? --CED my($x,$y,$p); if(@$in == 3) { release_and_barf "lines: inconsistent array refs in \$x,\$y,\$p call\n" if((ref $in->[0] eq 'ARRAY') ^ (ref $in->[1] eq 'ARRAY')); ($x,$y) = (ref $in->[0] eq 'ARRAY') ? ($in->[0],$in->[1]) : ([$in->[0]],[$in->[1]]); $p = (ref $in->[2] eq 'ARRAY') ? $in->[2] : [$in->[2]]; } elsif(@$in == 2) { # $xy, $p or $x,$y (no-$p) my($a) = (ref $in->[0] eq 'ARRAY') ? $in->[0] : [$in->[0]]; my($b) = (ref $in->[1] eq 'ARRAY') ? $in->[1] : [$in->[1]]; release_and_barf " lines: \$xy must be a piddle\n" unless(UNIVERSAL::isa($a->[0],'PDL')); if( ( ref $in->[0] ne ref $in->[1] ) || ( ! UNIVERSAL::isa($b->[0],'PDL') ) || ( $a->[0]->ndims > $b->[0]->ndims ) ) { # $xy, $p case -- split $xy into $x and $y. foreach $_(@$a){ push(@$x,$_->((0))); push(@$y,$_->((1))); } $p = $b; } else { # $x,$y,(omitted $p) case -- make default $p. $x = $a; $y = $b; $p = [1]; } } elsif(@$in == 1) { # $xyp or $xy,(omitted $p) case my($a) = (ref $in->[0] eq 'ARRAY') ? $in->[0] : [$in->[0]]; foreach $_(@$a) { push(@$x,$_->((0))); push(@$y,$_->((1))); push(@$p, ($_->dim(0) >= 3) ? $_->((2)) : 1); } } else { release_and_barf " lines: ".scalar(@$in)." is not a valid number of args\n"; } release_and_barf "lines: x and y lists have different numbers of elements" if($#$x != $#$y); release_and_barf "lines: \$o->\{Missing\} must be an array ref if specified\n" if (defined $o->{Missing} && ref $o->{Missing} ne 'ARRAY'); ############################## # Now $x, $y, and $p all have array refs containing their respective # vectors. Set up pgplot (copy-and-pasted from line; this is probably # the Wrong thing to do -- we probably ought to call line directly). # &catch_signals; $opt = {} unless defined($opt); my($o,$u_opt) = $self->_parse_options($line_options,$opt); $self->_check_move_or_erase($o->{Panel},$o->{Erase}); my $held = $self->held(); unless ($held) { my($ymin,$ymax,$xmin,$xmax) = ( zeroes(scalar(@$y)), zeroes(scalar(@$y)), zeroes(scalar(@$y)), zeroes(scalar(@$y)) ); my $thunk = sub { my($range) = shift; my($vals,$missing,$min,$max,$pp) = @_; if(ref $range eq 'ARRAY') { $min .= $range->[0]; $max .= $range->[1]; return; } my($mask) = (isfinite $vals); $mask &= ($vals != $missing) if(defined $missing); $mask->(1:-1) &= (($pp->(0:-2) != 0) | ($pp->(1:-1) != 0)); my($a,$b) = minmax(where($vals,$mask)); $min .= $a; $max .= $b; }; for my $i(0..$#$x) { my($pp) = $#$p ? $p->[$i] : $p->[0]; # allow scalar pen in array case $pp = pdl($pp) unless UNIVERSAL::isa($pp,'PDL'); my $miss = defined $o->{Missing} ? $o->{Missing}->[$i] : undef; &$thunk($u_opt->{XRange},$x->[$i],$miss,$xmin->(($i)),$xmax->(($i)),$pp); &$thunk($u_opt->{YRange},$y->[$i],$miss,$ymin->(($i)),$ymax->(($i)),$pp); } $xmin = $xmin->min; $xmax = $xmax->max; $ymin = $ymin->min; $ymax = $ymax->max; if($xmin==$xmax) { $xmin -= 0.5; $xmax += 0.5; } if($ymin==$ymax) { $ymin -= 0.5; $ymax += 0.5; } print "lines: xmin=$xmin; xmax=$xmax; ymin=$ymin; ymax=$ymax\n" if($PDL::verbose); $self->initenv($xmin,$xmax,$ymin,$ymax,$opt); } $self->_save_status(); $self->_standard_options_parser($u_opt); my($lw); # Save the normal line width pgqlw($lw); my($hh) = 0; # Indicates local window hold # Loop over everything in the list for my $i(0..$#$x) { my($xx,$yy) = ($x->[$i],$y->[$i]); next if($xx->nelem < 2); my($pp) = $#$p ? $p->[$i] : $p->[0]; # allow scalar pen in array case my($miss) = defined $o->{Missing} ? $o->{Missing}->[$i] : undef; my($n) = $xx->nelem; $pp = pdl($pp) unless UNIVERSAL::isa($pp,'PDL'); $pp = zeroes($xx)+$pp if($pp->nelem == 1); $pp = $pp->copy; # Make a duplicate to scribble on $pp->(0:-2) *= ($xx->(0:-2) + $xx->(1:-1))->isfinite; $pp->(0:-2) *= ($yy->(0:-2) + $yy->(1:-1))->isfinite; my($pn,$pval) = rle($pp); my($pos,$run,$rl) = (0,0,0); # Within each list element loop over runs of pen value while(($run<$pn->nelem) && ($rl = $pn->at($run))) { # assignment my($pv); if($pv = $pval->at($run)) { # (assignment) Skip runs with pen value=0 my $top = $pos+$rl; $top-- if($top == $xx->dim(0)); my $x0 = float $xx->($pos:$top); my $y0 = float $yy->($pos:$top); $self->_set_colour(abs($pv)*(defined $o->{Colour} ? $o->{Colour}:1)); ($x0,$y0) = $self->checklog($x0,$y0) if $self->autolog; if($pv > 0) { pgslw($lw); } else { pgslw(1); } if(defined($miss)) { my $mpt = defined $miss ? $miss->($pos:$top) : undef; pggapline($x0->nelem,$miss->($pos:$top),$x0->get_dataref, $y0->get_dataref); } else { pgline($x0->nelem,$x0->get_dataref,$y0->get_dataref,); } $self->hold() unless $hh++; } $pos += $rl; $run++; } # end of within-piddle polyline loop } # end of array ref loop pgslw($lw); # undo incredible shrinking line width$ $self->release() unless($held); $self->_restore_status(); $self->_add_to_state(\&lines,$in,$opt); &release_signals; 1; } sub line { my $self = shift; if (!defined($line_options)) { $line_options=$self->{PlotOptions}->extend({Missing => undef}); } my ($in, $opt)=_extract_hash(@_); release_and_barf 'Usage: line ( [$x,] $y, [$options] )' if $#$in<0 || $#$in>2; my($x,$y) = @$in; $self->_checkarg($x,1); my $n = nelem($x); &catch_signals; my ($is_1D, $is_2D); if ($#$in==1) { $is_1D = $self->_checkarg($y,1,undef,1); if (!$is_1D) { $is_2D = $self->_checkarg($y,2,undef,1); release_and_barf '$y must be 1D (or 2D for threading!)'."\n" if !$is_2D; # Ok, let us use the threading possibility. $self->tline(@$in, $opt); &release_signals; return; } else { release_and_barf '$x and $y must be same size' if $n!=nelem($y); } } else { $y = $x; $x = float(sequence($n)); } # Let us parse the options if any. $opt = {} if !defined($opt); my ($o, $u_opt) = $self->_parse_options($line_options, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); unless ( $self->held() ) { # Make sure the missing value is used as the min or max value. # Also, do autoscaling but avoid infinities. my ($ymin, $ymax, $xmin, $xmax); # Thunk for finding max and min X and Y ranges my($thunk) = sub { my($range) = shift; return @{$range} if(ref $range eq 'ARRAY'); my($vals, $missing) = @_; my($mask) = (isfinite $vals); $mask &= ($vals != $missing) if(defined $missing); minmax(where($vals,$mask)); }; ($xmin,$xmax) = &$thunk($o->{XRange},$x,$o->{Missing}); ($ymin,$ymax) = &$thunk($o->{YRange},$y,$o->{Missing}); if ($xmin == $xmax) { $xmin -= 0.5; $xmax += 0.5; } if ($ymin == $ymax) { $ymin -= 0.5; $ymax += 0.5; } print("line: xmin=$xmin; xmax=$max; ymin=$ymin; ymax=$ymax\n") if($PDL::verbose); $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt); } $self->_save_status(); $self->_standard_options_parser($u_opt); # take logs if we are in autolog mode and axis option indicates logs ($x,$y) = $self->checklog($x,$y) if $self->autolog; # If there is a missing value specified, use pggapline # to break the line around missing values. if (defined $o->{Missing}) { pggapline ($n, $o->{Missing}, $x->get_dataref, $y->get_dataref); } else { pgline($n, $x->get_dataref, $y->get_dataref); } $self->_restore_status(); $self->_add_to_state(\&line, $in, $opt); &release_signals; 1; } } # Plot points with pgpnts() sub arrow { my $self = shift; my ($in, $opt)=_extract_hash(@_); $opt = {} if !defined($opt); release_and_barf 'Usage: arrow($x1, $y1, $x2, $y2 [, $options])' if $#$in != 3; my ($x1, $y1, $x2, $y2)=@$in; &catch_signals; my ($o, $u_opt) = $self->_parse_options($self->{PlotOptions}, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); unless ($self->held()) { $self->initenv($x1, $x2, $y1, $y2, $opt); } $self->_save_status(); $self->_standard_options_parser($u_opt); pgarro($x1, $y1, $x2, $y2); $self->_restore_status(); $self->_add_to_state(\&arrow, $in, $opt); &release_signals; } { my $points_options = undef; sub points { my $self = shift; if (!defined($points_options)) { $points_options = $self->{PlotOptions}->extend({PlotLine => 0}); } my ($in, $opt)=_extract_hash(@_); release_and_barf 'Usage: points ( [$x,] $y, $sym, [$options] )' if $#$in<0 || $#$in>2; my ($x, $y, $sym)=@$in; $self->_checkarg($x,1); my $n=nelem($x); &catch_signals; my ($is_1D, $is_2D); if ($#$in>=1) { $is_1D = $self->_checkarg($y,1,undef,1); if (!$is_1D) { $is_2D = $self->_checkarg($y,2,undef,1); release_and_barf '$y must be 1D (or 2D for threading!)'."\n" if !$is_2D; # Ok, let us use the threading possibility. $self->tpoints(@$in, $opt); return; } else { release_and_barf '$x and $y must be same size' if $n!=nelem($y); } } else { $y = $x; $x = float(sequence($n)); } # Let us parse the options if any. $opt = {} if !defined($opt); my ($o, $u_opt) = $self->_parse_options($points_options, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); # # Save some time for large datasets. # unless ( $self->held() ) { my ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x); my ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($y); if ($xmin == $xmax) { $xmin -= 0.5; $xmax += 0.5; } if ($ymin == $ymax) { $ymin -= 0.5; $ymax += 0.5; } $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt ); } $self->_save_status(); $self->_standard_options_parser($u_opt); # take logs if we are in autolog mode and axis option indicates logs ($x,$y) = $self->checklog($x,$y) if $self->autolog; if (exists($opt->{SymbolSize})) { # Set symbol size (2001.10.22 kwi) pgsch($opt->{SymbolSize}); } if (exists($opt->{ColorValues})) { my $sym ||= $o->{Symbol} || 0; my $z = $opt->{ColorValues}; $self->_checkarg($z,1); # make sure this is a float PDL pgcolorpnts($n, $x->get_dataref, $y->get_dataref, $z->get_dataref, $sym); } else { # Set symbol if specified in the options hash. ## $sym ||= $o->{Symbol}; $sym = $o->{Symbol} unless defined $sym; $self->_checkarg($sym,1); my $ns = nelem($sym); $sym = long($sym); pgpnts($n, $x->get_dataref, $y->get_dataref, $sym->get_dataref, $ns); } # # Sometimes you would like to plot a line through the points straight # away. pgline($n, $x->get_dataref, $y->get_dataref) if $o->{PlotLine}>0; $self->_restore_status(); $self->_add_to_state(\&points, $in, $opt); &release_signals; 1; } } # add a "wedge" to the image # - since this can be called from imag() as well as by the user, # we make all parameters defined as options # # Wedge => { # Side => one of B L T R, # Displacement => default = 2, # Width => default = 3, # Fg/Bg => default, values used by imag() # Label => default '' # } # # - uses horrible _store()/_retrieve() routines, which need to # know (but don't) about changing window focus/erasing/... # # Want to be able to specify a title (optional) # - also, by default want to use the axes colour/size, but want to be able to # over-ride this # # initial version by Doug Burke (11/20/00 ish) { my $wedge_options = undef; sub draw_wedge { my $self = shift; if ( !defined($wegde_options) ) { $wedge_options = $self->{PlotOptions}->extend({ Side => 'R', Displacement => 1.5, Width =>3.0, WTitle => undef, Label => undef, ForeGround => undef, BackGround => undef, }); $wedge_options->synonyms({ Fg => 'ForeGround', Bg => 'BackGround' }); } my ( $in, $opt ) = _extract_hash(@_); $opt = {} unless defined($opt); release_and_barf 'Usage: $win->draw_wedge( [$options] )' unless $#$in == -1; &catch_signals; # check imag has been called, and get information # - this is HORRIBLE my $iref = $self->_retrieve( 'imag' ); release_and_barf 'draw_wedge() can only be called after a call to imag()' unless defined $iref; # Let us parse the options if any. # - not convinced I know what I'm doing my $o; if ( defined $opt->{Wedge} ) { $o = $wedge_options->options( $opt->{Wedge} ); } else { $o = $wedge_options->current(); } $o->{ForeGround} = $$iref{max} unless defined( $o->{ForeGround} ); $o->{BackGround} = $$iref{min} unless defined( $o->{BackGround} ); # do we really want this? # - (03/15/01 DJB) removed since I assume that draw_wedge() # will be called before the focus has been changed. # Not ideal, but I don't think the current implementation will # handle such cases anyway (ie getting the correct min/max values # for the wedge). # $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); # get the options used to draw the axes # note: use the window object, not the options hash, though we # probably could/should do that my $wo = $self->{_env_options}[4]; # Save current status $self->_save_status(); # we use the colour/size of the axes here $self->_set_colour($wo->{AxisColour}); pgsch($wo->{CharSize}); # draw the wedge my $side = $o->{Side} . $$iref{routine}; pgwedg( $side, $o->{Displacement}, $o->{Width}, $o->{BackGround}, $o->{ForeGround}, $o->{Label} || $o->{WTitle} || '' ); # restore character colour & size before returning $self->_restore_status(); $self->_add_to_state(\&draw_wedge, $in, $opt); &release_signals; 1; } # sub: draw_wedge() } ###################################################################### # # imag and related functions # # display an image using pgimag()/pggray()/pgrgbi() as appropriate. # # The longish routine '_imag' handles the meat and potatoes of the setup, # but hands off the final plot to the PGPLOT routines pgimag() or pgrgbi(). # It expects a ref to the appropriate function to be passed in. The # userland methods 'imag' and 'rgbi' are just trampolines that call _imag # with the appropriate function ref. # # This gets pretty sticky for fits_imag, which is itself a trampoline for # _fits_foo -- so if you call fits_imag, it trampolines into fits_foo, which # does setup and then bounces into imag, which in turn hands off control # to pgimag. What a mess -- but at least it seems to work OK. For now. # -- CED 20-Jan-2002 # { # The ITF is in the general options - since other functions might want # it too. # # There is some repetetiveness in the code, but this is to allow the # user to set global defaults when opening a new window. # # # my $im_options = undef; sub _imag { my $self = shift; if (!defined($im_options)) { $im_options = $self->{PlotOptions}->extend({ Min => undef, Max => undef, Range => undef, CRange => undef, DrawWedge => 0, Wedge => undef, Justify => undef, Transform => undef }); } ############################## # Unwrap first two arguments: the PGPLOT call and the # dimensions of the image variable (2 or 3 depending # on whether this is called by imag or rgbi) my $pgcall = shift; my $image_dims = shift; ############################## # Pull out the rest of the arg list, and parse the options (if any). my ($in, $opt)=_extract_hash(@_); $opt = {} if !defined($opt); my ($o, $u_opt) = $self->_parse_options($im_options, $opt); ########## # Default to putting tick marks outside the box, so that you don't # scrozzle images. $o->{Axis} = 'BCINST' unless (defined($opt->{Axis}) || ($o->{Axis} ne 'BCNST')); $self->_add_to_state(\&imag, $in, $opt); release_and_barf 'Usage: (imag|rgbi) ( $image, [$min, $max, $transform] )' if $#$in<0 || $#$in>3; my ($image,$min,$max,$tr) = @$in; my ($cmin, $cmax) = (0,1); ## Make sure the image has the right number of dims... $self->_checkarg($image,$image_dims); my($nx,$ny) = $image->dims; $nx = 1 unless($nx); $ny = 1 unless($ny); my $itf = 0; $tr = $u_opt->{Transform} if exists($u_opt->{Transform}); $min = $u_opt->{Min} if exists($u_opt->{Min}); $max = $u_opt->{Max} if exists($u_opt->{Max}); # Check on ITF value hardcoded in. $itf = $u_opt->{ITF} if exists($u_opt->{ITF}); release_and_barf ( "illegal ITF value `$val'") if $itf > 2 || $itf < 0; ## Option checker thunk gets defined only on first run-through. our $checker = sub { my($name,$opt,$min,$max) = @_; delete $opt->{$name} unless(defined $opt->{$name}); return unless exists($opt->{$name}); release_and_barf("$name option must be an array ref if specified.\n") if( ref ($opt->{$name}) ne 'ARRAY' ); ($$min,$$max) = @{$opt->{$name}} if defined($min); } unless(defined $checker); &$checker("Range", $u_opt, \$min, \$max); &$checker("CRange", $u_opt, \$cmin, \$cmax); &$checker("XRange", $u_opt); &$checker("YRange", $u_opt); $min = min($image) unless defined $min; $max = max($image) unless defined $max; if (defined($tr)) { $self->_checkarg($tr,1); release_and_barf '$transform incorrect' if nelem($tr)!=6; } else { $tr = float [0,1,0, 0,0,1]; } $tr = $self->CtoF77coords($tr); &catch_signals; $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); $self->initenv( _image_xyrange($tr,$nx,$ny,$o), $o ); # # Commented out, CED, 5-Dec-2003 -- # this is handled by redraw_axes, at the bottom. # #if (!$self->held()) { # # Label axes if necessary # if(defined ($u_opt->{Title} || # $u_opt->{XTitle} || # $u_opt->{YTitle})) { # $self->label_axes($u_opt->{XTitle}, # $u_opt->{YTitle}, # $u_opt->{Title}, # $u_opt); # } # } pgsitf( $itf ); my ($i1, $i2); pgqcir($i1, $i2); # Default color range my($c1,$c2); $c1 = int($i1 + ($i2-$i1) * $cmin + 0.5); $c2 = int($i1 + ($i2-$i1) * $cmax + 0.5); print "Displaying $nx x $ny image from $min to $max, using ".($c2-$c1+1)." colors ($c1-$c2)...\n" if $PDL::verbose; # Disable PS pggray output because the driver is busted in pgplot-2.3 # (haven't tested later versions). pgimag seems to work OK for that # output tho'. if ($c2-$c1<16 || $self->{Device} =~ /^v?ps$/i) { print STDERR "_imag: Under 16 colors available; reverting to pggray\n" if($PDL::debug || $PDL::verbose); pggray( $image->get_dataref, $nx,$ny,1,$nx,1,$ny, $min, $max, $tr->get_dataref); $self->_store( imag => { routine => "G", min => $min, max => $max } ); } else { $self->ctab('Grey') unless $self->_ctab_set(); # Start with grey pgscir($c1,$c2); &$pgcall( $image->get_dataref, $nx,$ny,1,$nx,1,$ny, $min, $max, $tr->get_dataref); pgscir($i1,$i2); $self->_store( imag => { routine => "I", min => $min, max => $max } ); } # draw the wedge, if requested if ( $u_opt->{DrawWedge} ) { my $hflag = $self->held(); $self->hold(); $self->draw_wedge( $u_opt ); $self->release() unless $hflag; } $self->redraw_axes($u_opt) unless $self->held(); &release_signals; 1; } # sub: imag() } ###################################################################### # Here are the `top-level' imaging routines -- they call _imag to get # the job done. ########## # image - the basic image plotter sub imag { my $me = shift; my $im = shift; my @a = @_; if(UNIVERSAL::isa($im,'PDL') && ($im->ndims == 3) && ($im->dim(2)==3)) { rgbi($me,$im,@a); return; } _imag($me,\&pgimag,2,$im,@a); } ########## # imag1 - Plot an image with Justify = 1 sub imag1 { my $self = shift; my ($in,$opt)=_extract_hash(@_); if (!defined($im_options)) { $im_options = $self->{PlotOptions}->extend({ Min => undef, Max => undef, DrawWedge => 0, Wedge => undef, XTitle => undef, YTitle => undef, Title => undef, Justify => 1 }); } # Let us parse the options if any. $opt = {} if !defined($opt); my ($o, $u_opt) = $self->_parse_options($im_options, $opt); release_and_barf 'Usage: imag1 ( $image, [$min, $max, $transform] )' if $#$in<0 || $#$in>3; $o->{Pix} = 1 unless defined($o->{Pix}); $self->imag (@$in,$o); # This is not added to the state, because the imag command does that. } ########## # rgbi - Plot an image with 3 color planes sub rgbi { unless($PGPLOT::RGB_OK) { print STDERR "PGPLOT rgbi called, but RGB support is not present. Using grayscale instead.\n"; my $me = shift; my $in = shift; my $in2; if($in->dim(0)==3 && $in->dim(1)>3 && $in->dim(2)>3) { $in2 = $in->sumover; } else { $in2 = $in->mv(2,0)->sumover; } my @a = @_; return _imag($me,\&pgimag,2,$in2,@a); } release_and_barf("rgbi: RGB-enabled PGPLOT is not present\n") unless($PGPLOT::RGB_OK); my $me = shift; my @a = @_; my($in,$opt) = _extract_hash(@_); my($image) = shift @$in; if(UNIVERSAL::isa($image,'PDL')) { @dims = $image->dims; if($dims[0] == 3 && $dims[1] > 3 && $dims[2] > 3) { print "rgbi: Hmmm... Found (rgb,X,Y) [deprecated] rather than (X,Y,rgb) [approved]." if($PDL::debug || $PDL::verbose); $image = $image->mv(0,2); } } $opt->{DrawWedge} = 0; # Get rid of nan elements... my $im2; my $m = !(isfinite $image); if(zcheck($m)) { $im2 = $image; } else { $im2 = $image->copy; $im2->range(scalar(whichND $m)) .= 0; } _imag($me,\&pgrgbi,3,$im2,@$in,$opt); } ###################################################################### # Here are the FITS subroutines # # They all use _fits_foo as a ``pre-call'' to set up the appropriate # image transformations and plot command. # # by fits_imag, fits_rgbi, and fits_cont. # { my $f_im_options = undef; sub _fits_foo { my $pane = shift; my $cmd = shift; my ($in,$opt_in) = _extract_hash(@_); my ($pdl,@rest) = @$in; $opt_in = {} unless defined($opt_in); unless ( defined($f_im_options) ) { $f_im_options = $pane->{PlotOptions}->extend({ Contours=>undef, Follow=>0, Labels=>undef, LabelColour=>undef, Missing=>undef, NContours=>undef, FillContours=>undef, Min => undef, Max => undef, DrawWedge => 0, Wedge => undef, XRange=>undef, YRange=>undef, XTitle => undef, YTitle => undef, Title => undef, CharSize=>undef, CharThick=>undef, HardCH=>undef, HardLW=>undef, TextThick=>undef, WCS => undef, }); } my($opt,$u_opt) = $pane->_parse_options($f_im_options,$opt_in); my $hdr = $pdl->gethdr(); # What WCS system are we using? # we could check that the WCS is valid here but we delegate it # to the _FITS_tr() routine. # my $wcs = $$u_opt{WCS} || ""; %opt2 = %{$u_opt}; # copy options delete $opt2{WCS}; $opt2{Transform} = _FITS_tr($pane,$pdl,{WCS => $wcs}); local($_); foreach $_(keys %opt2){ delete $opt2{$_} if (m/title/i); } $opt2{Align} = 'CC' unless defined($opt2{Align}); $opt2{DrawWedge} = 1 unless defined($opt2{DrawWedge}); my $min = (defined $opt->{min}) ? $opt->{min} : $pdl->min; my $max = (defined $opt->{max}) ? $opt->{max} : $pdl->max; my $unit = $pdl->gethdr->{BUNIT} || ""; my $rangestr = " ($min to $max $unit) "; # I am assuming here that CUNIT1<A-Z> is a valid keyword for # 'alternative' WCS mappings (DJB) # $opt2{Pix}=1.0 if( (!defined($opt2{Justify}) || !$opt2{Justify}) && (!defined($opt2{Pix})) && ( $hdr->{"CUNIT1$wcs"} ? ($hdr->{"CUNIT1$wcs"} eq $hdr->{"CUNIT2$wcs"}) : ($hdr->{"CTYPE1$wcs"} eq $hdr->{"CTYPE2$wcs"}) ) ); my $o2 = \%opt2; my $cmdstr = '$pane->' . $cmd . '($pdl,' . (scalar(@rest) ? '@rest,' : '') . '$o2);'; eval $cmdstr; my $mkaxis = sub { my ($typ,$unit) = @_; our @templates = ("(arbitrary units)","%u","%t","%t (%u)"); $s = $templates[2 * (defined $typ) + (defined $unit && $unit !~ m/^\s+$/)]; $s =~ s/\%u/$unit/; $s =~ s/\%t/$typ/; $s; }; $pane->label_axes( $opt->{XTitle} || &$mkaxis($hdr->{"CTYPE1$wcs"},$hdr->{"CUNIT1$wcs"}), $opt->{YTitle} || &$mkaxis($hdr->{"CTYPE2$wcs"},$hdr->{"CUNIT2$wcs"}), $opt->{Title}, $opt ); } # sub: _fits_foo() sub fits_imag { my($self) = shift; _fits_foo($self,'imag',@_); } sub fits_rgbi { my($self) = shift; _fits_foo($self,'rgbi',@_); } sub fits_cont { my($self) = shift; _fits_foo($self,'cont',@_); } sub fits_vect { my($self) = shift; _fits_vect($self,'vect',@_); } } # closure around _fits_foo and fits_XXXX routines # Load a colour table using pgctab() # # Modified 7/4/02 JB - having the last colour table as a variable in here # did not work. So it is now moved to the $self hash. { # This routine doesn't really have any options at the moment, but # it uses the following standard variables my %CTAB = (); $CTAB{Grey} = [ pdl([0,1],[0,1],[0,1],[0,1]) ]; $CTAB{Igrey} = [ pdl([0,1],[1,0],[1,0],[1,0]) ]; $CTAB{Fire} = [ pdl([0,0.33,0.66,1],[0,1,1,1],[0,0,1,1],[0,0,0,1]) ]; $CTAB{Gray} = $CTAB{Grey}; # Alias $CTAB{Igray} = $CTAB{Igrey}; # Alias # It would be easy to add options though.. sub _ctab_set { my $self = shift; return defined($self->{CTAB}); } sub ctab { my $self = shift; my ($in, $opt)=_extract_hash(@_); # No arguments -- print list of tables if (scalar(@$in) == 0) { print "Available 'standard' color tables are:\n",join(",",sort keys %CTAB) ,"\n"; return; } # No arguments -- print list of tables if (scalar(@$in) == 0) { print "Available 'standard' color tables are:\n",join(",",sort keys %CTAB) ,"\n"; return; } # First indirect arg list through %CTAB my(@arg) = @$in; my($ctab, $levels, $red, $green, $blue, $contrast, $brightness, @t, $n); if ($#arg>=0 && !ref($arg[0])) { # First arg is a name not an object # if first arg is undef or empty string, means use last CTAB. # preload with Grey if no prior CTAB $arg[0] = 'Grey' unless $arg[0] || $self->{CTAB}; # now check if we're using the last one specified if ( ! $arg[0] ) { shift @arg; unshift @arg, @{$self-{CTAB}->{ctab}}; $brightness = $self->{CTAB}->{brightness}; $contrast = $self->{CTAB}->{contrast}; } else { my $name = ucfirst(lc(shift @arg)); # My convention is $CTAB{Grey} etc... release_and_barf "$name is not a standard colour table" unless defined $CTAB{$name}; unshift @arg, @{$CTAB{$name}}; } } if ($#arg<0 || $#arg>5) { my @std = keys %CTAB; release_and_barf <<"EOD"; Usage: ctab ( \$name, [\$contrast, $\brightness] ) # Builtin col table [Builtins: @std] ctab ( \$ctab, [\$contrast, \$brightness] ) # $ctab is Nx4 array ctab ( \$levels, \$red, \$green, \$blue, [\$contrast, \$brightness] ) EOD } if ($#arg<3) { ($ctab, $contrast, $brightness) = @arg; @t = $ctab->dims; release_and_barf 'Must be a Nx4 array' if $#t != 1 || $t[1] != 4; $n = $t[0]; $ctab = float($ctab) if $ctab->get_datatype != $PDL_F; my $nn = $n-1; $levels = $ctab->(0:$nn,0:0); $red = $ctab->(0:$nn,1:1); $green = $ctab->(0:$nn,2:2); $blue = $ctab->(0:$nn,3:3); } else { ($levels, $red, $green, $blue, $contrast, $brightness) = @arg; $self->_checkarg($levels,1); $n = nelem($levels); for ($red,$green,$blue) { $self->_checkarg($_,1); release_and_barf 'Arguments must have same size' unless nelem($_) == $n; } } # Now load it $contrast = 1 unless defined $contrast; $brightness = 0.5 unless defined $brightness; &catch_signals; focus( $self ); pgctab( $levels->get_dataref, $red->get_dataref, $green->get_dataref, $blue->get_dataref, $n, $contrast, $brightness ); $self->{CTAB} = { ctab => [ $levels, $red, $green, $blue ], brightness => $brightness, contrast => $contrast }; # Loaded $self->_add_to_state(\&ctab, $in, $opt); &release_signals; 1; } # get information on last CTAB load sub ctab_info { my $self = shift; my ($in, $opt)=_extract_hash(@_); release_and_barf 'Usage: ctab_info( )' if $#$in> -1; return () unless $self->{CTAB}; return @{$self->{CTAB}->{ctab}}, $self-{CTAB}->{contrast}, $self->{CTAB}->{brightness}; } } # display an image using pghi2d() { my $hi2d_options = undef; sub hi2d { my $self = shift; if (!defined($hi2d_options)) { $hi2d_options = $self->{PlotOptions}->extend({ Ioff => undef, Bias => undef }); } my ($in, $opt)=_extract_hash(@_); $opt = {} if !defined($opt); release_and_barf 'Usage: hi2d ( $image, [$x, $ioff, $bias] [, $options] )' if $#$in<0 || $#$in>3; my ($image, $x, $ioff, $bias) = @$in; $self->_checkarg($image,2); my($nx,$ny) = $image->dims; # Let us parse the options if any. my ($o, $u_opt) = $self->_parse_options($hi2d_options, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); if (defined($x)) { $self->_checkarg($x,1); release_and_barf '$x incorrect' if nelem($x)!=$nx; } else { $x = float(sequence($nx)); } # Parse for options input instead of calling convention $ioff = $o->{Ioff} || 1 unless defined($ioff); $bias = $o->{Bias} if defined($o->{Bias}); $bias = 5*max($image)/$ny unless defined $bias; my $work = float(zeroes($nx)); &catch_signals; $self->_save_status(); $self->_standard_options_parser($u_opt); $self->initenv( 0 ,2*($nx-1), 0, 10*max($image), $opt ) unless $self->held(); pghi2d($image->get_dataref, $nx, $ny, 1,$nx,1,$ny, $x->get_dataref, $ioff, $bias, 1, $work->get_dataref); $self->_restore_status(); $self->_add_to_state(\&hi2d, $in, $opt); &release_signals; 1; } } # Plot a rectangle with pgrect() sub rect { my $self = shift; my ($in, $opt)=_extract_hash(@_); release_and_barf 'Usage: rect ( $x1, $x2, $y1, $y2 [, $options] )' if( $#$in<0 || $#$in>3); my($x1,$x2,$y1,$y2) = @$in; $self->_checkarg($x1,1); $self->_checkarg($x2,1); $self->_checkarg($y1,1); $self->_checkarg($y2,1); my ($o, $u_opt) = $self->_parse_options($self->{PlotOptions}, ($opt || {})); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); &catch_signals; unless ( $self->held() ) { my ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax(pdl($x1->at(0),$x2->at(0))); my ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax(pdl($y1->at(0),$y2->at(0))); if ($xmin == $xmax) { $xmin -= 0.5; $xmax += 0.5; } if ($ymin == $ymax) { $ymin -= 0.5; $ymax += 0.5; } $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt ); } $self->_save_status(); $self->_standard_options_parser($u_opt); pgrect($x1, $x2, $y1, $y2); $self->_restore_status(); $self->_add_to_state(\&poly, $in, $opt); &release_signals; 1; } # Plot a polygon with pgpoly() sub poly { my $self = shift; my ($in, $opt)=_extract_hash(@_); release_and_barf 'Usage: poly ( $x, $y [, $options] )' if $#$in<0 || $#$in>2; my($x,$y) = @$in; $self->_checkarg($x,1); $self->_checkarg($y,1); my ($o, $u_opt) = $self->_parse_options($self->{PlotOptions}, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); &catch_signals; unless ( $self->held() ) { my ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x); my ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($y); if ($xmin == $xmax) { $xmin -= 0.5; $xmax += 0.5; } if ($ymin == $ymax) { $ymin -= 0.5; $ymax += 0.5; } $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt ); } $self->_save_status(); $self->_standard_options_parser($u_opt); my $n = nelem($x); pgpoly($n, $x->get_dataref, $y->get_dataref); $self->_restore_status(); $self->_add_to_state(\&poly, $in, $opt); &release_signals; 1; } # Plot a circle using pgcirc { my $circle_options = undef; sub circle { my $self = shift; if (!defined($circle_options)) { $circle_options = $self->{PlotOptions}->extend({Radius => undef, XCenter => undef, YCenter => undef}); } my ($in, $opt)=_extract_hash(@_); $opt = {} if !defined($opt); my ($x, $y, $radius)=@$in; my ($o, $u_opt) = $self->_parse_options($circle_options, $opt); $o->{XCenter}=$x if defined($x); $o->{YCenter}=$y if defined($y); $o->{Radius} = $radius if defined($radius); &catch_signals; $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); ##DAL added this to properly set environment unless ( $self->held() ) { my ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : ($x-$radius,$x+$radius); my ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : ($y-$radius,$y+$radius); $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt ); } ##end DAL addition $self->_save_status(); $self->_standard_options_parser($u_opt); pgcirc($o->{XCenter}, $o->{YCenter}, $o->{Radius}); $self->_restore_status(); $self->_add_to_state(\&circle, $in, $opt); &release_signals; } } my $circle_options = undef; sub tcircle { my $self = shift; my ($in, $opt)=_extract_hash(@_); $self->_add_to_state(\&tcircle,$in,$opt); $opt = {} if !defined($opt); release_and_barf 'Usage tcircle ($x,$y,$r,[$options])' if $#$in < 0 || $#$in > 3; my ($x, $y, $radius)=@$in; $x=$x->flat;$y=$y->flat;$radius=$radius->flat; if (!defined($circle_options)){ $circle_options=$self->{PlotOptions}->extend({Missing => undef}); } &catch_signals; my $o = _thread_options($x->nelem,$opt); my $tmp_hold = $self->held(); unless ( $self->held() ) { my ($o,$u_opt) = $self->_parse_options($circle_options,$opt); $self->_check_move_or_erase($o->{Panel},$o->{Erase}); my ($ymin, $ymax, $xmin, $xmax); if ( defined $o->{Missing} ) { ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : minmax($y->where($y != $o->{Missing})); ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : minmax($x->where($x != $o->{Missing})); } else { ($ymin, $ymax)=ref $o->{YRange} eq 'ARRAY' ? @{$o->{YRange}} : (min($y-$radius),max($y+$radius)); ($xmin, $xmax)=ref $o->{XRange} eq 'ARRAY' ? @{$o->{XRange}} : (min($x-$radius),max($x+$radius)); } if ($xmin == $xmax) { $xmin-=0.5; $xmax +=0.5; } if ($ymin == $ymax) { $ymin-=0.5; $ymax +=0.5; } $self->initenv( $xmin, $xmax, $ymin, $ymax, $opt); $self->hold; } _tcircle($x,$y,$radius,PDL->sequence($x->nelem),$self,$o); $self->release unless $tmp_hold; &release_signals; } PDL::thread_define '_tcircle(a();b();c();ind()), NOtherPars => 2', PDL::over { my ($x,$y,$r,$ind,$self,$opt)=@_; $self->circle($x,$y,$r,$opt->[$ind->at(0)] || {} ); }; # Plot an ellipse using poly. { my $ell_options = undef; sub ellipse { my $self = shift; if (!defined($ell_options)) { $ell_options = $self->{PlotOptions}->extend({ MajorAxis=>undef, MinorAxis=>undef, Theta => 0.0, XCenter => undef, YCenter => undef, NPoints => 100 }); $ell_options->synonyms({Angle => 'Theta'}); } my ($in, $opt)=_extract_hash(@_); $opt = {} unless defined $opt; my ($x, $y, $a, $b, $theta)=@$in; my $o = $ell_options->options($opt); $o->{XCenter}=$x if defined($x); $o->{YCenter}=$y if defined($y); $o->{MajorAxis} = $a if defined($a); $o->{MinorAxis} = $b if defined($b); $o->{Theta}=$theta if defined($theta); if (!defined($o->{MajorAxis}) || !defined($o->{MinorAxis}) || !defined($o->{XCenter}) || !defined($o->{YCenter})) { release_and_barf "The major and minor axis and the center coordinates must be given!"; } &catch_signals; $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); my $t = 2*$PI*sequence($o->{NPoints})/($o->{NPoints}-1); my ($xtmp, $ytmp) = ($o->{MajorAxis}*cos($t), $o->{MinorAxis}*sin($t)); # Rotate the ellipse and shift it. my ($costheta, $sintheta)=(cos($o->{Theta}), sin($o->{Theta})); $x = $o->{XCenter}+$xtmp*$costheta-$ytmp*$sintheta; $y = $o->{YCenter}+$xtmp*$sintheta+$ytmp*$costheta; $self->_add_to_state(\&ellipse, $in, $opt); # Now turn off recording so we don't get this one twice.. $self->turn_off_recording(); $self->poly($x, $y, $opt); $self->turn_on_recording(); &release_signals; } } { my $rect_opt = undef; sub rectangle { my $self = shift; my $usage='Usage: rectangle($xcenter, $ycenter, $xside, $yside, [, $angle, $opt])'; if (!defined($rect_opt)) { # No need to use $self->{PlotOptions} here since we # pass control to poly below. $rect_opt = PDL::Options->new({XCenter => undef, YCenter => undef, XSide => undef, YSide => undef, Angle => 0, Side => undef}); $rect_opt->synonyms({XCentre => 'XCenter', YCentre => 'YCenter', Theta => 'Angle'}); $rect_opt->warnonmissing(0); } my ($in, $opt)=_extract_hash(@_); $opt={} if !defined($opt); my ($xc, $yc, $xside, $yside, $angle)=@$in; my $o=$rect_opt->options($opt); $o->{XCenter}=$xc if defined($xc); $o->{YCenter}=$yc if defined($yc); $o->{XSide}=$xside if defined($xside); $o->{YSide}=$yside if defined($yside); $o->{Angle}=$angle if defined($angle); ## # Now do some error checking and checks for squares. ## if (defined($o->{XSide}) || defined($o->{YSide})) { # At least one of these are set - let us ignore Side. $o->{XSide}=$o->{YSide} if !defined($o->{XSide}); $o->{YSide}=$o->{XSide} if !defined($o->{YSide}); } elsif (defined($o->{Side})) { $o->{XSide}=$o->{Side}; $o->{YSide}=$o->{Side}; } else { print "$usage\n"; release_and_barf 'The sides of the rectangle must be specified!'; } unless (defined($o->{XCenter}) && defined($o->{YCenter})) { print "$usage\n"; release_and_barf 'The center of the rectangle must be specified!'; } &catch_signals; $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); # Ok if we got this far it is about time to do something useful, # namely construct the piddle that contains the sides of the rectangle. # We make it first parallell to the coordinate axes around origo # and rotate it subsequently (ala the ellipse routine above). my ($dx, $dy)=(0.5*$o->{XSide}, 0.5*$o->{YSide}); my $xtmp = pdl(-$dx, $dx, $dx, -$dx, -$dx); my $ytmp = pdl(-$dy, -$dy, $dy, $dy, -$dy); my ($costheta, $sintheta)=(cos($o->{Angle}), sin($o->{Angle})); my $x = $o->{XCenter}+$xtmp*$costheta-$ytmp*$sintheta; my $y = $o->{YCenter}+$xtmp*$sintheta+$ytmp*$costheta; $self->_add_to_state(\&rectangle, $in, $opt); # Turn off recording temporarily. $self->turn_off_recording(); $self->poly($x, $y, $opt); $self->turn_on_recording(); &release_signals; } } # display a vector map of 2 images using pgvect() { my $vect_options = undef; sub vect { my $self = shift; if (!defined($vect_options)) { $vect_options = $self->{PlotOptions}->extend({ Scale => 0, Position => 0, Missing => undef }); $vect_options->add_synonym({Pos => 'Position'}); } my ($in, $opt)=_extract_hash(@_); release_and_barf 'Usage: vect ( $a, $b, [$scale, $pos, $transform, $misval] )' if $#$in<1 || $#$in>5; my ($a, $b, $scale, $pos, $tr, $misval) = @$in; $self->_checkarg($a,2); $self->_checkarg($b,2); my($nx,$ny) = $a->dims; my($n1,$n2) = $b->dims; release_and_barf 'Dimensions of $a and $b must be the same' unless $n1==$nx && $n2==$ny; my ($o, $u_opt) = $self->_parse_options($vect_options, $opt); $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); # Parse for options input instead of calling convention $scale = $o->{Scale} if exists($u_opt->{Scale}); $pos = $o->{Position} if exists($u_opt->{Scale}); $tr = $o->{Transform} if exists($u_opt->{Transform}); $misval = $o->{Missing} if exists($u_opt->{Missing}); #What if there's no Missing option supplied and one of the input piddles #contain zero? Then that location will have no arrow, instead of a #horizontal or vertical line. So define $misval, but make it meaningless: $misval = 1 + $a->glue(0,$b)->flat->maximum unless defined $misval; #DAL added 02-Jan-2006 $scale = 0 unless defined $scale; $pos = 0 unless defined $pos; if (defined($tr)) { $self->_checkarg($tr,1); release_and_barf '$transform incorrect' if nelem($tr)!=6; } else { $tr = float [0,1,0, 0,0,1]; } $tr = $self->CtoF77coords($tr); &catch_signals; $self->initenv( 0, $nx-1, 0, $ny-1, $opt ) unless $self->held(); print "Vectoring $nx x $ny images ...\n" if $PDL::verbose; $self->_save_status(); $self->_standard_options_parser($u_opt); # For arrowtype and arrowhead pgvect( $a->get_dataref, $b->get_dataref, $nx,$ny,1,$nx,1,$ny, $scale, $pos, $tr->get_dataref, $misval); $self->_restore_status(); $self->_add_to_state(\&vect, $in, $opt); &release_signals; 1; } } # ############ Text routines ############# { # Do not create this object unless necessary. my $text_options = undef; sub text { my $self = shift; if (!defined($text_options)) { # This is the first time this routine is called so we # have to initialise the options object. $text_options = $self->{PlotOptions}->extend({ Angle => 0.0, Justification => 0.0, Text => '', XPos => undef, YPos => undef }); $text_options->add_synonym({Justify => 'Justification'}); $text_options->add_synonym({Bg => 'BackgroundColour'}); } # Extract the options hash and separate it from the other input my ($in, $opt)=_extract_hash(@_); $opt = {} if !defined($opt); release_and_barf 'Usage: text ($text, $x, $y, [,$opt])' if (!defined($opt) && $#$in < 2) || ($#$in > 3) || ($#$in < 0); my ($text, $x, $y)=@$in; # Next - parse options my ($o, $u_opt) = $self->_parse_options($text_options, $opt); # Check for change of panel or request to erase the panel # (Commented out by CED 21-Jun-2002, because this seems # to erase too much -- e.g. it's hard to scribble on a line plot!) # $self->_check_move_or_erase($o->{Panel}, $o->{Erase}); # Parse standard options such as colour $self->_save_status(); $self->_standard_options_parser($u_opt); # Finally do what the routine needs to do. $o->{Text}=$text if defined($text); $o->{XPos}=$x if defined($x); $o->{YPos}=$y if defined($y); release_and_barf "text: You must specify the X-position!\n" if !defined($o->{XPos}); release_and_barf "text: You must specify the Y-position!\n" if !defined($o->{YPos}); &catch_signals; # Added support for different background colours.. # 2/10/01 JB - To avoid -w noise we use a reg-exp.. if ($o->{BackgroundColour} !~ m/^-\d+$/) { $self->_set_colour($o->{BackgroundColour}, 1); } # what width do we use? # - things are somewhat confused since we have # LineWidth and TextWidth (a recent addition) # and LineWidth is set by _setup_window() - so # _standard_options_parser() uses it - but # TextWidth isn't. # # so for now we over-ride the _standard_options_parser # setting if TextWidth exists # [DJB 2002 Aug 08] my $old_lw; if ( defined($o->{TextWidth}) ) { pgqlw($old_lw); pgslw($o->{TextWidth}); } my $old_bg; pgptxt($o->{XPos}, $o->{YPos}, $o->{Angle}, $o->{Justification}, $o->{Text}); pgslw($old_lw) if defined $old_lw; # $self->_restore_status(); $self->_add_to_state(\&text, $in, $opt); &release_signals; 1; } } { my $legend_options = undef; sub legend { my $self = shift; if (!defined($legend_options)) { $legend_options = $self->{PlotOptions}->extend({ Text => undef, XPos => undef, YPos => undef, Width => 'Automatic', Height => 'Automatic', TextFraction => 0.5, TextShift => 0.1, VertSpace => 0 }); # should this be synonyms() or add_synonym() ? DJB 09 Apr 03 $legend_options->add_synonym({ VSpace => 'VertSpace', Fraction => 'TextFraction', Bg => 'BackgroundColour', }); } my ($in, $opt)=_extract_hash(@_); $opt = {} if !defined($opt); my ($o, $u_opt) = $self->_parse_options($legend_options, $opt); # # In this function there are several options that we do not want # parsed by the standard options parsers so we deal with these # here - we translate the linestyles, symbols and colours below # my %myopt; foreach my $optname ( qw( LineStyle LineWidth Colour Symbol ) ) { my $tmp = $u_opt->{$optname}; $myopt{lc($optname)} = ref($tmp) eq "ARRAY" ? $tmp : [$tmp]; delete $u_opt->{$optname}; } my ($text, $x, $y, $width)=@$in; $o->{Text} = $text if defined($text); $o->{XPos} = $x if defined($x); $o->{YPos} = $y if defined($y); $o->{Width} = $width if defined($width); # We could keep accessing $o but this is more succint. # [In the following we want to deal with an array of text.] $text = $o->{Text}; $text = [$text] unless ref($text) eq 'ARRAY'; my $n_lines = $#$text+1; if (!defined($o->{XPos}) || !defined($o->{YPos}) || !defined($o->{Text})) { release_and_barf 'Usage: legend $text, $x, $y [,$width, $opt] (styles are given in $opt)'; } &catch_signals; $self->_save_status(); $self->_standard_options_parser($u_opt); # Set font, charsize, colour etc. # Ok, introductory stuff has been done, lets get down to the gritty # details. First let us save the current character size. pgqch(my $chsz); ## Now, set the background colour of the text before getting further. ## Added 2/10/01 - JB - test as a regexp to avoid -w noise. if ($o->{BackgroundColour} !~ m/^-?\d+$/) { # Do this unless a negative integer.. $self->_set_colour($o->{BackgroundColour}, 1); } # The size of the legend can be specified by giving the width or the # height so to calculate the required text size we need to find the # minimum required (since text in PGPLOT cannot have variable width # and height. # Get the window size. pgqwin( my $xmin, my $xmax, my $ymin, my $ymax ); # note: VertSpace is assumed to be a scalar my $vfactor = 1.0 + $o->{VertSpace}; my $required_charsize=$chsz*9000; if ($o->{Width} eq 'Automatic' && $o->{Height} eq 'Automatic') { # Ok - we just continue with the given character size. $required_charsize = $chsz; # We still need to calculate the width and height of the legend # though. Fixed 20/3/01 my $t_width = -1; # Very short text... my $t_height = -1; # And very low foreach my $t (@$text) { # Find the bounding box of left-justified text pgqtxt($xmin, $ymin, 0.0, 0.0, $t, my $xbox, my $ybox); my $dx = $$xbox[2] - $$xbox[0]; my $dy = $$ybox[2] - $$ybox[0]; $t_width = $dx if $dx > $t_width; $t_height = $dy if $dy > $t_height; } $o->{Width} = $t_width/$o->{TextFraction}; # we include an optional vspace (which is given as a fraction of the # height of a line) $o->{Height} = $t_height*$vfactor*$n_lines; # The height of all lines.. } else { # We have some constraint on the size. my ($win_width, $win_height)=($xmax-$xmin, $ymax-$ymin); # If either the width or the height is set to automatic we set # the width/height here to be 2 times the width/height of the # plot window - thus ensuring not too large a text size should the # user have done something stupid, but still large enough to # detect an error. $o->{Width} = 2*$win_width/$o->{TextFraction} if $o->{Width} eq 'Automatic'; $o->{Height} = 2*$win_height if $o->{Height} eq 'Automatic'; foreach my $t (@$text) { # Find the bounding box of left-justified text pgqtxt($xmin, $ymin, 0.0, 0.0, $t, my $xbox, my $ybox); my $dx = $$xbox[2] - $$xbox[0]; my $dy = $$ybox[2] - $$ybox[0]; # Find what charactersize is required to fit the height # (accounting for vspace) or fraction*width: my $t_width = $o->{TextFraction}*$o->{Width}/$dx; my $t_height = $o->{Height}/$vfactor/$n_lines/$dy; # XXX is $vfactor==(1+VertSpace) correct? $t_chsz = ($t_width < $t_height ? $t_width*$chsz : $t_height*$chsz); $required_charsize = $t_chsz if $t_chsz < $required_charsize; pgsch($required_charsize*$chsz); # Since we measured relative to $chsz } } # # Ok, $required_charsize should now contain the optimal size for the # text. The next step is to create the legend. We can set linestyle, # linewidth, colour and symbol for each of these texts. # my ($xpos, $ypos) = ($o->{XPos}, $o->{YPos}); my ($xstart, $xend)=($o->{XPos}+$o->{TextFraction}*$o->{Width}+ $o->{TextShift}*$o->{Width}, $o->{XPos}+$o->{Width}); my $xmid = 0.5 * ($xstart + $xend); # step size in y my $ystep = $o->{Height} / $n_lines; # store current settings pgqci(my $col); pgqls(my $ls); pgqlw(my $lw); foreach (my $i=0; $i<$n_lines; $i++) { $self->text($text->[$i], $xpos, $ypos); # Since the parsing of options does not go down array references # we need to create a temporary PDL::Options object here to do the # parsing.. my $t_o = $self->{PlotOptions}->options({ Symbol => $myopt{symbol}[$i], LineStyle => $myopt{linestyle}[$i], LineWidth => $myopt{linewidth}[$i], Colour => $myopt{colour}[$i], }); $self->_set_colour($t_o->{Colour}) if defined($myopt{colour}[$i]); # Use the following to get the lines/symbols centered on the # text. pgqtxt($xpos, $ypos, 0.0, 0.0, $text->[$i], my $xbox, my $ybox); my $ymid = 0.5 * ($$ybox[2] + $$ybox[0]); if (defined($myopt{symbol}[$i])) { pgpt(1, $xmid, $ymid, $t_o->{Symbol}); } else { pgsls($t_o->{LineStyle}) if defined $myopt{linestyle}[$i]; pgslw($t_o->{LineWidth}) if defined $myopt{linewidth}[$i]; pgline(2, [$xstart, $xend], [$ymid, $ymid]); } # reset colour, line style & width after each line $self->_set_colour($col); pgsls($ls); pgslw($lw); $ypos -= $ystep; } $self->_restore_status(); $self->_add_to_state(\&legend, $in, $opt); &release_signals; } } ############## Cursor routine ################## { $cursor_options = undef; sub cursor { my $self = shift; # Let us check if this is a hardcopy device, in which case we will return # with a warning and undefined values. my ($hcopy, $len); pgask(0); pgqinf("HARDCOPY",$hcopy,$len); if ($hcopy eq 'YES') { warn "cursor called on a hardcopy device - returning!\n"; return (undef, undef, undef, undef, undef); } if (!defined($cursor_options)) { $cursor_options = PDL::Options->new( { 'XRef' => undef, 'YRef' => undef, 'Type' => 0 }); $cursor_options->translation({Type=>{ 'Default' => 0, 'RadialLine' => 1, 'Rectangle' => 2, 'TwoHorizontalLines' => 3, 'TwoVerticalLines' => 4, 'HorizontalLine' => 5, 'VerticalLine' => 6, 'CrossHair' => 7 }}); } my ($opt)=@_; $opt = {} unless defined($opt); my $place_cursor=1; # Since X&Y might be uninitialised. my $o = $cursor_options->options($opt); my ($x, $y, $ch); &catch_signals; # The window needs to be focussed before using the cursor commands. # Added 08/08/01 by JB after bug report from Brad Holden. $self->focus(); if ($o->{Type} eq 'Rectangle' && !defined($o->{XRef})) { # # We use pgcurs to get a first position. # print "Please select a corner of the rectangle\n"; pgcurs($x, $y, $ch); $o->{XRef}=$x; $o->{YRef}=$y; } if ($o->{Type} > 7 || $o->{Type} < 0) { print "Unknown type of cursor $$o{Type} - using Default\n"; $o->{Type}=0; } my ($xmin, $xmax, $ymax, $ymin); pgqwin($xmin, $xmax, $ymin, $ymax); $x = $o->{XRef} if defined($o->{XRef}); $y = $o->{YRef} if defined($o->{YRef}); $x = 0.5*($xmin+$xmax) if !defined($x); $y = 0.5*($ymin+$ymax) if !defined($y); my ($got_xref, $got_yref)=(defined($o->{XRef}), defined($o->{YRef})); if (!$got_xref || !$got_yref) { # There is a little bit of gritty error-checking # for the users convenience here. if ($o->{Type}==1 || $o->{Type}==2) { release_and_barf "When specifying $$o{Type} as cursor you must specify the reference point"; } elsif ($o->{Type}==3 && !$got_yref) { release_and_barf "When specifying two horizontal lines you must specify the Y-reference"; } elsif ($o->{Type}==4 && !$got_xref ) { release_and_barf "When specifying two vertical lines you must specify the X-reference"; } # Ok so we have some valid combination of type and reference point. $o->{XRef}=$xmin if !$got_xref; $o->{YRef}=$ymin if !$got_yref; } $ch = ''; # To silence -w my $istat = pgband($o->{Type}, $place_cursor, $o->{XRef}, $o->{YRef}, $x, $y, $ch); $self->_add_to_state(\&cursor, [], $opt); &release_signals; return ($x, $y, $ch, $o->{XRef}, $o->{YRef}); } } =head1 INTERNAL The coding tries to follow reasonable standards, so that all functions starting with an underscore should be considered as internal and should not be called from outside the package. In addition most routines have a set of options. These are encapsulated and are not accessible outside the routine. This is to avoid collisions between different variables. =head1 AUTHOR Karl Glazebrook [kgb@aaoepp.aao.gov.au] modified by Jarle Brinchmann (jarle@astro.ox.ac.uk) who is also responsible for the OO interface, docs mangled by Tuomas J. Lukka (lukka@fas.harvard.edu) and Christian Soeller (c.soeller@auckland.ac.nz). Further contributions and bugfixes from Kaj Wiik, Doug Burke, Craig DeForest, and many others. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # 1; __DATA__ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/PGPLOT/Window/Window.xs����������������������������������������������������������0000644�0601750�0601001�00000006270�12562522364�016247� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� /* PGPLOT.xs A few routines in C to speed up PDL access to PGPLOT primitives. */ #include "EXTERN.h" /* std perl include */ #include "perl.h" /* std perl include */ #include "XSUB.h" /* XSUB include */ #include "ppport.h" /* for backwards comaptibility */ struct PGPLOT_function_handle { I32 binversion; void (*cpgmove) (float x, float y); void (*cpgdraw) (float x, float y); void (*cpgqcir) (int *icilo, int *icihi); void (*cpgsci) (int ci); void (*cpgpt1) (float x, float y, int sym); }; typedef struct PGPLOT_function_handle PGPLOT_function_handle; static I32 PGPLOT_structure_version = 20000302; /* The date the PGPLOT structure changed */ static PGPLOT_function_handle *myhandle; SV *ptr; MODULE = PDL::Graphics::PGPLOT::Window PACKAGE = PDL::Graphics::PGPLOT::Window void pggapline(n,msgval,xpts,ypts) int n float msgval float * xpts float * ypts CODE: { int i; int start = 0; while (xpts[start] == msgval) start++; /* make sure we have a good starting point */ myhandle->cpgmove (xpts[start], ypts[start]); for (i=start+1;i<n;i++) { if (ypts[i] == msgval) { /* check we are not at end of array and we don't move to a missing value */ if (i != n-1 && ypts[i+1] != msgval) { myhandle->cpgmove (xpts[i+1], ypts[i+1]); } } else { myhandle->cpgdraw (xpts[i], ypts[i]); } } } void pgcolorpnts(n,x,y,z,sym) int n float * x float * y float * z int sym CODE: { /* find range of color pallette */ int icilo, icihi, i, cirange, ci; float minz, maxz, zrange; /* If the structure read from the PGPLOT module is too old */ if (myhandle->binversion < PGPLOT_structure_version) { char msg[128]; sprintf (msg, "This function requires PGPLOT with a structure version at least %d.\nPlease upgrade your PGPLOT package.", PGPLOT_structure_version); Perl_croak(aTHX_ "%s", msg); } myhandle->cpgqcir(&icilo, &icihi); /* find min and max values of zpts variable */ minz = 9.99e30; maxz = -9.99e30; for (i=0;i<n;i++) { if (z[i] < minz) minz = z[i]; if (z[i] > maxz) maxz = z[i]; } /* determine range of available z indices and range of input 'z' values */ cirange = icihi - icilo; zrange = maxz - minz; /* printf ("cilo = %d, cihi = %d\n", icilo, icihi); */ /* for each input point, compute a scaled color index and plot the point */ for (i=0;i<n;i++) { ci = (int)(icilo + (z[i] - minz) * (float)(cirange/zrange)); /* printf ("x = %f, y = %f, ci = %d\n", x[i], y[i], ci); */ myhandle->cpgsci(ci); myhandle->cpgpt1(x[i], y[i], sym); } } BOOT: /* Get pointer to structure of core shared C routines */ ptr = get_sv("PGPLOT::HANDLE",FALSE | GV_ADDMULTI); /* SV* value */ #ifndef aTHX_ #define aTHX_ #endif if (ptr==NULL) Perl_croak(aTHX_ "This module requires PGPLOT version 2.16 or later.\nPlease install/upgrade PGPLOT (see the PDL/DEPENDENCIES file)."); myhandle = INT2PTR(PGPLOT_function_handle*,SvIV( ptr )); ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/State.pm�������������������������������������������������������������������������0000644�0601750�0601001�00000005663�13036512175�013567� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME State - A package to keep track of plotting commands =head1 SYNOPSIS use PDL::Graphics::State; =head1 DESCRIPTION This is a very simple, at present almost trivial, package to keep track of the current set of plotting commands. =head1 USAGE You create a new object by calling the C<new> operator $state = PDL::Graphics::State->new(); Then for each new command you call C<add> on this object so that for a call to C<line> of the form line $x, $y, $opt; the call to C<add> would be like $state->add(\&line, 'line', [$x, $y], $opt); which is stored internally as: [\&line, 'line', [$x, $y], $opt] The state can later be extracted using C<get> which returns the state object which is an array of anonymous arrays like the one above where the first object is a reference to the function, the second an anomymous array of arguments to the function and finally an anonymous hash with options to the command. If you know the order in which you inserted commands they can be removed by calling C<remove> with the number in the stack. No further interaction is implemented except C<clear> which clears the stack and C<copy> which returns a "deep" copy of the state. =head1 AUTHOR Jarle Brinchmann (jarle@astro.ox.ac.uk) after some prodding by Karl Glazebrook. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Graphics::State; # # This is a very simple package to deal with the graphics state. # sub new { my $type = shift; my $self = { 'Commands' => [], }; bless $self, ref($type) || $type; return $self; } sub DESTROY { my $self = shift; $self->clear(); } sub add { my $self = shift; # The command is a reference to the subroutine, the data is an # anonymous array containing the data passed to the routine and # opt is the options hash PASSED TO THE ROUTINE.. my ($command, $command_name, $data, $opt) = @_; # Compact and not user-friendly storage. push @{$self->{Commands}}, [$command, $command_name, $data, $opt]; # return $#{$self->{Commands}}+1; } sub remove { my $self = shift; my $num = shift; # Remove entry #1 splice @{$self->{Commands}}, $num, 1; } sub get { my $self = shift; return @{$self->{Commands}}; } sub info { my $self = shift; print "The state has ".($#{$self->{Commands}}+1)." commands in the stack\n"; } sub show { my $self = shift; my $count=0; foreach my $arg (@{$self->{Commands}}) { print "$count - Func=$$arg[1]\n"; $count++; } } sub clear { my $self = shift; # Do I need to do more? $self->{Commands}=[]; } sub copy { my $self = shift; my $new = PDL::Graphics::State->new(); foreach my $arg (@{$self->{Commands}}) { $new->add(@$arg); } return $new; } 1; �����������������������������������������������������������������������������PDL-2.018/Graphics/TriD/����������������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�012765� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/Makefile.PL�����������������������������������������������������������������0000644�0601750�0601001�00000001737�12562522364�014767� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; # do we build the OpenGL/OpenGLQ stuff # (rather than have these 2 modules do it themselves) # # try and find out whether we should build the OpenGL/Mesa stuff # - first check is to dump win32 systems # my $gl_build = 0; my $gl_msg = ""; my $gl_dir = ""; my @subdirs = qw( Rout VRML ); if ( $PDL::Config{USE_POGL} ) { # build with OpenGL for GL bindings and compile/link info print "Graphics/TriD/Makefile.PL: using POGL for OpenGL bindings and compile options\n"; @subdirs = ( @subdirs, qw( POGL OpenGLQ ) ); $gl_build = 1; } else { print "Graphics/TriD/Makefile.PL: skipping build of TriD::OpenGL(Q) modules - no POGL\n"; } $PDL::Config{GL_BUILD} = $gl_build; # record for Config.pm WriteMakefile ( 'NAME' => "PDL::Graphics::TriD", 'VERSION_FROM' => '../../Basic/Core/Version.pm', 'DIR' => [ @subdirs ], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); ���������������������������������PDL-2.018/Graphics/TriD/OpenGLQ/��������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402045�014231� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/OpenGLQ/Makefile.PL���������������������������������������������������������0000644�0601750�0601001�00000002023�12562522364�016221� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; BEGIN { if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw()"; if (!$@) { eval "use OpenGL::Config"; } } } my @pack = (["openglq.pd", qw(OpenGLQ PDL::Graphics::OpenGLQ)]); my %hash = pdlpp_stdargs_int(@pack); if ( $PDL::Config{USE_POGL} ) { push @{$hash{LIBS}}, $OpenGL::Config->{LIBS}; $hash{DEFINE} .= ' '.$OpenGL::Config->{DEFINE}; $hash{INC} .= ' '.$OpenGL::Config->{INC}; if($^O eq 'MSWin32') { $hash{LDFROM} .= ' '. $OpenGL::Config->{LDFROM}; $hash{LDFROM} =~ s/\-lfreeglut//g; } } else { warn "Graphics/TriD/OpenGLQ/Makefile.PL: will not compile bindings without Perl OpenGL\n\n"; ## push @{$hash{LIBS}}, $PDL::Config{OPENGL_LIBS}; ## $hash{DEFINE} .= ' '.$PDL::Config{OPENGL_DEFINE}; ## $hash{INC} .= ' '.$PDL::Config{OPENGL_INC}; } ${$hash{LIBS}}[0] .= ' -lm'; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/OpenGLQ/openglq.pd����������������������������������������������������������0000644�0601750�0601001�00000016220�12562522364�016245� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::Graphics::OpenGLQ - quick routines to plot lots of stuff from piddles. =head1 SYNOPSIS only for internal use - see source =head1 DESCRIPTION only for internal use - see source =head1 AUTHOR Copyright (C) 1997,1998 Tuomas J. Lukka. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_addhdr(' #ifdef HAVE_AGL_GLUT #include <OpenGL/gl.h> #include <OpenGL/glu.h> #else #include <GL/gl.h> #include <GL/glu.h> #endif /* #include <GL/glx.h> */ /* #include "../OpenGL/OpenGL.m" */ /* D_OPENGL; */ '); #pp_add_boot(' # I_OPENGL; #'); @internal = (Doc => 'internal'); pp_def( 'line_3x_3c', GenericTypes => [F,D], Pars => 'coords(tri=3,n); colors(tri,n);', Code => ' glBegin(GL_LINE_STRIP); loop(n) %{ glColor3f( $colors(tri => 0), $colors(tri => 1), $colors(tri => 2) ); glVertex3f( $coords(tri => 0), $coords(tri => 1), $coords(tri => 2) ); %} glEnd(); ', @internal ); sub TRI {return "$_[0]$_[1](tri => 0), $_[0]$_[1](tri => 1), $_[0]$_[1](tri => 2)"} sub COLOR{ " glColor3f( ". TRI('$colors',$_[0]) ." ); " }; sub ADCOLOR{ " { GLfloat ad[4]; ".(join '',map {"ad[$_] = \$colors$_[0](tri => $_);"} 0..2). "ad[3] = 1.0; glMaterialfv(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE, ad); } " }; sub VERTEX{ " glVertex3f( ". TRI('$coords',$_[0]) ." ); " }; sub NORMAL{ " glNormal3f( ". TRI('$norm',$_[0]) ." ); " }; sub RPOS{ " glRasterPos3f( ". TRI('$coords',$_[0]) ." ); " }; pp_def('gl_points', GenericTypes => [F,D], Pars => 'coords(tri=3); colors(tri);', Code => ' glBegin(GL_POINTS); threadloop %{'.COLOR().VERTEX().' %} glEnd(); ', @internal ); pp_def( 'gl_lines', GenericTypes => [F,D], Pars => 'coords(tri,x);colors(tri,x);', Code => ' glBegin(GL_LINES); loop(x) %{ '.COLOR().VERTEX().' %} glEnd(); ', @internal ); pp_def( 'gl_line_strip', GenericTypes => [F,D], Pars => 'coords(tri,x);colors(tri,x);', Code => ' glBegin(GL_LINE_STRIP); loop(x) %{ '.COLOR().VERTEX().' %} glEnd(); ', @internal ); pp_def( 'gl_texts', GenericTypes => [F,D], Pars => 'coords(tri,x); ', OtherPars => 'int base; SV *arr', Code => ' SV *sv = $COMP(arr); AV *arr; if(!(SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)) { barf("gl_texts requires an array ref"); } arr = (AV *)SvRV(sv); glPushAttrib(GL_LIST_BIT); glListBase($COMP(base)); loop(x) %{ STRLEN n_a; SV *elem = *(av_fetch(arr, x, 0)); if(elem) { char *str = SvPV(elem,n_a); '.RPOS().' glCallLists(strlen(str),GL_UNSIGNED_BYTE, (GLubyte*)str); } %} glPopAttrib(); ', @internal ); for $m ( {Suf => '_mat', Func => \&ADCOLOR}, {Suf => '', Func => \&COLOR}, ) { for( {Name => 'gl_triangles', NormalCode => ''}, {Name => 'gl_triangles_n', NormalCode => ' tmp1[0] = $coordsb(tri => 0) - $coordsa(tri => 0); tmp1[1] = $coordsb(tri => 1) - $coordsa(tri => 1); tmp1[2] = $coordsb(tri => 2) - $coordsa(tri => 2); tmp2[0] = $coordsc(tri => 0) - $coordsa(tri => 0); tmp2[1] = $coordsc(tri => 1) - $coordsa(tri => 1); tmp2[2] = $coordsc(tri => 2) - $coordsa(tri => 2); glNormal3f( tmp1[1]*tmp2[2] - tmp2[1]*tmp1[2], -(tmp1[0]*tmp2[2] - tmp2[0]*tmp1[2]), tmp1[0]*tmp2[1] - tmp2[0]*tmp1[1] ); ' }, {Name => 'gl_triangles_wn', NormalArgs => 'norma(tri); normb(tri); normc(tri);', (map {("NormalCode".($_ eq 'A'?'':$_),NORMAL(lc $_))} (A..C)), }) { # This may be suboptimal but should still be fast enough.. # We only do triangles with this. pp_def( $_->{Name}.$m->{Suf}, GenericTypes => [F,D], Pars => 'coordsa(tri=3); coordsb(tri); coordsc(tri);'. $_->{NormalArgs}. 'colorsa(tri); colorsb(tri); colorsc(tri); ', Code => ' float tmp1[3]; float tmp2[3]; glBegin(GL_TRIANGLES); threadloop %{'. $_->{NormalCode} .&{$m->{Func}}("a").VERTEX("a"). $_->{NormalCodeB} .&{$m->{Func}}("b").VERTEX("b"). $_->{NormalCodeC} .&{$m->{Func}}("c").VERTEX("c").' %} glEnd(); ', @internal ); } } pp_def('gl_arrows', Pars => 'coords(tri=3,n); int indsa(); int indsb();', OtherPars => 'float headlen; float width;', Code => ' float hl = $COMP(headlen); float w = $COMP(width); float tmp2[3]; tmp2[0] = 0.000001; tmp2[1] = -0.0001; tmp2[2] = 1; glBegin(GL_LINES); threadloop %{ int a = $indsa(); int b = $indsb(); float tmp1[3]; float norm[3]; float norm2[3]; float normlen,origlen,norm2len; tmp1[0] = $coords(tri => 0, n => a) - $coords(tri => 0, n => b); tmp1[1] = $coords(tri => 1, n => a) - $coords(tri => 1, n => b); tmp1[2] = $coords(tri => 2, n => a) - $coords(tri => 2, n => b); norm[0] = tmp1[1]*tmp2[2] - tmp2[1]*tmp1[2]; norm[1] = -(tmp1[0]*tmp2[2] - tmp2[0]*tmp1[2]); norm[2] = tmp1[0]*tmp2[1] - tmp2[0]*tmp1[1]; norm2[0] = tmp1[1]*norm[2] - norm[1]*tmp1[2]; norm2[1] = -(tmp1[0]*norm[2] - norm[0]*tmp1[2]); norm2[2] = tmp1[0]*norm[1] - norm[0]*tmp1[1]; normlen = sqrt(norm[0] * norm[0] + norm[1] * norm[1] + norm[2] * norm[2]); norm2len = sqrt(norm2[0] * norm2[0] + norm2[1] * norm2[1] + norm2[2] * norm2[2]); origlen = sqrt(tmp1[0] * tmp1[0] + tmp1[1] * tmp1[1] + tmp1[2] * tmp1[2]); norm[0] *= w/normlen; norm[1] *= w/normlen; norm[2] *= w/normlen; norm2[0] *= w/norm2len; norm2[1] *= w/norm2len; norm2[2] *= w/norm2len; tmp1[0] /= origlen; tmp1[1] /= origlen; tmp1[2] /= origlen; glVertex3d( $coords(tri => 0, n => a) , $coords(tri => 1, n => a) , $coords(tri => 2, n => a) ); glVertex3d( $coords(tri => 0, n => b) , $coords(tri => 1, n => b) , $coords(tri => 2, n => b) ); if(w!=0) { glVertex3d( $coords(tri => 0, n => b) , $coords(tri => 1, n => b) , $coords(tri => 2, n => b) ); glVertex3d( $coords(tri => 0, n => b) + hl*tmp1[0] + norm[0], $coords(tri => 1, n => b) + hl*tmp1[1] + norm[1], $coords(tri => 2, n => b) + hl*tmp1[2] + norm[2]); glVertex3d( $coords(tri => 0, n => b) , $coords(tri => 1, n => b) , $coords(tri => 2, n => b) ); glVertex3d( $coords(tri => 0, n => b) + hl*tmp1[0] - norm[0], $coords(tri => 1, n => b) + hl*tmp1[1] - norm[1], $coords(tri => 2, n => b) + hl*tmp1[2] - norm[2]); glVertex3d( $coords(tri => 0, n => b) , $coords(tri => 1, n => b) , $coords(tri => 2, n => b) ); glVertex3d( $coords(tri => 0, n => b) + hl*tmp1[0] + norm2[0], $coords(tri => 1, n => b) + hl*tmp1[1] + norm2[1], $coords(tri => 2, n => b) + hl*tmp1[2] + norm2[2]); glVertex3d( $coords(tri => 0, n => b) , $coords(tri => 1, n => b) , $coords(tri => 2, n => b) ); glVertex3d( $coords(tri => 0, n => b) + hl*tmp1[0] - norm2[0], $coords(tri => 1, n => b) + hl*tmp1[1] - norm2[1], $coords(tri => 2, n => b) + hl*tmp1[2] - norm2[2]); } %} glEnd(); ', @internal ); pp_done(); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/POGL/�����������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013526� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/POGL/ignore.txt�������������������������������������������������������������0000644�0601750�0601001�00000000166�12562522364�015575� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������blib* Makefile Makefile.old Build _build* pm_to_blib* *.tar.gz .lwpcookies PDL-Graphics-OpenGL-Perl-OpenGL-* cover_db ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/POGL/Makefile.PL������������������������������������������������������������0000644�0601750�0601001�00000001105�12562522364�015515� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Graphics::OpenGL::Perl::OpenGL', 'VERSION_FROM' => 'OpenGL.pm', 'ABSTRACT_FROM' => 'OpenGL.pm', 'LICENSE' => 'perl', 'PL_FILES' => {}, 'PREREQ_PM' => { 'Test::More' => 0, 'OpenGL' => 0.58004, # TODO: this should be from perldl.conf value }, 'dist' => { 'COMPRESS' => 'gzip -9f', 'SUFFIX' => 'gz', }, 'clean' => { 'FILES' => 'PDL-Graphics-OpenGL-Perl-OpenGL-*' }, ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/POGL/MANIFEST���������������������������������������������������������������0000644�0601750�0601001�00000000072�12562522364�014676� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Changes MANIFEST Makefile.PL README OpenGL.pm t/00-load.t ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/POGL/OpenGL.pm��������������������������������������������������������������0000644�0601750�0601001�00000031035�13036512175�015226� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package PDL::Graphics::OpenGL::Perl::OpenGL; BEGIN { use PDL::Config; if ($PDL::Config{USE_POGL}) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw()"; use OpenGL::Config; } } BEGIN { eval 'OpenGL::ConfigureNotify()'; if ($@) { # Set up some X11 and GLX constants for fake XEvent emulation { no warnings 'redefine'; eval "sub OpenGL::GLX_DOUBLEBUFFER () { 5 }"; eval "sub OpenGL::GLX_RGBA () { 4 }"; eval "sub OpenGL::GLX_RED_SIZE () { 8 }"; eval "sub OpenGL::GLX_GREEN_SIZE () { 9 }"; eval "sub OpenGL::GLX_BLUE_SIZE () { 10 }"; eval "sub OpenGL::GLX_DEPTH_SIZE () { 12 }"; eval "sub OpenGL::KeyPressMask () { (1<<0 ) }"; eval "sub OpenGL::KeyReleaseMask () { (1<<1 ) }"; eval "sub OpenGL::ButtonPressMask () { (1<<2 ) }"; eval "sub OpenGL::ButtonReleaseMask () { (1<<3 ) }"; eval "sub OpenGL::PointerMotionMask () { (1<<6 ) }"; eval "sub OpenGL::Button1Mask () { (1<<8 ) }"; eval "sub OpenGL::Button2Mask () { (1<<9 ) }"; eval "sub OpenGL::Button3Mask () { (1<<10) }"; eval "sub OpenGL::Button4Mask () { (1<<11) }"; # scroll wheel eval "sub OpenGL::Button5Mask () { (1<<12) }"; # scroll wheel eval "sub OpenGL::ButtonMotionMask () { (1<<13) }"; eval "sub OpenGL::ExposureMask () { (1<<15) }"; eval "sub OpenGL::StructureNotifyMask { (1<<17) }"; eval "sub OpenGL::KeyPress () { 2 }"; eval "sub OpenGL::KeyRelease () { 3 }"; eval "sub OpenGL::ButtonPress () { 4 }"; eval "sub OpenGL::ButtonRelease () { 5 }"; eval "sub OpenGL::MotionNotify () { 6 }"; eval "sub OpenGL::Expose () { 12 }"; eval "sub OpenGL::GraphicsExpose () { 13 }"; eval "sub OpenGL::NoExpose () { 14 }"; eval "sub OpenGL::VisibilityNotify () { 15 }"; eval "sub OpenGL::ConfigureNotify () { 22 }"; } } } use warnings; use strict; =head1 NAME PDL::Graphics::OpenGL::Perl::OpenGL - PDL TriD OpenGL interface using POGL =head1 VERSION Version 0.01_10 =cut our $VERSION = '0.01_10'; $VERSION = eval $VERSION; =head1 SYNOPSIS This module provides the glue between the Perl OpenGL functions and the API defined by the internal PDL::Graphics::OpenGL one. It also supports any miscellaneous OpenGL or GUI related functionality to support PDL::Graphics::TriD refactoring. You should eventually be able to replace: use PDL::Graphics::OpenGL by use PDL::Graphics::OpenGL::Perl::OpenGL; This module also includes support for FreeGLUT and GLUT instead of X11+GLX as mechanism for creating windows and graphics contexts. =head1 EXPORT See the documentation for the OpenGL module. More details to follow as the refactored TriD module interface and build environment matures =head1 FUNCTIONS =head2 TBD =cut *glpOpenWindow = \&OpenGL::glpOpenWindow; *glpcOpenWindow = \&OpenGL::glpcOpenWindow; =head2 TBD =cut package PDL::Graphics::OpenGL::OO; use PDL::Graphics::TriD::Window qw(); use PDL::Options; use strict; my $debug = 0; my (@fakeXEvents) = (); my (@winObjects) = (); # # This is a list of all the fields of the opengl object # #use fields qw/Display Window Context Options GL_Vendor GL_Version GL_Renderer/; =head2 new($class,$options,[$window_type]) Returns a new OpenGL object with attributes specified in the options field, and of the 3d window type, if specified. These attributes are: =for ref x,y - the position of the upper left corner of the window (0,0) width,height - the width and height of the window in pixels (500,500) parent - the parent under which the new window should be opened (root) mask - the user interface mask (StructureNotifyMask) attributes - attributes to pass to glXChooseVisual Allowed 3d window types, case insensitive, are: =for ref glut - use Perl OpenGL bindings and GLUT windows (no Tk) x11 - use Perl OpenGL (POGL) bindings with X11 (disabled) =cut sub new { my($class_or_hash,$options,$window_type) = @_; my $isref = ref($class_or_hash); my $p; # OpenGL::glpSetDebug(1); if($isref and defined $class_or_hash->{Options}){ $p = $class_or_hash->{Options}; }else{ my $opt = new PDL::Options(default_options()); $opt->incremental(1); $opt->options($options) if(defined $options); $p = $opt->options; } # Use GLUT windows and event handling as the TriD default $window_type ||= $PDL::Config{POGL_WINDOW_TYPE}; # $window_type ||= 'x11'; # use X11 default until glut code is ready my $self; if ( $window_type =~ /x11/i ) { # X11 windows print STDERR "Creating X11 OO window\n" if $debug; $self = OpenGL::glpcOpenWindow( $p->{x},$p->{y},$p->{width},$p->{height}, $p->{parent},$p->{mask}, $p->{steal}, @{$p->{attributes}}); } else { # GLUT or FreeGLUT windows print STDERR "Creating GLUT OO window\n" if $debug; OpenGL::glutInit() unless OpenGL::done_glutInit(); # make sure glut is initialized OpenGL::glutInitWindowPosition( $p->{x}, $p->{y} ); OpenGL::glutInitWindowSize( $p->{width}, $p->{height} ); OpenGL::glutInitDisplayMode( OpenGL::GLUT_RGBA() | OpenGL::GLUT_DOUBLE() | OpenGL::GLUT_DEPTH() ); # hardwire for now if ($^O ne 'MSWin32' and not $OpenGL::Config->{DEFINE} =~ /-DHAVE_W32API/) { # skip these MODE checks on win32, they don't work if (not OpenGL::glutGet(OpenGL::GLUT_DISPLAY_MODE_POSSIBLE())) { warn "glutInitDisplayMode(GLUT_RGBA | GLUT_DOUBLE | GLUT_DEPTH | GLUT_ALPHA) not possible"; warn "...trying without GLUT_ALPHA"; # try without GLUT_ALPHA OpenGL::glutInitDisplayMode( OpenGL::GLUT_RGBA() | OpenGL::GLUT_DOUBLE() | OpenGL::GLUT_DEPTH() ); if ( not OpenGL::glutGet( OpenGL::GLUT_DISPLAY_MODE_POSSIBLE() ) ) { die "display mode not possible"; } } } my($glutwin) = OpenGL::glutCreateWindow( "GLUT TriD" ); OpenGL::glutSetWindowTitle("GLUT TriD #$glutwin"); # add GLUT window id to title $self = { 'glutwindow' => $glutwin, 'xevents' => \@fakeXEvents, 'winobjects' => \@winObjects }; OpenGL::glutReshapeFunc( \&_pdl_fake_ConfigureNotify ); OpenGL::glutCloseFunc( \&_pdl_fake_exit_handler ); OpenGL::glutKeyboardFunc( \&_pdl_fake_KeyPress ); OpenGL::glutMouseFunc( \&_pdl_fake_button_event ); OpenGL::glutMotionFunc( \&_pdl_fake_MotionNotify ); OpenGL::glutDisplayFunc( \&_pdl_display_wrapper ); OpenGL::glutSetOption(OpenGL::GLUT_ACTION_ON_WINDOW_CLOSE(), OpenGL::GLUT_ACTION_GLUTMAINLOOP_RETURNS()) if OpenGL::_have_freeglut(); OpenGL::glutMainLoopEvent(); # pump event loop so window appears } if(ref($self) ne 'HASH'){ die "Could not create OpenGL window"; } # psuedo-hash style see note above # no strict 'refs'; # my $self = bless [ \%{"$class\::FIELDS"}], $class; # $self->{Options} = $p; $self->{window_type} = $window_type; if($isref){ if(defined($class_or_hash->{Options})){ return bless $self,ref($class_or_hash); }else{ foreach(keys %$self){ $class_or_hash->{$_} = $self->{$_}; } return $class_or_hash; } } bless $self,$class_or_hash; } =head2 default GLUT callbacks These routines are set as the default GLUT callbacks for when GLUT windows are used for PDL/POGL. Their only function at the moment is to drive an fake XEvent queue to feed the existing TriD GUI controls. At some point, the X11 stuff will the deprecated and we can rewrite this more cleanly. =cut sub _pdl_display_wrapper { my ($win) = OpenGL::glutGetWindow(); if ( defined($win) and defined($winObjects[$win]) ) { $winObjects[$win]->display(); } } sub _pdl_fake_exit_handler { my ($win) = shift; print "_pdl_fake_exit_handler: clicked for window $win\n" if $debug; # Need to clean up better and exit/transition cleanly } sub _pdl_fake_ConfigureNotify { print "_pdl_fake_ConfigureNotify: got (@_)\n" if $debug; OpenGL::glutPostRedisplay(); push @fakeXEvents, [ 22, @_ ]; } sub _pdl_fake_KeyPress { print "_pdl_fake_KeyPress: got (@_)\n" if $debug; push @fakeXEvents, [ 2, chr($_[0]) ]; } { my @button_to_mask = (1<<8, 1<<9, 1<<10, 1<<11, 1<<12); my $fake_mouse_state = 16; # default have EnterWindowMask set; my $last_fake_mouse_state; sub _pdl_fake_button_event { print "_pdl_fake_button_event: got (@_)\n" if $debug; $last_fake_mouse_state = $fake_mouse_state; if ( $_[1] == 0 ) { # a press $fake_mouse_state |= $button_to_mask[$_[0]]; push @fakeXEvents, [ 4, $_[0]+1, @_[2,3], -1, -1, $last_fake_mouse_state ]; } elsif ( $_[1] == 1 ) { # a release $fake_mouse_state &= ~$button_to_mask[$_[0]]; push @fakeXEvents, [ 5, $_[0]+1 , @_[2,3], -1, -1, $last_fake_mouse_state ]; } else { die "ERROR: _pdl_fake_button_event got unexpected value!"; } } sub _pdl_fake_MotionNotify { print "_pdl_fake_MotionNotify: got (@_)\n" if $debug; push @fakeXEvents, [ 6, $fake_mouse_state, @_ ]; } } =head2 default_options default options for object oriented methods =cut sub default_options{ { 'x' => 0, 'y' => 0, 'width' => 500, 'height'=> 500, 'parent'=> 0, 'mask' => eval '&OpenGL::StructureNotifyMask', 'steal' => 0, 'attributes' => eval '[ &OpenGL::GLX_DOUBLEBUFFER, &OpenGL::GLX_RGBA ]', } } =head2 XPending() OO interface to XPending =cut sub XPending { my($self) = @_; if ( $self->{window_type} eq 'glut' ) { # monitor state of @fakeXEvents, return number on queue print STDERR "OO::XPending: have " . scalar( @{$self->{xevents}} ) . " xevents\n" if $debug > 1; scalar( @{$self->{xevents}} ); } else { OpenGL::XPending($self->{Display}); } } =head2 XResizeWindow(x,y) OO interface to XResizeWindow =cut sub XResizeWindow { my($self,$x,$y) = @_; OpenGL::glpResizeWindow($x,$y,$self->{Window},$self->{Display}); } =head2 glpXNextEvent() OO interface to glpXNextEvent =cut sub glpXNextEvent { my($self) = @_; if ( $self->{window_type} eq 'glut' ) { while ( !scalar( @{$self->{xevents}} ) ) { # If no events, we keep pumping the event loop OpenGL::glutMainLoopEvent(); } # Extract first event from fake event queue and return return @{ shift @{$self->{xevents}} }; } else { return OpenGL::glpXNextEvent($self->{Display}); } } =head2 glpRasterFont() OO interface to the glpRasterFont function =cut sub glpRasterFont{ my($this,@args) = @_; OpenGL::glpRasterFont($args[0],$args[1],$args[2],$this->{Display}); } =head2 AUTOLOAD If the function is not prototyped in OO we assume there is no explicit mention of the three identifying parameters (Display, Window, Context) and try to load the OpenGL function. =cut sub AUTOLOAD { my($self,@args) = @_; use vars qw($AUTOLOAD); my $sub = $AUTOLOAD; return if($sub =~ /DESTROY/); $sub =~ s/.*:://; $sub = "OpenGL::$sub"; if(defined $debug){ print "In AUTOLOAD: $sub at ",__FILE__," line ",__LINE__,".\n"; } no strict 'refs'; return(&{$sub}(@args)); } =head2 glXSwapBuffers OO interface to the glXSwapBuffers function =cut sub glXSwapBuffers { my($this,@args) = @_; OpenGL::glXSwapBuffers($this->{Window},$this->{Display}); # Notice win and display reversed [sic] } =head1 AUTHOR Chris Marshall, C<< <devel dot chm dot 01 at gmail.com> >> =head1 BUGS Bugs and feature requests may be submitted through the PDL sourceforge project page at L<http://sourceforge.net/tracker/?group_id=612> . =head1 SUPPORT PDL uses a mailing list support model. The Perldl mailing list is the best for questions, problems, and feature discussions with other PDL users and PDL developers. To subscribe see the page at L<http://pdl.perl.org/?page=mailing-lists> =head1 ACKNOWLEDGEMENTS TBD including PDL TriD developers and POGL developers...thanks to all. =head1 COPYRIGHT & LICENSE Copyright 2009 Chris Marshall. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; # End of PDL::Graphics::OpenGL::Perl::OpenGL ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/POGL/README�����������������������������������������������������������������0000644�0601750�0601001�00000001755�12562522364�014436� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-Graphics-OpenGL-Perl-OpenGL This module provides an alternative OpenGL API interface to the internal PDL::Graphics::OpenGL one. It curently requires that you have a recent version of the Perl OpenGL module (a.k.a. POGL) installed. INSTALLATION The current source for this module resides in the PDL source tree. To have it build, edit the perldl.conf file and set the USE_POGL option to 1. To install this module separately via CPAN, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc PDL::Graphics::OpenGL::Perl::OpenGL COPYRIGHT AND LICENCE Copyright (C) 2009 Chris Marshall This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. �������������������PDL-2.018/Graphics/TriD/POGL/t/���������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013771� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/POGL/t/00-load.t������������������������������������������������������������0000644�0601750�0601001�00000000317�12562522364�015333� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use Test::More tests => 1; BEGIN { use_ok( 'PDL::Graphics::OpenGL::Perl::OpenGL' ); } diag( "Testing PDL::Graphics::OpenGL::Perl::OpenGL $PDL::Graphics::OpenGL::Perl::OpenGL::VERSION, Perl $], $^X" ); �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/Rout/�����������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013716� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/Rout/Makefile.PL������������������������������������������������������������0000644�0601750�0601001�00000000446�12562522364�015714� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["rout.pd", qw(Rout PDL::Graphics::TriD::Rout)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS} = ['-lm']; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/Rout/rout.pd����������������������������������������������������������������0000644�0601750�0601001�00000030402�12562522364�015253� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::Graphics::TriD::Rout - Helper routines for Three-dimensional graphics =head1 DESCRIPTION This module is for miscellaneous PP-defined utility routines for the PDL::Graphics::TriD module. Currently, there are EOD pp_def( 'combcoords', GenericTypes => [F,D], DefaultFlow => 1, Pars => 'x(); y(); z(); float [o]coords(tri=3);', Code => ' $coords(tri => 0) = $x(); $coords(tri => 1) = $y(); $coords(tri => 2) = $z(); ', Doc => <<EOT =for ref Combine three coordinates into a single piddle. Combine x, y and z to a single piddle the first dimension of which is 3. This routine does dataflow automatically. =cut EOT ); # checks all neighbouring boxes. # Returns (r = |dist|+d) a*r^-2 + b*r^-1 + c*r^-0.5 pp_def( 'repulse', GenericTypes => [F,D], Pars => 'coords(nc,np); [o]vecs(nc,np); int [t]links(np);', OtherPars => ' double boxsize; int dmult; double a; double b; double c; double d; ', Code => ' double a = $COMP(a); double b = $COMP(b); double c = $COMP(c); double d = $COMP(d); int ind; int x,y,z; SV **svp; SV *sv; int npv; HV *hv = newHV(); double boxsize = $COMP(boxsize); int dmult = $COMP(dmult); loop(np) %{ int index = 0; $links() = -1; loop(nc) %{ $vecs() = 0; index *= dmult; index += (int)($coords()/boxsize); %} /* Repulse old (shame to use x,y,z...) */ for(x=-1; x<=1; x++) { for(y=-1; y<=1; y++) { for(z=-1; z<=1; z++) { int ni = index + x + dmult * y + dmult * dmult * z; svp = hv_fetch(hv, (char *)&ni, sizeof(int), 0); if(svp && *svp) { ind = SvIV(*svp) - 1; while(ind>=0) { double dist = 0; double dist2; double tmp; double func; loop(nc) %{ tmp = ($coords() - $coords(np => ind)); dist += tmp * tmp; %} dist = sqrt(1/(sqrt(dist)+d)); func = c * dist; dist2 = dist * dist; func += b * dist2; dist2 *= dist2; func += a * dist2; loop(nc) %{ tmp = ($coords() - $coords(np => ind)); $vecs() -= func * tmp; $vecs(np => ind) += func * tmp; %} ind = $links(np => ind); } } } } } /* Store new */ svp = hv_fetch(hv, (char *)&index, sizeof(int), 1); if(svp == NULL) { die("Invalid sv from hvfetch"); } sv = *svp; if((npv = SvIV(sv))) { npv --; $links() = $links(np => npv); $links(np => npv) = np; } else { sv_setiv(sv,np+1); $links() = -1; } %} hv_undef(hv); ', Doc => ' =for ref Repulsive potential for molecule-like constructs. C<repulse> uses a hash table of cubes to quickly calculate a repulsive force that vanishes at infinity for many objects. For use by the module L<PDL::Graphics::TriD::MathGraph|PDL::Graphics::TriD::MathGraph>. For definition of the potential, see the actual function. =cut ' ); pp_def( 'attract', GenericTypes => [F,D], Pars => 'coords(nc,np); int from(nl); int to(nl); strength(nl); [o]vecs(nc,np);', OtherPars => ' double m; double ms; ', Code => ' double m = $COMP(m); double ms = $COMP(ms); loop(nc,np) %{ $vecs() = 0; %} loop(nl) %{ int f = $from(); int t = $to(); double s = $strength(); double dist = 0; double tmp; loop(nc) %{ tmp = $coords(np => f) - $coords(np => t); dist += tmp * tmp; %} s *= ms * dist + m * sqrt(dist); loop(nc) %{ tmp = $coords(np => f) - $coords(np => t); $vecs(np => f) -= tmp * s; $vecs(np => t) += tmp * s; %} %} ', Doc => ' =for ref Attractive potential for molecule-like constructs. C<attract> is used to calculate an attractive force for many objects, of which some attract each other (in a way like molecular bonds). For use by the module L<PDL::Graphics::TriD::MathGraph|PDL::Graphics::TriD::MathGraph>. For definition of the potential, see the actual function. =cut ' ); sub trid { my ($par,$ind) = @_; join ',', map {"\$$par($ind => $_)"} (0..2); } pp_def('vrmlcoordsvert', Pars => 'vertices(n=3)', OtherPars => 'char* space; char* fd', GenericTypes => [F,D], Code => q@ PerlIO *fp; IO *io; PDL_Byte *buf, *bp; char *spc = $COMP(space); char formchar = $TFD(' ','l'); char formatstr[25]; io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO)); if (!io || !(fp = IoIFP(io))) barf("Can\'t figure out FP"); sprintf(formatstr,"%s%%.3%cf %%.3%cf %%.3%cf,\n",spc, formchar,formchar,formchar); threadloop %{ PerlIO_printf(fp,formatstr,@.trid(vertices,n).'); %}' ); pp_addpm(<<'EOD'); =head2 contour_segments =for ref This is the interface for the pp routine contour_segments_internal - it takes 3 piddles as input C<$c> is a contour value (or a list of contour values) C<$data> is an [m,n] array of values at each point C<$points> is a list of [3,m,n] points, it should be a grid monotonically increasing with m and n. contour_segments returns a reference to a Perl array of line segments associated with each value of C<$c>. It does not (yet) handle missing data values. =over 4 =item Algorthym The data array represents samples of some field observed on the surface described by points. For each contour value we look for intersections on the line segments joining points of the data. When an intersection is found we look to the adjoining line segments for the other end(s) of the line segment(s). So suppose we find an intersection on an x-segment. We first look down to the left y-segment, then to the right y-segment and finally across to the next x-segment. Once we find one in a box (two on a point) we can quit because there can only be one. After we are done with a given x-segment, we look to the leftover possibilities for the adjoining y-segment. Thus the contours are built as a collection of line segments rather than a set of closed polygons. =back =cut use strict; sub PDL::Graphics::TriD::Contours::contour_segments { my($this,$c,$data,$points) = @_; # pre compute space for output of pp routine my $segdim = ($data->getdim(0)-1)*($data->getdim(1)-1)*4; # print "segdim = $segdim\n"; my $segs = zeroes(3,$segdim,$c->nelem); my $cnt = zeroes($c->nelem); contour_segments_internal($c,$data,$points,$segs,$cnt); # print "contour segments done ",$points->info,"\n"; $this->{Points} = pdl->null; my $pcnt=0; my $ncnt; for(my $i=0; $i<$c->nelem; $i++){ $ncnt = $cnt->slice("($i)"); next if($ncnt==-1); $pcnt = $pcnt+$ncnt; $this->{ContourSegCnt}[$i] = $pcnt; $pcnt=$pcnt+1; $this->{Points} = $this->{Points}->append($segs->slice(":,0:$ncnt,($i)")->xchg(0,1)); } $this->{Points} = $this->{Points}->xchg(0,1); } EOD pp_def('contour_segments_internal', Pars => 'c(); data(m,n); points(d,m,n); float [o]segs(d,q); int [o] cnt();', GenericTypes => [F], Code => ' int ds, ms, ns; float dist; float a_int[3]; int i, j, m1, n1, mr, ml, p, found, p1, a; ds = $SIZE(d); ms = $SIZE(m); ns = $SIZE(n); if(ds != 3){ croak("Bad first dimension in contour_segments"); } p=0; p1=1; loop(m) %{ if(m<ms-1){ m1=m+1; loop(n)%{ if(n<ns-1){ n1=n+1; /* printf("found %d %d %d\n",found,ml,mr); */ found=0; if((a=($data() < $c() && $data(m=>m1) >= $c())) || ($data() >= $c() && $data(m=>m1) < $c())){ /* circle the high if there is a choice of direction */ if(a==0){ ml=m; mr=m1; }else{ ml=m1; mr=m; } /* found an x intersect */ dist = ($c()-$data())/($data(m=>m1)-$data()); loop(d) %{ a_int[d]=$points()+dist*($points(m=>m1)-$points()); %} /* now look for the connecting point */ /* First down and to the left (right) */ if(($data(m=>ml) < $c() && $data(m=>ml,n=>n1) >= $c()) || ($data(m=>ml) >= $c() && $data(m=>ml,n=>n1) < $c())){ found=(m==ml)? 1:-1; dist = ($c()-$data(m=>ml))/($data(m=>ml,n=>n1)-$data(m=>ml)); loop(d) %{ $segs(q=>p1)=$points(m=>ml)+dist*($points(m=>ml,n=>n1)-$points(m=>ml)); $segs(q=>p) = a_int[d]; %} p+=2; p1=p+1; /* printf("found1 %d %d %d\n",found,ml,mr); */ }else{ /* down and to the right (left)*/ if(($data(m=>mr) < $c() && $data(m=>mr,n=>n1) >= $c()) || ($data(m=>mr) >= $c() && $data(m=>mr,n=>n1) < $c())){ dist = ($c()-$data(m=>mr))/($data(m=>mr,n=>n1)-$data(m=>mr)); found=(m==mr)? 1:-1; loop(d) %{ $segs(q=>p1)=$points(m=>mr)+dist*($points(m=>mr,n=>n1)-$points(m=>mr)); $segs(q=>p) = a_int[d]; %} p+=2; p1=p+1; /* printf("found2 %d %d %d\n",found,ml,mr);*/ }else{ /* straight down */ found=2; if(($data(n=>n1) < $c() && $data(m=>m1,n=>n1) >= $c()) || ($data(n=>n1) >= $c() && $data(m=>m1,n=>n1) < $c())){ dist = ($c()-$data(n=>n1))/($data(m=>m1,n=>n1)-$data(n=>n1)); loop(d) %{ $segs(q=>p1)=$points(n=>n1)+dist*($points(m=>m1,n=>n1)-$points(n=>n1)); $segs(q=>p) = a_int[d]; %} p+=2; p1=p+1; }/* straight down */ } /* down and to the right */ } /* First down and to the left */ } /* found an x intersect */ if(found<=0){ /* need to check the y-pnt */ if(($data() < $c() && $data(n=>n1) >= $c()) || ($data() >= $c() && $data(n=>n1) < $c())){ dist = ($c()-$data())/($data(n=>n1)-$data()); loop(d) %{ a_int[d]=$points()+dist*($points(n=>n1)-$points()); %} if(($data(n=>n1) < $c() && $data(m=>m1,n=>n1) >= $c()) || ($data(n=>n1)>= $c() && $data(m=>m1,n=>n1) < $c())){ dist = ($c()-$data(n=>n1))/($data(m=>m1,n=>n1)-$data(n=>n1)); loop(d) %{ $segs(q=>p1)=$points(n=>n1)+dist*($points(m=>m1,n=>n1)-$points(n=>n1)); $segs(q=>p) = a_int[d]; %} p+=2; p1=p+1; found = (found==-1)?-3:3; }else if(found==0){ if(($data(m=>m1) < $c() && $data(m=>m1,n=>n1) >= $c()) || ($data(m=>m1) >= $c() && $data(m=>m1,n=>n1) < $c())){ dist = ($c()-$data(m=>m1))/($data(m=>m1,n=>n1)-$data(m=>m1)); loop(d) %{ $segs(q=>p1) = $points(m=>m1)+dist*($points(m=>m1,n=>n1)-$points(m=>m1)); $segs(q=>p) = a_int[d]; %} p+=2; p1=p+1; found = 4; } } } } /* need to check the y-pnt */ if(found==0 || found==1 || found == 3){ if((($data(m=>m1) < $c() && $data(m=>m1,n=>n1) >= $c()) || ($data(m=>m1) >= $c() && $data(m=>m1,n=>n1) < $c())) && (($data(n=>n1) < $c() && $data(m=>m1,n=>n1) >= $c()) || ($data(n=>n1) >= $c() && $data(m=>m1,n=>n1) < $c()))){ float dist2; dist = ($c()-$data(m=>m1))/($data(m=>m1,n=>n1)-$data(m=>m1)); dist2 = ($c()-$data(n=>n1))/($data(m=>m1,n=>n1)-$data(n=>n1)); loop(d) %{ $segs(q=>p) = $points(m=>m1)+dist*($points(m=>m1,n=>n1)-$points(m=>m1)); $segs(q=>p1)=$points(n=>n1)+dist2*($points(m=>m1,n=>n1)-$points(n=>n1)); %} found=5; p+=2; p1=p+1; } } } /* n<ns-1 */ %} } %} /*printf("p= %d \n",p); */ $cnt()=p-1;' , Doc => undef, #' #=for ref # #Internal support for contour_segments above. # #=cut #' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR Copyright (C) 2000 James P. Edwards Copyright (C) 1997 Tuomas J. Lukka. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/�����������������������������������������������������������������������0000755�0601750�0601001�00000000000�13110402046�013627� 5����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/ArcBall.pm�������������������������������������������������������������0000644�0601750�0601001�00000006144�12562522364�015512� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������################################################### # # ArcBall.pm # # From Graphics Gems IV. # # This is an example of the controller class: # the routines set_wh and mouse_moved are the standard routines. # # This needs a faster implementation (?) package PDL::Graphics::TriD::QuaterController; use base qw(PDL::Graphics::TriD::ButtonControl); use fields qw /Inv Quat/; sub new { my($type,$win,$inv,$quat) = @_; my $this = $type->SUPER::new($win); $this->{Inv} = $inv; $this->{Quat} = (defined($quat) ? $quat : new PDL::Graphics::TriD::Quaternion(1,0,0,0)); $win->add_resizecommand(sub {$this->set_wh(@_)}); return $this; } sub xy2qua { my($this,$x,$y) = @_; $x -= $this->{W}/2; $y -= $this->{H}/2; $x /= $this->{SC}; $y /= $this->{SC}; $y = -$y; return $this->normxy2qua($x,$y); } sub mouse_moved { my($this,$x0,$y0,$x1,$y1) = @_; # Copy the size of the owning viewport to our size, in case it changed... $this->{H} = $this->{Win}->{H}; $this->{W} = $this->{Win}->{W}; if($PDL::Graphics::TriD::verbose) { print "QuaterController: mouse-moved: $this: $x0,$y0,$x1,$y1,$this->{W},$this->{H},$this->{SC}\n" if($PDL::Graphics::TriD::verbose); if($PDL::Graphics::TriD::verbose > 1) { print "\tthis is:\n"; foreach my $k(sort keys %$this) { print "\t$k\t=>\t$this->{$k}\n"; } } } # Convert both to quaternions. my ($qua0,$qua1) = ($this->xy2qua($x0,$y0),$this->xy2qua($x1,$y1)); # print "ARCBALLQ: ",(join ', ',@$qua0)," ",(join ', ',@$qua1),"\n"; my $arc = $qua1->multiply($qua0->invert()); # my $arc = $qua0->invert()->multiply($qua1); if($this->{Inv}) { $arc->invert_rotation_this(); } $this->{Quat}->set($arc->multiply($this->{Quat})); # print "ARCBALLQ: ",(join ', ',@$arc)," ",(join ', ',@{$this->{Quat}}),"\n"; # $this->{Quat}->set($this->{Quat}->multiply($arc)); 1; # signals a refresh } # # Original ArcBall # package PDL::Graphics::TriD::ArcBall; use base qw/PDL::Graphics::TriD::QuaterController/; # x,y to unit quaternion on the sphere. sub normxy2qua { my($this,$x,$y) = @_; my $dist = sqrt ($x ** 2 + $y ** 2); if($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;} my $z = sqrt(1-$dist**2); return PDL::Graphics::TriD::Quaternion->new(0,$x,$y,$z); } # Tjl's version: a cone - more even change of package PDL::Graphics::TriD::ArcCone; use base qw/PDL::Graphics::TriD::QuaterController/; # x,y to unit quaternion on the sphere. sub normxy2qua { my($this,$x,$y) = @_; my $dist = sqrt ($x ** 2 + $y ** 2); if($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;} my $z = 1-$dist; my $qua = PDL::Graphics::TriD::Quaternion->new(0,$x,$y,$z); $qua->normalize_this(); return $qua; } # Tjl's version2: a bowl -- angle is proportional to displacement. package PDL::Graphics::TriD::ArcBowl; use base qw/PDL::Graphics::TriD::QuaterController/; # x,y to unit quaternion on the sphere. sub normxy2qua { my($this,$x,$y) = @_; my $dist = sqrt ($x ** 2 + $y ** 2); if($dist > 1.0) {$x /= $dist; $y /= $dist; $dist = 1.0;} my $z = cos($dist*3.142/2); my $qua = PDL::Graphics::TriD::Quaternion->new(0,$x,$y,$z); $qua->normalize_this(); return $qua; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/ButtonControl.pm�������������������������������������������������������0000644�0601750�0601001�00000004654�12776222612�017032� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl # # PDL::Graphics::TriD::ButtonControl - This package simply defines # default event handler subroutines. $Revision$ # # James P. Edwards # Instituto Nacional de Meteorologia # Brasilia, DF, Brasil # jedwards@inmet.gov.br # # This distribution is free software; you can # redistribute it and/or modify it under the same terms as Perl itself. # =head1 NAME PDL::Graphics::TriD::ButtonControl - default event handler subroutines =head1 FUNCTIONS =head2 new() =for ref Bless an oject into the class ButtonControl, expects the associated Window object to be supplied as an argument. =for usage The ButtonControl class is a base class which all TriD event controllers should inherit from. By itself it does not do much. It defines ButtonPressed and ButtonRelease functions which are expected by the Event loop. =cut package PDL::Graphics::TriD::ButtonControl; use strict; use fields qw/Win W H SC/; sub new { my ($class,$win) = @_; my $self = fields::new($class); $self->{Win} = $win; $self; } =head2 mouse_moved =for ref A do nothing function to prevent errors if not defined in a subclass =cut sub mouse_moved{ print "mouse_moved @_\n" if $PDL::Graphics::TriD::verbose; } =head2 ButtonRelease =for ref A do nothing function to prevent errors if not defined in a subclass =cut sub ButtonRelease{ my ($this,$x,$y) = @_; $this->{Win}{Active} = 0; print "ButtonRelease @_\n" if $PDL::Graphics::TriD::verbose; } =head2 ButtonPressed =for ref Activates the viewport the mouse is inside when pressed =cut sub ButtonPress{ my ($this,$x,$y) = @_; # # GL (0,0) point is Lower left X and Tk is upper left. # $y = $PDL::Graphics::TriD::cur->{Height}-$y; # print "$x $y ",$this->{Win}{X0}," ",$this->{Win}{Y0}," ",$this->{Win}{W}," ",$this->{Win}{H},"\n"; if($this->{Win}{X0} <= $x && $this->{Win}{X0}+$this->{Win}{W}>=$x && $this->{Win}{Y0} <= $y && $this->{Win}{Y0}+$this->{Win}{H}>=$y ){ $this->{Win}{Active} = 1; } print "ButtonPress @_ ",ref($this->{Win}),"\n" if $PDL::Graphics::TriD::verbose; } =head2 set_wh =for ref Define the width and Height of the window for button control =cut sub set_wh { my($this,$w,$h) = @_; print ref($this)," $w,$h\n" if $PDL::Graphics::TriD::verbose; $this->{W} = $w; $this->{H} = $h; $w = 0 unless defined $w; $h = 0 unless defined $h; if($w > $h) { $this->{SC} = $h/2; } else { $this->{SC} = $w/2; } } 1; ������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Contours.pm������������������������������������������������������������0000644�0601750�0601001�00000020401�13036512175�016012� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Graphics::TriD::Contours - 3D Surface contours for TriD =head1 SYNOPSIS =for usage # A simple contour plot in black and white use PDL::Graphics::TriD; use PDL::Graphics::TriD::Contours; $size = 25; $x = (xvals zeroes $size,$size) / $size; $y = (yvals zeroes $size,$size) / $size; $z = (sin($x*6.3) * sin($y*6.3)) ** 3; $data=new PDL::Graphics::TriD::Contours($z, [$z->xvals/$size,$z->yvals/$size,0]); PDL::Graphics::TriD::graph_object($data) =cut package PDL::Graphics::TriD::Contours; use strict; use PDL; use PDL::Graphics::TriD; use PDL::Graphics::TriD::Rout; use PDL::Graphics::TriD::Labels; #use Data::Dumper; use base qw/PDL::Graphics::TriD::GObject/; use fields qw/ContourSegCnt Labels LabelStrings/; =head1 FUNCTIONS =head2 new() =for ref Define a new contour plot for TriD. =for example $data=new PDL::Graphics::TriD::Contours($d,[$x,$y,$z],[$r,$g,$b],$options); where $d is a 2D pdl of data to be contoured. [$x,$y,$z] define a 3D map of $d into the visualization space [$r,$g,$b] is an optional [3,1] piddle specifying the contour color and $options is a hash reference to a list of options documented below. Contours can also be colored by value using the set_color_table function. =for opt ContourInt => 0.7 # explicitly set a contour interval ContourMin => 0.0 # explicitly set a contour minimum ContourMax => 10.0 # explicitly set a contour maximum ContourVals => $pdl # explicitly set all contour values Label => [1,5,$myfont] # see addlabels below Font => $font # explicitly set the font for contour labels If ContourVals is specified ContourInt, ContourMin, and ContourMax are ignored. If no options are specified, the algorthym tries to choose values based on the data supplied. Font can also be specified or overwritten by the addlabels() function below. =cut sub new{ my($type,$data,$points,$colors,$options) = @_; if(! defined $points){ $points = [$data->xvals,$data->yvals,$data->zvals]; } if(ref($colors) eq "HASH"){ $options=$colors ; undef $colors; } $colors = PDL::Graphics::TriD::realcoords("COLOR",pdl[1,1,1]) unless defined $colors; my $this = $type->SUPER::new($points,$colors,$options); my $grid = $this->{Points}; $this->{ContourSegCnt} = []; my @lines; my($xmin,$dx,$ymin,$dy); my @dims = $data->dims(); my $d0 = $dims[0]-1; my $d1 = $dims[1]-1; my ($min,$max) = $data->minmax(); my $fac=1; unless(defined $this->{Options}{ContourMin}){ while($fac*($max-$min)<10){ $fac*=10; } if(int($fac*$min) == $fac*$min){ $this->{Options}{ContourMin} = $min; }else{ $this->{Options}{ContourMin} = int($fac*$min+1)/$fac; print "ContourMin = ",$this->{Options}{ContourMin},"\n" if($PDL::Graphics::TriD::verbose); } } unless(defined $this->{Options}{ContourMax} && $this->{Options}{ContourMax} > $this->{Options}{ContourMin} ){ if(defined $this->{Options}{ContourInt}){ $this->{Options}{ContourMax} = $this->{Options}{ContourMin}; while($this->{Options}{ContourMax}+$this->{Options}{ContourInt} < $max){ $this->{Options}{ContourMax}= $this->{Options}{ContourMax}+$this->{Options}{ContourInt}; } }else{ if(int($fac*$max) == $fac*$max){ $this->{Options}{ContourMax} = $max; }else{ $this->{Options}{ContourMax} = (int($fac*$max)-1)/$fac; print "ContourMax = ",$this->{Options}{ContourMax},"\n" if($PDL::Graphics::TriD::verbose); } } } unless(defined $this->{Options}{ContourInt} && $this->{Options}{ContourInt}>0){ $this->{Options}{ContourInt} = int($fac*($this->{Options}{ContourMax}-$this->{Options}{ContourMin}))/(10*$fac); print "ContourInt = ",$this->{Options}{ContourInt},"\n" if($PDL::Graphics::TriD::verbose); } # # The user could also name cvals # my $cvals; if( !defined($this->{Options}{ContourVals}) || $this->{Options}{ContourVals}->isempty){ $cvals=zeroes(int(($this->{Options}{ContourMax}-$this->{Options}{ContourMin})/$this->{Options}{ContourInt}+1)); $cvals = $cvals->xlinvals($this->{Options}{ContourMin},$this->{Options}{ContourMax}); }else{ $cvals = $this->{Options}{ContourVals}; $this->{Options}{ContourMax}=$cvals->max; $this->{Options}{ContourMin}=$cvals->min; } $this->{Options}{ContourVals} = $cvals; print "Cvals = $cvals\n" if($PDL::Graphics::TriD::verbose); $this->contour_segments($cvals,$data,$grid); $this->addlabels($this->{Options}{Labels}) if(defined $this->{Options}{Labels}); return $this; } sub get_valid_options{ return{ ContourInt => undef, ContourMin => undef, ContourMax=> undef, ContourVals=> pdl->null, UseDefcols=>1, Labels=> undef, Font=>$PDL::Graphics::TriD::GL::fontbase} } =head2 addlabels() =for ref Add labels to a contour plot =for usage $contour->addlabels($labelint,$segint,$font); $labelint is the integer interval between labeled contours. If you have 8 contour levels and specify $labelint=3 addlabels will attempt to label the 1st, 4th, and 7th contours. $labelint defaults to 1. $segint specifies the density of labels on a single contour level. Each contour level consists of a number of connected line segments, $segint defines how many of these segments get labels. $segint defaults to 5, that is every fifth line segment will be labeled. =cut sub addlabels{ my ($self,$labelint, $segint ,$font) = @_; $labelint = 1 unless(defined $labelint); $font = $self->{Options}{Font} unless(defined $font); $segint = 5 unless(defined $segint); my $cnt=0; my $strlist; my $lp=pdl->null; my $pcnt = 0; my $cnt; my $offset = pdl[0.5,0.5,0.5]; for(my $i=0; $i<= $#{$self->{ContourSegCnt}}; $i++){ next unless defined $self->{ContourSegCnt}[$i]; $cnt = $self->{ContourSegCnt}[$i]; my $val = $self->{Options}{ContourVals}->slice("($i)"); my $leg = $self->{Points}->slice(":,$pcnt:$cnt"); $pcnt=$cnt+1; next if($i % $labelint); for(my $j=0; $j< $leg->getdim(1); $j+=2){ next if(($j/2) % $segint); my $j1=$j+1; my $lp2 = $leg->slice(":,($j)") + $offset*($leg->slice(":,($j1)") - $leg->slice(":,($j)")); $lp = $lp->append($lp2); # need a label string for each point push(@$strlist,$val); } } if($lp->nelem>0){ $self->{Points} = $self->{Points}->xchg(0,1) ->append($lp->reshape(3,$lp->nelem/3)->xchg(0,1))->xchg(0,1); $self->{Labels} = [$cnt+1,$cnt+$lp->nelem/3]; $self->{LabelStrings} = $strlist; $self->{Options}{Font}=$font; } } =head2 set_colortable($table) =for ref Sets contour level colors based on the color table. =for usage $table is passed in as either a piddle of [3,n] colors, where n is the number of contour levels, or as a reference to a function which expects the number of contour levels as an argument and returns a [3,n] piddle. It should be straight forward to use the L<PDL::Graphics::LUT> tables in a function which subsets the 256 colors supplied by the look up table into the number of colors needed by Contours. =cut sub set_colortable{ my($self,$table) = @_; my $colors; if(ref($table) eq "CODE"){ my $min = $self->{Options}{ContourMin}; my $max = $self->{Options}{ContourMax}; my $int = $self->{Options}{ContourInt}; my $ncolors=($max-$min)/$int+1; $colors= &$table($ncolors); }else{ $colors = $table; } if($colors->getdim(0)!=3){ $colors->reshape(3,$colors->nelem/3); } print "Color info ",$self->{Colors}->info," ",$colors->info,"\n" if($PDL::Graphics::TriD::verbose); $self->{Colors} = $colors; } =head2 coldhot_colortable() =for ref A simple colortable function for use with the set_colortable function. =for usage coldhot_colortable defines a blue red spectrum of colors where the smallest contour value is blue, the highest is red and the others are shades in between. =cut sub coldhot_colortable{ my($ncolors) = @_; my $colorpdl; # 0 red, 1 green, 2 blue for(my $i=0;$i<$ncolors;$i++){ my $color = zeroes(float,3); (my $t = $color->slice("0")) .= 0.75*($i)/$ncolors; ($t = $color->slice("2")) .= 0.75*($ncolors-$i)/$ncolors; if($i==0){ $colorpdl = $color; }else{ $colorpdl = $colorpdl->append($color); } } return($colorpdl); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Control3D.pm�����������������������������������������������������������0000644�0601750�0601001�00000003261�12562522364�016016� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package PDL::Graphics::TriD::Control3D; # Mustn't have empty package in some perl versions. ############################################## # # A quaternion-based controller framework with the following transformations: # 1. world "origin". This is what the world revolves around # 2. world "rotation" at origin. # 3. camera "distance" along z axis after that (camera looks # at negative z axis). # 4. camera "rotation" after that (not always usable). package PDL::Graphics::TriD::SimpleController; use strict; use fields qw/WOrigin WRotation CDistance CRotation/; sub new{ my ($class) = @_; my $self = fields::new($class); $self->reset(); $self; } sub normalize { my($this) = @_; $this->{WRotation}->normalize_this(); $this->{CRotation}->normalize_this(); } sub reset { my($this) = @_; $this->{WOrigin} = [0,0,0]; $this->{WRotation} = PDL::Graphics::TriD::Quaternion->new(1,0,0,0); # $this->{WRotation} = PDL::Graphics::TriD::Quaternion->new( # 0.847, -0.458, -0.161, -0.216); # $this->{WRotation} = PDL::Graphics::TriD::Quaternion->new( # 0.347, -0.458, -0.161, -0.216); $this->{CDistance} = 5; $this->{CRotation} = PDL::Graphics::TriD::Quaternion->new(1,0,0,0); } sub set { my($this,$options) = @_; foreach my $what (keys %$options){ if($what =~ /Rotation/){ $this->{$what}[0] = $options->{$what}[0]; $this->{$what}[1] = $options->{$what}[1]; $this->{$what}[2] = $options->{$what}[2]; $this->{$what}[3] = $options->{$what}[3]; }elsif($what eq 'WOrigin'){ $this->{$what}[0] = $options->{$what}[0]; $this->{$what}[1] = $options->{$what}[1]; $this->{$what}[2] = $options->{$what}[2]; }else{ $this->{$what} = $options->{$what}; } } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/GL.pm������������������������������������������������������������������0000644�0601750�0601001�00000074612�12774027732�014525� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # # ToDo: # - multiple windows - requires editing generate.pl in OpenGL/ # - clean up # #package PDL::Graphics::TriD::GL; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } $PDL::Graphics::TriD::create_window_sub = sub { return new PDL::Graphics::TriD::GL::Window(@_); }; sub PDL::Graphics::TriD::Material::togl{ my $this = shift; my $shin = pack "f*",$this->{Shine}; glMaterialfv(GL_FRONT_AND_BACK,GL_SHININESS,$shin); my $spec = pack "f*",@{$this->{Specular}}; glMaterialfv(GL_FRONT_AND_BACK,GL_SPECULAR,$spec); my $amb = pack "f*",@{$this->{Ambient}}; glMaterialfv(GL_FRONT_AND_BACK,GL_AMBIENT,$amb); my $diff = pack "f*",@{$this->{Diffuse}}; glMaterialfv(GL_FRONT_AND_BACK,GL_DIFFUSE,$diff); } $PDL::Graphics::TriD::any_cannots = 0; sub PDL::Graphics::TriD::Object::cannot_mklist { return 0; } sub PDL::Graphics::TriD::Object::gl_update_list { my($this) = @_; if($this->{List}) { glDeleteLists($this->{List},1); } my $lno = glGenLists(1); $this->{List} = $lno; print "GENLIST $lno\n" if($PDL::Graphics::TriD::verbose); glNewList($lno,GL_COMPILE); if ($PDL::Graphics::TriD::any_cannots) { for(@{$this->{Objects}}) { if(!$_->cannot_mklist()) { $_->togl(); } } } else { for (@{$this->{Objects}}) { $_->togl() } } print "EGENLIST $lno\n" if($PDL::Graphics::TriD::verbose); # pdltotrianglemesh($pdl, 0, 1, 0, ($pdl->{Dims}[1]-1)*$mult); glEndList(); print "VALID1 $this\n" if($PDL::Graphics::TriD::verbose); $this->{ValidList} = 1; } sub PDL::Graphics::TriD::Object::gl_call_list { my($this) = @_; print "CALLIST ",$this->{List},"!\n" if($PDL::Graphics::TriD::verbose); print "CHECKVALID $this\n" if($PDL::Graphics::TriD::verbose); if(!$this->{ValidList}) { $this->gl_update_list(); } glCallList($this->{List}); if ($PDL::Graphics::TriD::any_cannots) { for(@{$this->{Objects}}) { if($_->cannot_mklist()) { print ref($_)," cannot mklist\n"; $_->togl(); } } } } sub PDL::Graphics::TriD::Object::delete_displist { my($this) = @_; if($this->{List}) { glDeleteLists($this->{List},1); undef $this->{List}; } } sub PDL::Graphics::TriD::Object::togl { my($this) = @_; for(@{$this->{Objects}}) { $_->togl() } } sub PDL::Graphics::TriD::BoundingBox::togl { my($this) = @_; $this = $this->{Box}; glDisable(GL_LIGHTING); glColor3d(1,1,1); glBegin(GL_LINES); for([0,4,2],[0,1,2],[0,1,5],[0,4,5],[0,4,2],[3,4,2], [3,1,2],[3,1,5],[3,4,5],[3,4,2]) { &glVertex3d(@{$this}[@$_]); } glEnd(); glBegin(GL_LINE_STRIP); for([0,1,2],[3,1,2],[0,1,5],[3,1,5],[0,4,5],[3,4,5]) { &glVertex3d(@{$this}[@$_]); } glEnd(); glEnable(GL_LIGHTING); } sub PDL::Graphics::TriD::Graph::togl { my($this) = @_; # print "TOGL Axis\n"; for(keys %{$this->{Axis}}) { if($_ eq "Default") {next} $this->{Axis}{$_}->togl_axis($this); } # print "TOGL DATA\n"; for(keys %{$this->{Data}}) { # print "TOGL $_, $this->{Data}{$_} $this->{Data}{$_}{Options}{LineWidth}\n"; $this->{Data}{$_}->togl_graph($this,$this->get_points($_)); } } use PDL; sub PDL::Graphics::TriD::CylindricalEquidistantAxes::togl_axis { my($this,$graph) = @_; my $fontbase = $PDL::Graphics::TriD::GL::fontbase; my (@nadd,@nc,@ns); for $dim (0..1) { my $width = $this->{Scale}[$dim][1]-$this->{Scale}[$dim][0]; if($width > 100){ $nadd[$dim] = 10; }elsif($width>30){ $nadd[$dim] = 5; }elsif($width>20){ $nadd[$dim] = 2; }else{ $nadd[$dim] = 1; } $nc[$dim] = int($this->{Scale}[$dim][0]/$nadd[$dim])*$nadd[$dim]; $ns[$dim] = int($width/$nadd[$dim])+1; } # can be changed to topo heights? my $verts = zeroes(3,$ns[0],$ns[1]); ($t = $verts->slice("2")) .= 1012.5; ($t = $verts->slice("0")) .= $verts->ylinvals($nc[0],$nc[0]+$nadd[0]*($ns[0]-1)); ($t = $verts->slice("1")) .= $verts->zlinvals($nc[1],$nc[1]+$nadd[1]*($ns[1]-1)); my $tverts = zeroes(3,$ns[0],$ns[1]); $tverts = $this->transform($tverts,$verts,[0,1,2]); glDisable(GL_LIGHTING); glColor3d(1,1,1); for(my $j=0;$j<$tverts->getdim(2)-1;$j++){ my $j1=$j+1; glBegin(GL_LINES); for(my $i=0;$i<$tverts->getdim(1)-1;$i++){ my $i1=$i+1; glVertex2f($tverts->at(0,$i,$j),$tverts->at(1,$i,$j)); glVertex2f($tverts->at(0,$i1,$j),$tverts->at(1,$i1,$j)); glVertex2f($tverts->at(0,$i1,$j),$tverts->at(1,$i1,$j)); glVertex2f($tverts->at(0,$i1,$j1),$tverts->at(1,$i1,$j1)); glVertex2f($tverts->at(0,$i1,$j1),$tverts->at(1,$i1,$j1)); glVertex2f($tverts->at(0,$i,$j1),$tverts->at(1,$i,$j1)); glVertex2f($tverts->at(0,$i,$j1),$tverts->at(1,$i,$j1)); glVertex2f($tverts->at(0,$i,$j),$tverts->at(1,$i,$j)); } glEnd(); } glEnable(GL_LIGHTING); } sub PDL::Graphics::TriD::EuclidAxes::togl_axis { my($this,$graph) = @_; print "togl_axis: got object type " . ref($this) . "\n" if $PDL::debug_trid; # print "TOGLAX\n"; my $fontbase = $PDL::Graphics::TriD::GL::fontbase; # print "TOGL EUCLID\n"; glLineWidth(1); # ought to be user defined glDisable(GL_LIGHTING); glColor3d(1,1,1); glBegin(GL_LINES); my $dim; for $dim (0..2) { glVertex3f(0,0,0); &glVertex3f(map {$_==$dim} 0..2); } glEnd(); for $dim (0..2) { my @coords = (0,0,0); my @coords0 = (0,0,0); for(0..2) {if($dim != $_) { $coords[$_] -= 0.1; } } my $s = $this->{Scale}[$dim]; my $ndiv = 3; my $radd = 1.0/$ndiv; my $nadd = ($s->[1]-$s->[0])/$ndiv; my $nc = $s->[0]; for(0..$ndiv) { &glRasterPos3f(@coords); if ( $PDL::Config{USE_POGL} ) { if ( OpenGL::done_glutInit() ) { OpenGL::glutBitmapString($fontbase, sprintf("%.3f",$nc)); } else { OpenGL::glpPrintString($fontbase, sprintf("%.3f",$nc)); } } else { PDL::Graphics::OpenGL::glpPrintString($fontbase, sprintf("%.3f",$nc)); } glBegin(GL_LINES); &glVertex3f(@coords0); &glVertex3f(@coords); glEnd(); # print "PUT: $nc\n"; $coords[$dim] += $radd; $coords0[$dim] += $radd; $nc += $nadd; } $coords0[$dim] = 1.1; &glRasterPos3f(@coords0); if ( $PDL::Config{USE_POGL} ) { if ( OpenGL::done_glutInit() ) { OpenGL::glutBitmapString($fontbase, $this->{Names}[$dim]); } else { OpenGL::glpPrintString($fontbase, $this->{Names}[$dim]); } } else { PDL::Graphics::OpenGL::glpPrintString($fontbase, $this->{Names}[$dim]); } } glEnable(GL_LIGHTING); } use POSIX qw//; sub PDL::Graphics::TriD::Quaternion::togl { my($this) = @_; if(abs($this->[0]) == 1) { return ; } if(abs($this->[0]) >= 1) { # die "Unnormalized Quaternion!\n"; $this->normalize_this(); } &glRotatef(2*POSIX::acos($this->[0])/3.14*180, @{$this}[1..3]); } ################################## # Graph Objects # # sub PDL::Graphics::TriD::GObject::togl { $_[0]->gdraw($_[0]->{Points}); } # (this,graphs,points) sub PDL::Graphics::TriD::GObject::togl_graph { # print "TOGLGRAPH: $_[0]\n"; $_[0]->gdraw($_[2]); } sub PDL::Graphics::TriD::Points::gdraw { my($this,$points) = @_; # print "DRAWPOINTS: \n",$points; $this->glOptions(); glDisable(GL_LIGHTING); PDL::gl_points($points,$this->{Colors}); glEnable(GL_LIGHTING); } sub PDL::gl_spheres { my ($coords,$colors) = @_; for (my $np=0; $np<$coords->dim(1); $np++) { glPushMatrix(); my ($x,$y,$z) = ($coords->slice(":,($np)"))->float->list; glTranslatef($x,$y,$z); glutSolidSphere(0.025,15,15); glPopMatrix(); } } sub PDL::Graphics::TriD::Spheres::gdraw { my($this,$points) = @_; $this->glOptions(); glShadeModel(GL_SMOOTH); PDL::gl_spheres($points,$this->{Colors}); } sub PDL::Graphics::TriD::Lattice::gdraw { my($this,$points) = @_; $this->glOptions(); glDisable(GL_LIGHTING); PDL::gl_line_strip($points,$this->{Colors}); PDL::gl_line_strip($points->xchg(1,2),$this->{Colors}->xchg(1,2)); glEnable(GL_LIGHTING); } sub PDL::Graphics::TriD::LineStrip::gdraw { my($this,$points) = @_; $this->glOptions(); glDisable(GL_LIGHTING); PDL::gl_line_strip($points,$this->{Colors}); glEnable(GL_LIGHTING); } sub PDL::Graphics::TriD::Lines::gdraw { my($this,$points) = @_; $this->glOptions(); glDisable(GL_LIGHTING); PDL::gl_lines($points,$this->{Colors}); glEnable(GL_LIGHTING); } sub PDL::Graphics::TriD::GObject::glOptions { my ($this) = @_; if($this->{Options}{LineWidth}){ glLineWidth($this->{Options}{LineWidth}); }else{ glLineWidth(1); } if($this->{Options}{PointSize}){ glPointSize($this->{Options}{PointSize}); }else{ glPointSize(1); } } sub PDL::Graphics::TriD::Contours::gdraw { my($this,$points) = @_; $this->glOptions(); glDisable(GL_LIGHTING); my $pcnt=0; my $i=0; foreach(@{$this->{ContourSegCnt}}){ my $colors; if($this->{Colors}->getndims==2){ $colors = $this->{Colors}->slice(":,($i)"); }else{ $colors = $this->{Colors}; } next unless(defined $_); PDL::gl_lines($points->slice(":,$pcnt:$_"),$colors); $i++; $pcnt=$_+1; } if(defined $this->{Labels}){ glColor3d(1,1,1); my $seg = sprintf(":,%d:%d",$this->{Labels}[0],$this->{Labels}[1]); PDL::Graphics::OpenGLQ::gl_texts($points->slice($seg), $this->{Options}{Font} ,$this->{LabelStrings}); } glEnable(GL_LIGHTING); } sub PDL::Graphics::TriD::SLattice::gdraw { my($this,$points) = @_; $this->glOptions(); glPushAttrib(GL_LIGHTING_BIT | GL_ENABLE_BIT); glDisable(GL_LIGHTING); # By-vertex doesn't make sense otherwise. glShadeModel (GL_SMOOTH); my @sls1 = (":,0:-2,0:-2", ":,1:-1,0:-2", ":,0:-2,1:-1"); my @sls2 = (":,1:-1,1:-1", ":,0:-2,1:-1", ":,1:-1,0:-2" ); PDL::gl_triangles( (map {$points->slice($_)} @sls1), (map {$this->{Colors}->slice($_)} @sls1) ); PDL::gl_triangles( (map {$points->slice($_)} @sls2), (map {$this->{Colors}->slice($_)} @sls2) ); if ($this->{Options}{Lines}) { my $black = PDL->pdl(0,0,0)->dummy(1)->dummy(1); PDL::gl_line_strip($points,$black); PDL::gl_line_strip($points->xchg(1,2),$black); } glPopAttrib(); } sub PDL::Graphics::TriD::SCLattice::gdraw { my($this,$points) = @_; $this->glOptions(); glPushAttrib(GL_LIGHTING_BIT | GL_ENABLE_BIT); glDisable(GL_LIGHTING); # By-vertex doesn't make sense otherwise. glShadeModel (GL_FLAT); my @sls1 = (":,0:-2,0:-2", ":,1:-1,0:-2", ":,0:-2,1:-1"); my @sls2 = (":,1:-1,1:-1", ":,0:-2,1:-1", ":,1:-1,0:-2" ); PDL::gl_triangles( (map {$points->slice($_)} @sls1), (map {$this->{Colors}} @sls1) ); PDL::gl_triangles( (map {$points->slice($_)} @sls2), (map {$this->{Colors}} @sls2) ); if ($this->{Options}{Lines}) { my $black = PDL->pdl(0,0,0)->dummy(1)->dummy(1); PDL::gl_line_strip($points,$black); PDL::gl_line_strip($points->xchg(1,2),$black); } glPopAttrib(); } sub PDL::Graphics::TriD::SLattice_S::gdraw { my($this,$points) = @_; $this->glOptions(); glPushAttrib(GL_LIGHTING_BIT | GL_ENABLE_BIT); # For some reason, we need to set this here as well. glLightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_TRUE); # By-vertex doesn't make sense otherwise. glShadeModel (GL_SMOOTH); my @sls1 = (":,0:-2,0:-2", ":,1:-1,0:-2", ":,0:-2,1:-1"); my @sls2 = (":,1:-1,1:-1", ":,0:-2,1:-1", ":,1:-1,0:-2" ); if ($this->{Options}{Smooth}) { $this->{Normals} = $this->smoothn($points) unless defined($this->{Normals}); my $n = $this->{Normals}; my $f = (!$this->{Options}{Material} ? \&PDL::gl_triangles_wn : \&PDL::gl_triangles_wn_mat); &$f( (map {$points->slice($_)} @sls1), (map {$n->slice($_)} @sls1), (map {$this->{Colors}->slice($_)} @sls1) ); &$f( (map {$points->slice($_)} @sls2), (map {$n->slice($_)} @sls2), (map {$this->{Colors}->slice($_)} @sls2) ); } else { my $f = (!$this->{Options}{Material} ? \&PDL::gl_triangles_n : \&PDL::gl_triangles_n_mat); &$f( (map {$points->slice($_)} @sls1), (map {$this->{Colors}->slice($_)} @sls1) ); &$f( (map {$points->slice($_)} @sls2), (map {$this->{Colors}->slice($_)} @sls2) ); } glDisable(GL_LIGHTING); if ($this->{Options}{Lines}) { my $black = PDL->pdl(0,0,0)->dummy(1)->dummy(1); PDL::gl_line_strip($points,$black); PDL::gl_line_strip($points->xchg(1,2),$black); } glPopAttrib(); } #################################################################### ################### JNK 15mar11 added section start ################ sub PDL::Graphics::TriD::STrigrid_S::gdraw { my($this,$points) = @_; glPushAttrib(GL_LIGHTING_BIT | GL_ENABLE_BIT); # For some reason, we need to set this here as well. glLightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_TRUE); # By-vertex doesn't make sense otherwise. glShadeModel (GL_SMOOTH); my @sls = (":,(0)",":,(1)",":,(2)"); my $idx = [0,1,2,0]; # for lines, below if ($this->{Options}{Smooth}) { $this->{Normals}=$this->smoothn($this->{Points}) unless defined($this->{Normals}); my $f=(!$this->{Options}{Material}?\&PDL::gl_triangles_wn :\&PDL::gl_triangles_wn_mat); my $tmpn=$this->{Normals}->dice_axis(1,$this->{Faceidx}->clump(-1)) ->splitdim(1,($this->{Faceidx}->dims)[0]); my @args=((map {$this->{Faces}->slice($_)} @sls), # faces is a slice of points (map {$tmpn->slice($_)} @sls), (map {$this->{Colors}->slice($_)} @sls) );&$f(@args); } else { my $f=(!$this->{Options}{Material}?\&PDL::gl_triangles_n :\&PDL::gl_triangles_n_mat); &$f( (map {$this->{Faces}->slice($_)} @sls), # faces is a slice of points (map {$this->{Colors}->slice($_)} @sls) ); } glDisable(GL_LIGHTING); if ($this->{Options}{Lines}) { my $black = PDL->pdl(0,0,0)->dummy(1)->dummy(1); PDL::gl_lines($this->{Faces}->dice_axis(1,$idx),$black); } glPopAttrib(); } sub PDL::Graphics::TriD::STrigrid::gdraw { my($this,$points) = @_; glPushAttrib(GL_LIGHTING_BIT | GL_ENABLE_BIT); glDisable(GL_LIGHTING); # By-vertex doesn't make sense otherwise. glShadeModel (GL_SMOOTH); my @sls = (":,(0)",":,(1)",":,(2)"); my $idx = [0,1,2,0]; PDL::gl_triangles( (map {$this->{Faces}->slice($_)} @sls), # faces is a slice of points (map {$this->{Colors}->slice($_)} @sls)); if ($this->{Options}{Lines}) { my $black = PDL->pdl(0,0,0)->dummy(1)->dummy(1); PDL::gl_lines($this->{Faces}->dice_axis(1,$idx),$black); } glPopAttrib(); } ################### JNK 15mar11 added section finis ################ #################################################################### ################################## # PDL::Graphics::TriD::Image # # sub PDL::Graphics::TriD::Image::togl { # glDisable(GL_LIGHTING); # # A special construct which always faces the display and takes the entire window # glMatrixMode(GL_MODELVIEW); glLoadIdentity(); glMatrixMode(GL_PROJECTION); glLoadIdentity(); gluOrtho2D(0,1,0,1); &PDL::Graphics::TriD::Image::togl_graph; } sub PDL::Graphics::TriD::Image::togl_graph { $_[0]->gdraw(); } # The quick method is to use texturing for the good effect. sub PDL::Graphics::TriD::Image::gdraw { my($this,$vert) = @_; my ($p,$xd,$yd,$txd,$tyd) = $this->flatten(1); # do binary alignment glColor3d(1,1,1); if ( $PDL::Config{USE_POGL} ) { glTexImage2D_s(GL_TEXTURE_2D, 0, GL_RGB, $txd, $tyd, 0, GL_RGB, GL_FLOAT, $p->get_dataref()); } else { glTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, $txd, $tyd, 0, GL_RGB, GL_FLOAT, $p->get_dataref()); } glTexParameteri( GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST ); glTexParameteri( GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST ); glTexParameteri( GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT ); glTexParameteri( GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT ); glDisable(GL_LIGHTING); glNormal3d(0,0,1); glEnable(GL_TEXTURE_2D); glBegin(GL_QUADS); my @texvert = ( [0,0], [$xd/$txd, 0], [$xd/$txd, $yd/$tyd], [0, $yd/$tyd] ); if(!defined $vert) {$vert = $this->{Points}} for(0..3) { &glTexCoord2f(@{$texvert[$_]}); &glVertex3f($vert->slice(":,($_)")->list); } glEnd(); glEnable(GL_LIGHTING); glDisable(GL_TEXTURE_2D); } sub PDL::Graphics::TriD::SimpleController::togl { my($this) = @_; $this->{CRotation}->togl(); glTranslatef(0,0,-$this->{CDistance}); $this->{WRotation}->togl(); &glTranslatef(map {-$_} @{$this->{WOrigin}}); } ############################################## # # A window with mouse control over rotation. # # package PDL::Graphics::TriD::Window; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use base qw/PDL::Graphics::TriD::Object/; use fields qw/Ev Width Height Interactive _GLObject _ViewPorts _CurrentViewPort /; sub i_keep_list {return 1} # For Object, so I will be notified of changes. use strict; sub gdriver { my($this, $options) = @_; print "GL gdriver...\n" if($PDL::debug_trid); if(defined $this->{_GLObject}){ print "WARNING: Graphics Driver already defined for this window \n"; return; } my @db = GLX_DOUBLEBUFFER; if($PDL::Graphics::TriD::offline) {$options->{x} = -1; @db=()} $options->{attributes} = [GLX_RGBA, @db, GLX_RED_SIZE,1, GLX_GREEN_SIZE,1, GLX_BLUE_SIZE,1, GLX_DEPTH_SIZE,1, # Alpha size? ] unless defined $options->{attributes}; $options->{mask} = (KeyPressMask | ButtonPressMask | ButtonMotionMask | ButtonReleaseMask | ExposureMask | StructureNotifyMask | PointerMotionMask) unless defined $options->{mask}; print "STARTING OPENGL $options->{width} $options->{height}\n" if($PDL::Graphics::TriD::verbose); print "gdriver: Calling OpengGL::OO($options)...\n" if ($PDL::debug_trid); $this->{_GLObject}= new PDL::Graphics::OpenGL::OO($options); if (exists $this->{_GLObject}->{glutwindow}) { if ($PDL::debug_trid) { print "gdriver: Got OpenGL::OO object(GLUT window ID# " . $this->{_GLObject}->{glutwindow} . ")\n"; } $this->{_GLObject}->{winobjects}->[$this->{_GLObject}->{glutwindow}] = $this; # circular ref } #glpOpenWindow(%$options); print "gdriver: Calling glClearColor...\n" if ($PDL::debug_trid); glClearColor(0,0,0,1); print "gdriver: Calling glpRasterFont...\n" if ($PDL::debug_trid); if ( $this->{_GLObject}->{window_type} eq 'glut' ) { print STDERR "gdriver: window_type => 'glut' so not actually setting the rasterfont\n" if ($PDL::debug_trid); eval '$PDL::Graphics::TriD::GL::fontbase = GLUT_BITMAP_8_BY_13'; } else { # NOTE: glpRasterFont() will die() if the requested font cannot be found # The new POGL+GLUT TriD implementation uses the builtin GLUT defined # fonts and does not have this failure mode. my $lb = eval { $this->{_GLObject}->glpRasterFont( ($ENV{PDL_3D_FONT} or "5x8"), 0, 256 ) }; if ( $@ ) { die "glpRasterFont: unable to load font '%s', please set PDL_3D_FONT to an existing X11 font."; } $PDL::Graphics::TriD::GL::fontbase = $lb } # glDisable(GL_DITHER); glShadeModel (GL_FLAT); glEnable(GL_DEPTH_TEST); glEnable(GL_NORMALIZE); glEnable(GL_LIGHTING); glEnable(GL_LIGHT0); glLightModeli(GL_LIGHT_MODEL_TWO_SIDE, GL_TRUE); # Will this bring us trouble? # if(defined *PDL::Graphics::TriD::GL::Window::glPolygonOffsetEXT{CODE}) { # glEnable(GL_POLYGON_OFFSET_EXT); # glPolygonOffsetEXT(0.0000000000001,0.000002); # } # Inherits attributes of Object class # my $this = $type->SUPER::new(); # $this->reshape($options->{width},$options->{height}); my $light = pack "f*",1.0,1.0,1.0,0.0; if ( $PDL::Config{USE_POGL} ) { glLightfv_s(GL_LIGHT0,GL_POSITION,$light); } else { glLightfv(GL_LIGHT0,GL_POSITION,$light); } glColor3f(1,1,1); # $this->{Interactive} = 1; print "STARTED OPENGL!\n" if($PDL::Graphics::TriD::verbose); if($PDL::Graphics::TriD::offline) { $this->doconfig($options->{width}, $options->{height}); } return 1; # Interactive Window } sub ev_defaults{ return { ConfigureNotify => \&doconfig, MotionNotify => \&domotion, } } sub reshape { my($this,$x,$y) = @_; my $pw = $this->{Width}; my $ph = $this->{Height}; $this->{Width} = $x; $this->{Height} = $y; for my $vp (@{$this->{_ViewPorts}}){ my $nw = $vp->{W} + ($x-$pw) * $vp->{W}/$pw; my $nx0 = $vp->{X0} + ($x-$pw) * $vp->{X0}/$pw; my $nh = $vp->{H} + ($y-$ph) * $vp->{H}/$ph; my $ny0 = $vp->{Y0} + ($y-$ph) * $vp->{Y0}/$ph; print "reshape: resizing viewport to $nx0,$ny0,$nw,$nh\n" if($PDL::Graphics::TriD::verbose); $vp->resize($nx0,$ny0,$nw,$nh); } } sub get_size { my $this=shift; return ($this->{Width},$this->{Height}); } sub twiddle { my($this,$getout,$dontshow) = @_; my (@e); my $quit; if($PDL::Graphics::TriD::offline) { $PDL::Graphics::TriD::offlineindex ++; $this->display(); require PDL::IO::Pic; wpic($this->read_picture(),"PDL_$PDL::Graphics::TriD::offlineindex.jpg"); return; } if ($getout and $dontshow) { if ( !$this->{_GLObject}->XPending() ) { return; } } if(!defined $getout) { $getout = not $PDL::Graphics::TriD::keeptwiddling; } $this->display(); TWIDLOOP: while(1) { print "EVENT!\n" if($PDL::Graphics::TriD::verbose); my $hap = 0; my $gotev = 0; # Run a MainLoop event if GLUT windows # this pumps the system allowing callbacks to populate # the fake XEvent queue. # glutMainLoopEvent() if $this->{_GLObject}->{window_type} eq 'glut' and not $this->{_GLObject}->XPending(); if ($this->{_GLObject}->XPending() or !$getout) { @e = $this->{_GLObject}->glpXNextEvent(); $gotev=1; } print "e= ".join(",",@e)."\n" if($PDL::Graphics::TriD::verbose); if(@e){ if ($e[0] == VisibilityNotify || $e[0] == Expose) { $hap = 1; } elsif ($e[0] == ConfigureNotify) { print "CONFIGNOTIFE\n" if($PDL::Graphics::TriD::verbose); $this->reshape($e[1],$e[2]); $hap=1; } elsif($e[0] == KeyPress) { print "KEYPRESS: '$e[1]'\n" if($PDL::Graphics::TriD::verbose); if((lc $e[1]) eq "q") { $quit = 1; } if((lc $e[1]) eq "c") { $quit = 2; } if((lc $e[1]) eq "q" and not $getout) { last TWIDLOOP; } $hap=1; } } if($gotev){ # print "HANDLING $this->{EHandler}\n"; foreach my $vp (@{$this->{_ViewPorts}}) { if(defined($vp->{EHandler})) { $hap += $vp->{EHandler}->event(@e); } } } if(! $this->{_GLObject}->XPending()) { if($hap) { $this->display(); } if($getout) {last TWIDLOOP} } undef @e; } print "STOPTWIDDLE\n" if($PDL::Graphics::TriD::verbose); return $quit; } sub setlist { my($this,$list) = @_; $this->{List} = $list; } # Resize window. sub doconfig { my($this,$x,$y) = @_; $this->reshape($x,$y); print "CONFIGURENOTIFY\n" if($PDL::Graphics::TriD::verbose); } sub domotion { my($this) = @_; print "MOTIONENOTIFY\n" if($PDL::Graphics::TriD::verbose); } sub display { my($this) = @_; return unless defined($this); # set GLUT context to current window (for multiwindow support if ( $this->{_GLObject}->{window_type} eq 'glut' ) { glutSetWindow($this->{_GLObject}->{glutwindow}); } print "display: calling glClear()\n" if ($PDL::Graphics::TriD::verbose); glClear(GL_COLOR_BUFFER_BIT|GL_DEPTH_BUFFER_BIT); glMatrixMode(GL_MODELVIEW); for my $vp (@{$this->{_ViewPorts}}) { glPushMatrix(); $vp->do_perspective(); if($vp->{Transformer}) { print "display: transforming viewport!\n" if ($PDL::Graphics::TriD::verbose); $vp->{Transformer}->togl(); } glTranslatef(-1,-1,-1); glScalef(2,2,2); # double the scale in each direction ? $vp->gl_call_list(); glPopMatrix(); } if ( $PDL::Config{USE_POGL} ) { print "display: SwapBuffers() call on return\n" if ($PDL::Graphics::TriD::verbose); if ( $this->{_GLObject}->{window_type} eq 'glut' ) { # need to make method call glutSwapBuffers(); } elsif ( $this->{_GLObject}->{window_type} eq 'x11' ) { # need to make method call $this->{_GLObject}->glXSwapBuffers(); } else { print "display: got object with inconsistent _GLObject info\n"; } } else { $this->{_GLObject}->glXSwapBuffers(); } # $this->{Angle}+= 3; } # should this reallyt be in viewport? sub read_picture { my($this) = @_; my($w,$h) = @{$this}{qw/Width Height/}; my $res = PDL->zeroes(PDL::byte,3,$w,$h); glPixelStorei(GL_UNPACK_ALIGNMENT,1); glPixelStorei(GL_PACK_ALIGNMENT,1); if ( $PDL::Config{USE_POGL} ) { glReadPixels_s(0,0,$w,$h,GL_RGB,GL_UNSIGNED_BYTE,$res->get_dataref); } else { glReadPixels(0,0,$w,$h,GL_RGB,GL_UNSIGNED_BYTE,$res->get_dataref); } return $res; } ###################################################################### ###################################################################### # EVENT HANDLER MINIPACKAGE FOLLOWS! package PDL::Graphics::TriD::EventHandler; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(ConfigureNotify MotionNotify ButtonPress ButtonRelease Button1Mask Button2Mask Button3Mask)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use fields qw/X Y Buttons VP/; use strict; sub new { my $class = shift; my $vp = shift; no strict 'refs'; my $self = fields::new($class); $self->{X} = -1; $self->{Y} = -1; $self->{Buttons} = []; $self->{VP} = $vp; $self; } sub event { my($this,$type,@args) = @_; print "EH: ",ref($this)," $type (",join(",",@args),")\n" if($PDL::Graphics::TriD::verbose); my $retval; if($type == MotionNotify) { my $but = -1; SWITCH: { $but = 0, last SWITCH if ($args[0] & (Button1Mask)); $but = 1, last SWITCH if ($args[0] & (Button2Mask)); $but = 2, last SWITCH if ($args[0] & (Button3Mask)); print "No button pressed...\n" if($PDL::Graphics::TriD::verbose); goto NOBUT; } print "MOTION $but $args[0]\n" if($PDL::Graphics::TriD::verbose); if($this->{Buttons}[$but]) { if($this->{VP}->{Active}){ print "calling ".($this->{Buttons}[$but])."->mouse_moved ($this->{X},$this->{Y},$args[1],$args[2])...\n" if($PDL::Graphics::TriD::verbose); $retval = $this->{Buttons}[$but]->mouse_moved( $this->{X},$this->{Y}, $args[1],$args[2]); } } $this->{X} = $args[1]; $this->{Y} = $args[2]; NOBUT: } elsif($type == ButtonPress) { my $but = $args[0]-1; print "BUTTONPRESS $but\n" if($PDL::Graphics::TriD::verbose); $this->{X} = $args[1]; $this->{Y} = $args[2]; $retval = $this->{Buttons}[$but]->ButtonPress($args[1],$args[2]) if($this->{Buttons}[$but]); } elsif($type == ButtonRelease) { my $but = $args[0]-1; print "BUTTONRELEASE $but\n" if($PDL::Graphics::TriD::verbose); $retval = $this->{Buttons}[$but]->ButtonRelease($args[1],$args[2]) if($this->{Buttons}[$but]); } elsif($type== ConfigureNotify) { # Kludge to force reshape of the viewport associated with the window -CD print "ConfigureNotify (".join(",",@args).")\n" if($PDL::Graphics::TriD::verbose); print "viewport is $this->{VP}\n" if($PDL::Graphics::TriD::verbose); # $retval = $this->reshape(@args); } $retval; } sub set_button { my($this,$butno,$act) = @_; $this->{Buttons}[$butno] = $act; } ###################################################################### ###################################################################### # VIEWPORT MINI_PACKAGE FOLLOWS! package PDL::Graphics::TriD::ViewPort; use base qw/PDL::Graphics::TriD::Object/; use fields qw/X0 Y0 W H Transformer EHandler Active ResizeCommands DefMaterial AspectRatio Graphs/; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use PDL::Graphics::OpenGLQ; sub highlight { my ($vp) = @_; my $pts = new PDL [[0,0,0], [$vp->{W},0,0], [$vp->{W},$vp->{H},0], [0,$vp->{H},0], [0,0,0]]; my $colors; $colors = PDL->ones(3,5); glDisable(GL_LIGHTING); glMatrixMode(GL_MODELVIEW); glLoadIdentity(); glMatrixMode(GL_PROJECTION); glLoadIdentity(); gluOrtho2D(0,$vp->{W},0,$vp->{H}); glLineWidth(4); gl_line_strip($pts,$colors); glLineWidth(1); glEnable(GL_LIGHTING); } sub do_perspective { my($this) = @_; print "do_perspective ",$this->{W}," ",$this->{H} ,"\n" if($PDL::Graphics::TriD::verbose); if($PDL::Graphics::TriD::verbose>1){ my ($i,$package,$filename,$line); $i = 0; do { ($package,$filename,$line) = caller($i++); print "$package ($filename, line $line)\n"; } while($package); print "\n"; } unless($this->{W}>0 and $this->{H}>0) {return;} # if($this->{W}==0 or $this->{H}==0) {return;} $this->{AspectRatio} = (1.0*$this->{W})/$this->{H}; # glResizeBuffers(); glViewport($this->{X0},$this->{Y0},$this->{W},$this->{H}); $this->highlight() if($this->{Active}); glMatrixMode(GL_PROJECTION); glLoadIdentity(); gluPerspective(40.0, $this->{AspectRatio} , 0.1, 200000.0); glMatrixMode(GL_MODELVIEW); glLoadIdentity (); } ############### # # Because of the way GL does texturing, this must be the very last thing # in the object stack before the actual surface. There must not be any # transformations after this. # # There may be several of these but all of these must have just one texture. @PDL::Graphics::TriD::GL::SliceTexture::ISA = qw/PDL::Graphics::TriD::Object/; sub PDL::Graphics::TriD::GL::SliceTexture::new { my $image; glPixelStorei(GL_UNPACK_ALIGNMENT,1); glTexImage1D(GL_TEXTURE_1D,0 , 4, 2,0,GL_RGBA,GL_UNSIGNED_BYTE, $image); glTexParameterf(GL_TEXTURE_1D,GL_TEXTURE_WRAP_S,GL_CLAMP); glTexEnvf(GL_TEXTURE_ENV,GL_TEXTURE_ENV_MODE,GL_DECAL); } sub PDL::Graphics::TriD::GL::SliceTexture::togl { my ($this) = @_; glEnable(GL_TEXTURE_1D); glTexGen(); $this->SUPER::togl(); glDisable(GL_TEXTURE_1D); } 1; ����������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/GoBoard.pm�������������������������������������������������������������0000644�0601750�0601001�00000004537�12562522364�015533� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # Some 3D/2D representations of Go Boards. # this may not be of great interest to people who don't play Go # except in some strange visualization senses. # Also Go players will not find this to look too much like a real go board. package PDL::Graphics::TriD::GoBoard; use base qw/PDL::Graphics::TriD::Object/; use fields qw /Data InLays BG/; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use PDL::Lite; sub new { my($type,$opts) = @_; my $this = $type->SUPER::new(); $this->{Data} = $opts->{Data}; my $d = $opts->{Data}; my $eo = ($d->slice("(3)")+0.000005) / ($d->slice("(2)") + $d->slice("(3)") + 0.00001); $this->{BG} = new PDL::Graphics::TriD::Image([$eo*0, $eo, 0*$eo]); return $this; } sub add_inlay { my($this,$data,$x,$y,$z) = @_; push @{$this->{InLays}},[$z,(new PDL::Graphics::TriD::GoBoard({Data => $data})), $x,$y, $data->dims]; } sub togl { my($this) = @_; # my $z = 0.5; # my $z = 0.001; my $z = 0.01; print "BOARD2GL\n" if $PDL::Graphics::TriD::verbose; # 0 = white, 1 = black, 2 = outside, 3 = empty. my $d = $this->{Data}; $this->{BG}->togl(); glDisable(GL_LIGHTING); # 1. stones. my $hass = $d->slice("(0)") + $d->slice("(1)"); my $stoc = $d->slice("(0)") / ($hass+0.00001); my ($x,$y); my ($foo,$nx,$ny) = ($this->{Data}->dims); my $xs = 0.5/$nx; my $ys = 0.5/$ny; glBegin(GL_QUADS); for $x (0..$nx-1) { for $y (0..$ny-1) { my $c = $stoc->at($x,$y); my $s = $hass->at($x,$y); my $cx = ($x+0.5)/$nx; my $cy = ($y+0.5)/$ny; # glColor3f($c,$c,$c); glColor3f($c,0.3,1-$c); glVertex3d($cx+$s*$xs,$cy,$z); glVertex3d($cx,$cy+$s*$ys,$z); glVertex3d($cx-$s*$xs,$cy,$z); glVertex3d($cx,$cy-$s*$ys,$z); } } glEnd(); for (@{$this->{InLays}}) { glEnable(&GL_DEPTH_TEST); glPushMatrix(); glTranslatef($xs*2*$_->[2],$ys*2*$_->[3], $_->[0]); my $z = -$_->[0]; glScalef($_->[5]/$nx,$_->[6]/$ny,1); $_->[1]->togl(); glDisable(&GL_LIGHTING); glColor3d(1,1,1); glBegin(&GL_LINES); glVertex3d(0,0,0); glVertex3d(0,0,$z); glVertex3d(0,1,0); glVertex3d(0,1,$z); glVertex3d(1,0,0); glVertex3d(1,0,$z); glVertex3d(1,1,0); glVertex3d(1,1,$z); glEnd(); glPopMatrix(); } glEnable(&GL_LIGHTING); } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Graph.pm���������������������������������������������������������������0000644�0601750�0601001�00000022172�12562522364�015252� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package PDL::Graphics::TriD::Graph; use base qw/PDL::Graphics::TriD::Object/; use PDL::LiteF; # XXX F needed? use fields qw(Data DataBind UnBound DefaultAxes Axis ); sub add_dataseries { my($this,$data,$name) = @_; if(!defined $name) { $name = "Data0"; while(defined $this->{Data}{$name}) {$name++;} } $this->{Data}{$name} = $data; $this->{DataBind}{$name} = []; $this->{UnBound}{$name} = 1; $this->add_object($data); $this->changed(); return $name; } sub bind_data { my($this,$dser,$axes,$axis) = @_; push @{$this->{DataBind}{$dser}},[$axis,$axes]; delete $this->{UnBound}{$dser}; $this->changed(); } sub bind_default { my($this,$dser,$axes) = @_; if(!defined $axes) {$axes = $this->{DefaultAxes}}; $this->{DataBind}{$dser} = [['Default',$axes]]; delete $this->{UnBound}{$dser}; } sub set_axis { my($this,$axis,$name) = @_; $this->{Axis}{$name} = $axis; $this->changed(); } # Bind all unbound things here... sub scalethings { my($this) = @_; for(keys %{$this->{UnBound}}) { $this->bind_default($_); } for(values %{$this->{Axis}}) { $_->init_scale() ; } my ($k,$v); while(($k,$v) = each %{$this->{DataBind}}) { for(@$v) { $this->{Axis}{$_->[0]}->add_scale( $this->{Data}{$k}->get_points(), $_->[1]); } } for(values %{$this->{Axis}}) { $_->finish_scale(); } } # use Data::Dumper; sub get_points { my($this,$name) = @_; # print Dumper($this->{Axis}); my $d = $this->{Data}{$name}->get_points(); my @ddims = $d->dims; shift @ddims; my $p = PDL->zeroes(&PDL::float(),3,@ddims); my $pnew; for(@{$this->{DataBind}{$name}}) { defined($this->{Axis}{$_->[0]}) or die("Axis not defined: $_->[0]"); # Transform can return the same or a different piddle. $pnew = $this->{Axis}{$_->[0]}->transform($p,$d,$_->[1]); $p = $pnew; } return $pnew; } sub clear_data { my($this) = @_; $this->{Data} = {}; $this->{DataBind} = {}; $this->{UnBound} = {}; $this->changed(); } sub delete_data { my($this,$name) = @_; delete $this->{Data}{$name}; delete $this->{DataBind}{$name}; delete $this->{UnBound}{$name}; $this->changed(); } sub default_axes { my($this) = @_; $this->set_axis(PDL::Graphics::TriD::EuclidAxes->new(),"Euclid3"); $this->set_default_axis("Euclid3",[0,1,2]); } sub set_default_axis { my($this,$name,$axes) = @_; $this->{Axis}{Default} = $this->{Axis}{$name}; $this->{DefaultAxes} = $axes; } sub changed {} package PDL::Graphics::TriD::EuclidAxes; sub new { my($type) = @_; bless {Names => [X,Y,Z]},$type; } sub init_scale { my($this) = @_; $this->{Scale} = []; } sub add_scale { my($this,$data,$inds) = @_; my $i = 0; for(@$inds) { my $d = $data->slice("($_)"); my $max = $d->max; my $min = $d->min; if(!defined $this->{Scale}[$i]) { $this->{Scale}[$i] = [$min,$max]; } else { if($min < $this->{Scale}[$i][0]) { $this->{Scale}[$i][0] = $min; } if($max > $this->{Scale}[$i][1]) { $this->{Scale}[$i][1] = $max; } } $i++; } } sub finish_scale { my($this) = @_; # Normalize the smallest differences away. for(@{$this->{Scale}}) { if(abs($_->[0] - $_->[1]) < 0.000001) { $_->[1] = $_->[0] + 1; } else { my $shift = ($_->[1]-$_->[0])*0.05; $_->[0] -= $shift; $_->[1] += $shift; } } } # Add 0..1 to each axis. sub transform { my($this,$point,$data,$inds) = @_; my $i = 0; for(@$inds) { (my $tmp = $point->slice("($i)")) += ($data->slice("($_)") - $this->{Scale}[$i][0]) / ($this->{Scale}[$i][1] - $this->{Scale}[$i][0]) ; $i++; } return $point; } # # projects from the sphere to a cylinder # package PDL::Graphics::TriD::CylindricalEquidistantAxes; use PDL::Core ''; sub new { my($type) = @_; bless {Names => [LON,LAT,Pressure]},$type; } sub init_scale { my($this) = @_; $this->{Scale} = []; } sub add_scale { my($this,$data,$inds) = @_; my $i = 0; for(@$inds) { my $d = $data->slice("($_)"); my $max = $d->max; my $min = $d->min; if($i==1){ if($max > 89.9999 or $min < -89.9999){ barf "Error in Latitude $max $min\n"; } } elsif($i==2){ $max = 1012.5 if($max<1012.5); $min = 100 if($min>100); } if(!defined $this->{Scale}[$i]) { $this->{Scale}[$i] = [$min,$max]; } else { if($min < $this->{Scale}[$i][0]) { $this->{Scale}[$i][0] = $min; } if($max > $this->{Scale}[$i][1]) { $this->{Scale}[$i][1] = $max; } } $i++; } # $this->{Center} = [$this->{Scale}[0][0]+($this->{Scale}[0][1]-$this->{Scale}[0][0])/2, # $this->{Scale}[1][0]+($this->{Scale}[1][1]-$this->{Scale}[1][0])/2]; # # Should make the projection center an option # $this->{Center} = [$this->{Scale}[0][0]+($this->{Scale}[0][1]-$this->{Scale}[0][0])/2, 0]; } sub finish_scale { my($this) = @_; my @dist; # Normalize the smallest differences away. for(@{$this->{Scale}}) { if(abs($_->[0] - $_->[1]) < 0.000001) { $_->[1] = $_->[0] + 1; } push(@dist,$_->[1]-$_->[0]); } # for the z coordiniate reverse the min and max values my $max = $this->{Scale}[2][0]; if($max < $this->{Scale}[2][1]){ $this->{Scale}[2][0] = $this->{Scale}[2][1]; $this->{Scale}[2][1] = $max; } # Normalize longitude and latitude scale if($dist[1] > $dist[0]){ $this->{Scale}[0][0] -= ($dist[1]-$dist[0])/2; $this->{Scale}[0][1] += ($dist[1]-$dist[0])/2; }elsif($dist[0] > $dist[1] && $dist[0]<90){ $this->{Scale}[1][0] -= ($dist[0]-$dist[1])/2; $this->{Scale}[1][1] += ($dist[0]-$dist[1])/2; }elsif($dist[0] > $dist[1]){ $this->{Scale}[1][0] -= (90-$dist[1])/2; $this->{Scale}[1][1] += (90-$dist[1])/2; } } sub transform { my($this,$point,$data,$inds) = @_; my $i = 0; if($#$inds!=2){ barf("Wrong number of arguments to transform $this\n"); exit; } my $pio180 = 0.017453292; (my $tmp1 = $point->slice("(0)")) += 0.5+($data->slice("($inds->[0])")-$this->{Center}[0]) / ($this->{Scale}[0][1] - $this->{Scale}[0][0]) *cos($data->slice("($inds->[1])")*$pio180); (my $tmp2 = $point->slice("(1)")) += 0.5+($data->slice("($inds->[1])")-$this->{Center}[1]) / ($this->{Scale}[1][1] - $this->{Scale}[1][0]); (my $tmp3 = $point->slice("(2)")) .= log($data->slice("($inds->[2])")/1012.5)/log($this->{Scale}[2][1]/1012.5); return $point; } package PDL::Graphics::TriD::PolarStereoAxes; use PDL::Core ''; sub new { my($type) = @_; bless {Names => [LONGITUDE,LATITUDE,HEIGHT]},$type; } sub init_scale { my($this) = @_; $this->{Scale} = []; } sub add_scale { my($this,$data,$inds) = @_; my $i = 0; for(@$inds) { my $d = $data->slice("($_)"); my $max = $d->max; my $min = $d->min; if($i==1){ if($max > 89.9999 or $min < -89.9999){ barf "Error in Latitude $max $min\n"; } } elsif($i==2){ $max = 1012.5 if($max<1012.5); $min = 100 if($min>100); } if(!defined $this->{Scale}[$i]) { $this->{Scale}[$i] = [$min,$max]; } else { if($min < $this->{Scale}[$i][0]) { $this->{Scale}[$i][0] = $min; } if($max > $this->{Scale}[$i][1]) { $this->{Scale}[$i][1] = $max; } } $i++; } $this->{Center} = [$this->{Scale}[0][0]+($this->{Scale}[0][1]-$this->{Scale}[0][0])/2, $this->{Scale}[1][0]+($this->{Scale}[1][1]-$this->{Scale}[1][0])/2]; } sub finish_scale { my($this) = @_; my @dist; # Normalize the smallest differences away. for(@{$this->{Scale}}) { if(abs($_->[0] - $_->[1]) < 0.000001) { $_->[1] = $_->[0] + 1; } push(@dist,$_->[1]-$_->[0]); } # for the z coordiniate reverse the min and max values my $max = $this->{Scale}[2][0]; if($max < $this->{Scale}[2][1]){ $this->{Scale}[2][0] = $this->{Scale}[2][1]; $this->{Scale}[2][1] = $max; } # Normalize longitude and latitude scale if($dist[1] > $dist[0]){ $this->{Scale}[0][0] -= ($dist[1]-$dist[0])/2; $this->{Scale}[0][1] += ($dist[1]-$dist[0])/2; }elsif($dist[0] > $dist[1] && $dist[0]<90){ $this->{Scale}[1][0] -= ($dist[0]-$dist[1])/2; $this->{Scale}[1][1] += ($dist[0]-$dist[1])/2; }elsif($dist[0] > $dist[1]){ $this->{Scale}[1][0] -= (90-$dist[1])/2; $this->{Scale}[1][1] += (90-$dist[1])/2; } } sub transform { my($this,$point,$data,$inds) = @_; my $i = 0; if($#$inds!=2){ barf("Wrong number of arguments to transform $this\n"); exit; } my $pio180 = 0.017453292; (my $tmp1 = $point->slice("(0)")) += 0.5+($data->slice("($inds->[0])")-$this->{Center}[0]) / ($this->{Scale}[0][1] - $this->{Scale}[0][0]) *cos($data->slice("($inds->[1])")*$pio180); (my $tmp2 = $point->slice("(1)")) += 0.5+($data->slice("($inds->[1])")-$this->{Center}[1]) / ($this->{Scale}[1][1] - $this->{Scale}[1][0]) *cos($data->slice("($inds->[1])")*$pio180); # Longitude transformation # (my $tmp = $point->slice("(0)")) = # ($this->{Center}[0]-$point->slice("(0)"))*cos($data->slice("(1)")); # Latitude transformation # (my $tmp = $point->slice("(1)")) = # ($this->{Center}[1]-$data->slice("(1)"))*cos($data->slice("(1)")); # Vertical transformation # -7.2*log($data->slice("(2)")/1012.5 (my $tmp3 = $point->slice("(2)")) .= log($data->slice("($inds->[2])")/1012.5)/log($this->{Scale}[2][1]/1012.5); return $point; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Image.pm���������������������������������������������������������������0000644�0601750�0601001�00000006002�12562522364�015225� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # What makes this complicated is that we want # imag(3,x,y,z,q,d,f) # appear in one 2D image, flattened out appropriately, with # one black space between the subimages. # The X coordinate will be ((x+1)*z+1)*d and the # Y coordinate ((y+1)*q+1)*f. We need to use splitdim to obtain # a piddle of the imag dimensions from the flat piddle. package PDL::Graphics::TriD::Image; @ISA=qw/PDL::Graphics::TriD::Object/; use PDL::Lite; my $defaultvert = PDL->pdl([ [0,0,0], [1,0,0], [1,1,0], [0,1,0] ]); # r,g,b = 0..1 sub new { my($type,$color,$opts) = @_; my $im = PDL::Graphics::TriD::realcoords(COLOR,$color); my $this = { Im => $im, Opts => $opts, Points => $defaultvert, }; if(defined $opts->{Points}) { $this->{Points} = $opts->{Points}; if("ARRAY" eq ref $this->{Points}) { $this->{Points} = PDL->pdl($this->{Points}); } } bless $this,$type; } sub get_points { return $_[0]->{Points}; } # In the future, have this happen automatically by the piddles. sub data_changed { my($this) = @_; $this->changed(); } # ND piddle -> 2D sub flatten { my ($this,$bin_align) = @_; my @dims = $this->{Im}->dims; shift @dims; # get rid of the '3' my $xd = $dims[0]; my $yd = $dims[1]; my $xdr = $xd; my $ydr = $yd; # Calculate the whole width of the image. my $ind = 0; my $xm = 0; my $ym = 0; for(@dims[2..$#dims]) { if($ind % 2 == 0) { $xd ++; # = $dims[$ind-2]; $xd *= $_; $xdr ++; $xdr *= $_; # $xd --; # = $dims[$ind-2]; $xm++; } else { $yd ++; # = $dims[$ind-2]; $yd *= $_; $ydr ++; $ydr *= $_; # $yd --; # = $dims[$ind-2]; $ym++; } $ind++; } $xd -= $xm; $yd -= $ym; # R because the final texture must be 2**x-aligned ;( my ($txd ,$tyd, $xxd, $yyd); if ($bin_align) { for($txd = 0; $txd < 12 and 2**$txd < $xdr; $txd++) {}; for($tyd = 0; $tyd < 12 and 2**$tyd < $ydr; $tyd++) {}; $txd = 2**$txd; $tyd = 2**$tyd; $xxd = ($xdr > $txd ? $xdr : $txd); $yyd = ($ydr > $tyd ? $ydr : $tyd); if($#dims > 1) { # print "XALL: $xd $yd $xdr $ydr $txd $tyd\n"; # print "DIMS: ",(join ',',$this->{Im}->dims),"\n"; } # $PDL::debug=1; } else { $xxd=$txd=$xdr; $yyd=$tyd=$ydr; } my $p = PDL->zeroes(PDL::float(),3,$xxd,$yyd); if(defined $this->{Opts}{Bg}) { $p .= $this->{Opts}{Bg}; } # print "MKFOOP\n"; my $foop = $p->slice(":,0:".($xdr-1).",0:".($ydr-1)); $ind = $#dims; my $firstx = 1; my $firsty = 1; my $spi; for(@dims[reverse(2..$#dims)]) { $foop->make_physdims(); # print "FOOP: \n"; $foop->dump; if($ind % 2 == 0) { $spi = $foop->getdim(1)/$_; $foop = $foop->splitdim(1,$spi)->slice(":,0:-2")-> mv(2,3); } else { $spi = $foop->getdim(2)/$_; $foop = $foop->splitdim(2,$spi)->slice(":,:,0:-2"); } # print "IND+\n"; $ind++; # Just to keep even/odd correct } # $foop->dump; print "ASSGNFOOP!\n" if $PDL::debug; $foop .= $this->{Im}; # print "P: $p\n"; return wantarray() ? ($p,$xd,$yd,$txd,$tyd) : $p; } sub toimage { # initially very simple implementation my ($this) = @_; return $this->flatten(0); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Labels.pm��������������������������������������������������������������0000644�0601750�0601001�00000002655�12562522364�015417� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Graphics::TriD::Labels -- Text tools =head1 SYNOPSIS my $l = new PDL::Graphics::TriD::Labels($lablepoints, {Strings=>$strlist ,Font=>$font}); =head1 WARNING This module is experimental and the interface will probably change. =head1 DESCRIPTION This module is used to write Labels on the graphs of TriD =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka (lukka@husc.harvard.edu). 2000 James P. Edwards (jedwards@inmet.gov.br) All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Graphics::TriD::Labels; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use PDL::Graphics::OpenGLQ; use base qw/PDL::Graphics::TriD::GObject/; sub gdraw { my($this,$points) = @_; glDisable(&GL_LIGHTING); glColor3d(1,1,1); PDL::Graphics::OpenGLQ::gl_texts($points,$this->{Options}{Font},$this->{Options}{Strings}); glEnable(&GL_LIGHTING); } sub get_valid_options { return {UseDefcols => 0, Font=>$PDL::Graphics::TriD::GL::fontbase, Strings => [] } } 1; �����������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Lines.pm���������������������������������������������������������������0000644�0601750�0601001�00000002336�12562522364�015263� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� package PDL::Graphics::TriD::LinesFOOOLD; @ISA=qw/PDL::Graphics::TriD::Object/; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use PDL::Lite; sub new { my($type,$x,$y,$z,$color) = @_; my @xdims = $x->dims; $color = PDL->pdl(1) if !defined $color; my $this = { X => $x, Y => $y, Z => $z, Color => $color, }; bless $this,$type; } sub get_boundingbox { my ($this) = @_; my (@mins,@maxs); for (X,Y,Z) { push @mins, $this->{$_}->min(); push @maxs, $this->{$_}->max(); } print "LineBound: ",(join ',',@mins,@maxs),"\n"; return PDL::Graphics::TriD::BoundingBox->new( @mins,@maxs ); } # XXX Color is ignored. sub togl { my($this) = @_; glDisable(GL_LIGHTING); glBegin(&GL_LINE_STRIP); my $first = 1; PDL::threadover_n($this->{X},$this->{Y},$this->{Z},$this->{Color},sub { if(shift > 0) { if(!$first) { glEnd(); glBegin(&GL_LINE_STRIP); } else {$first = 0;} } my $color = pop @_; glColor3f($color,0,1-$color); glVertex3d(@_); # print "VERTEX: ",(join ",",@_),"\n"; }) ; glEnd(); glEnable(GL_LIGHTING); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Logo.pm����������������������������������������������������������������0000644�0601750�0601001�00000031645�12562522364�015116� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package PDL::Graphics::TriD::Logo; use PDL::Lite; @ISA=qw/PDL::Graphics::TriD::Object/; sub new { my ($type,$pos,$size) = @_; $this = bless {},$type; $this->{Points} = PDL->pdl ([ [ 0.843, 0.852, 0], [ 0.843, 0.852, -1], [ 1.227, 0.891, 0], [ 1.227, 0.891, -1], [ 1.56, 1.071, 0], [ 1.56, 1.071, -1], [ 1.722, 1.488, 0], [ 1.722, 1.488, -1], [ 1.656, 1.776, 0], [ 1.656, 1.776, -1], [ 1.488, 1.956, 0], [ 1.488, 1.956, -1], [ 0.942, 2.076, 0], [ 0.942, 2.076, -1], [ 0.105, 2.076, 0], [ 0.105, 2.076, -1], [ 0.105, 1.989, 0], [ 0.105, 1.989, -1], [ 0.339, 1.95, 0], [ 0.339, 1.95, -1], [ 0.375, 1.797, 0], [ 0.375, 1.797, -1], [ 0.375, 0.279, 0], [ 0.375, 0.279, -1], [ 0.339, 0.126, 0], [ 0.339, 0.126, -1], [ 0.105, 0.087, 0], [ 0.105, 0.087, -1], [ 0.105, 0, 0], [ 0.105, 0, -1], [ 0.99, 0, 0], [ 0.99, 0, -1], [ 0.99, 0.087, 0], [ 0.99, 0.087, -1], [ 0.714, 0.126, 0], [ 0.714, 0.126, -1], [ 0.672, 0.279, 0], [ 0.672, 0.279, -1], [ 0.672, 0.852, 0], [ 0.672, 0.852, -1], [ 0.714, 1.947, 0], [ 0.714, 1.947, -1], [ 0.9, 1.971, 0], [ 0.9, 1.971, -1], [ 1.266, 1.842, 0], [ 1.266, 1.842, -1], [ 1.398, 1.467, 0], [ 1.398, 1.467, -1], [ 1.242, 1.071, 0], [ 1.242, 1.071, -1], [ 0.894, 0.957, 0], [ 0.894, 0.957, -1], [ 0.717, 0.975, 0], [ 0.717, 0.975, -1], [ 0.672, 1.074, 0], [ 0.672, 1.074, -1], [ 0.672, 1.86, 0], [ 0.672, 1.86, -1], [ 2.526, 1.944, 0], [ 2.526, 1.944, -1], [ 2.82, 1.971, 0], [ 2.82, 1.971, -1], [ 3.222, 1.896, 0], [ 3.222, 1.896, -1], [ 3.48, 1.701, 0], [ 3.48, 1.701, -1], [ 3.657, 1.062, 0], [ 3.657, 1.062, -1], [ 3.591, 0.594, 0], [ 3.591, 0.594, -1], [ 3.411, 0.3, 0], [ 3.411, 0.3, -1], [ 3.132, 0.147, 0], [ 3.132, 0.147, -1], [ 2.784, 0.105, 0], [ 2.784, 0.105, -1], [ 2.529, 0.15, 0], [ 2.529, 0.15, -1], [ 2.472, 0.375, 0], [ 2.472, 0.375, -1], [ 2.472, 1.8, 0], [ 2.472, 1.8, -1], [ 1.905, 1.989, 0], [ 1.905, 1.989, -1], [ 2.139, 1.95, 0], [ 2.139, 1.95, -1], [ 2.175, 1.797, 0], [ 2.175, 1.797, -1], [ 2.175, 0.279, 0], [ 2.175, 0.279, -1], [ 2.139, 0.126, 0], [ 2.139, 0.126, -1], [ 1.905, 0.087, 0], [ 1.905, 0.087, -1], [ 1.905, 0, 0], [ 1.905, 0, -1], [ 2.841, 0, 0], [ 2.841, 0, -1], [ 3.603, 0.192, 0], [ 3.603, 0.192, -1], [ 3.882, 0.522, 0], [ 3.882, 0.522, -1], [ 3.993, 1.074, 0], [ 3.993, 1.074, -1], [ 3.927, 1.491, 0], [ 3.927, 1.491, -1], [ 3.723, 1.815, 0], [ 3.723, 1.815, -1], [ 3.375, 2.013, 0], [ 3.375, 2.013, -1], [ 2.901, 2.076, 0], [ 2.901, 2.076, -1], [ 1.905, 2.076, 0], [ 1.905, 2.076, -1], [ 4.848, 1.95, 0], [ 4.848, 1.95, -1], [ 5.097, 1.989, 0], [ 5.097, 1.989, -1], [ 5.097, 2.076, 0], [ 5.097, 2.076, -1], [ 4.242, 2.076, 0], [ 4.242, 2.076, -1], [ 4.242, 1.989, 0], [ 4.242, 1.989, -1], [ 4.476, 1.95, 0], [ 4.476, 1.95, -1], [ 4.512, 1.797, 0], [ 4.512, 1.797, -1], [ 4.512, 0.279, 0], [ 4.512, 0.279, -1], [ 4.476, 0.126, 0], [ 4.476, 0.126, -1], [ 4.242, 0.087, 0], [ 4.242, 0.087, -1], [ 4.242, 0, 0], [ 4.242, 0, -1], [ 5.799, 0, 0], [ 5.799, 0, -1], [ 5.835, 0.537, 0], [ 5.835, 0.537, -1], [ 5.745, 0.537, 0], [ 5.745, 0.537, -1], [ 5.571, 0.174, 0], [ 5.571, 0.174, -1], [ 5.205, 0.105, 0], [ 5.205, 0.105, -1], [ 4.884, 0.135, 0], [ 4.884, 0.135, -1], [ 4.809, 0.36, 0], [ 4.809, 0.36, -1], [ 4.809, 1.797, 0], [ 4.809, 1.797, -1]]); $this->{Index} = PDL->pdl([ [ 0, 1, 2], [ 3, 2, 1], [ 2, 3, 4], [ 5, 4, 3], [ 4, 5, 6], [ 7, 6, 5], [ 6, 7, 8], [ 9, 8, 7], [ 8, 9, 10], [ 11, 10, 9], [ 10, 11, 12], [ 13, 12, 11], [ 12, 13, 14], [ 15, 14, 13], [ 14, 15, 16], [ 17, 16, 15], [ 16, 17, 18], [ 19, 18, 17], [ 18, 19, 20], [ 21, 20, 19], [ 20, 21, 22], [ 23, 22, 21], [ 22, 23, 24], [ 25, 24, 23], [ 24, 25, 26], [ 27, 26, 25], [ 26, 27, 28], [ 29, 28, 27], [ 28, 29, 30], [ 31, 30, 29], [ 30, 31, 32], [ 33, 32, 31], [ 32, 33, 34], [ 35, 34, 33], [ 34, 35, 36], [ 37, 36, 35], [ 36, 37, 38], [ 39, 38, 37], [ 38, 39, 0], [ 1, 0, 39], [ 40, 41, 42], [ 43, 42, 41], [ 42, 43, 44], [ 45, 44, 43], [ 44, 45, 46], [ 47, 46, 45], [ 46, 47, 48], [ 49, 48, 47], [ 48, 49, 50], [ 51, 50, 49], [ 50, 51, 52], [ 53, 52, 51], [ 52, 53, 54], [ 55, 54, 53], [ 54, 55, 56], [ 57, 56, 55], [ 56, 57, 40], [ 41, 40, 57], [ 58, 59, 60], [ 61, 60, 59], [ 60, 61, 62], [ 63, 62, 61], [ 62, 63, 64], [ 65, 64, 63], [ 64, 65, 66], [ 67, 66, 65], [ 66, 67, 68], [ 69, 68, 67], [ 68, 69, 70], [ 71, 70, 69], [ 70, 71, 72], [ 73, 72, 71], [ 72, 73, 74], [ 75, 74, 73], [ 74, 75, 76], [ 77, 76, 75], [ 76, 77, 78], [ 79, 78, 77], [ 78, 79, 80], [ 81, 80, 79], [ 80, 81, 58], [ 59, 58, 81], [ 82, 83, 84], [ 85, 84, 83], [ 84, 85, 86], [ 87, 86, 85], [ 86, 87, 88], [ 89, 88, 87], [ 88, 89, 90], [ 91, 90, 89], [ 90, 91, 92], [ 93, 92, 91], [ 92, 93, 94], [ 95, 94, 93], [ 94, 95, 96], [ 97, 96, 95], [ 96, 97, 98], [ 99, 98, 97], [ 98, 99,100], [101,100, 99], [100,101,102], [103,102,101], [102,103,104], [105,104,103], [104,105,106], [107,106,105], [106,107,108], [109,108,107], [108,109,110], [111,110,109], [110,111,112], [113,112,111], [112,113, 82], [ 83, 82,113], [114,115,116], [117,116,115], [116,117,118], [119,118,117], [118,119,120], [121,120,119], [120,121,122], [123,122,121], [122,123,124], [125,124,123], [124,125,126], [127,126,125], [126,127,128], [129,128,127], [128,129,130], [131,130,129], [130,131,132], [133,132,131], [132,133,134], [135,134,133], [134,135,136], [137,136,135], [136,137,138], [139,138,137], [138,139,140], [141,140,139], [140,141,142], [143,142,141], [142,143,144], [145,144,143], [144,145,146], [147,146,145], [146,147,148], [149,148,147], [148,149,150], [151,150,149], [150,151,114], [115,114,151], [ 13, 43, 41], [ 13, 45, 43], [ 11, 45, 13], [ 11, 47, 45], [ 5, 47, 11], [ 5, 49, 47], [ 3, 49, 5], [ 3, 51, 49], [ 1, 51, 3], [ 1, 53, 51], [ 39, 53, 1], [ 39, 55, 53], [ 57, 55, 39], [ 57, 39, 37], [ 21, 57, 37], [ 23, 21, 37], [ 35, 23, 37], [ 21, 41, 57], [ 21, 13, 41], [ 19, 13, 21], [ 19, 15, 13], [ 17, 15, 19], [ 5, 11, 9], [ 7, 5, 9], [ 35, 33, 31], [ 23, 35, 31], [ 25, 23, 31], [ 27, 25, 31], [ 29, 27, 31], [111, 61, 59], [111, 63, 61], [109, 63,111], [109, 65, 63], [107, 65,109], [107, 67, 65], [101, 67,107], [101, 99, 67], [ 97, 75, 73], [ 97, 77, 75], [ 89, 77, 97], [ 89, 79, 77], [ 87, 79, 89], [ 87, 81, 79], [ 59, 81, 87], [ 59, 87, 85], [111, 59, 85], [113,111, 85], [ 83,113, 85], [101,107,105], [103,101,105], [ 69, 67, 99], [ 71, 69, 99], [ 73, 71, 99], [ 97, 73, 99], [ 91, 89, 97], [ 93, 91, 97], [ 95, 93, 97], [125,121,119], [127,125,119], [115,127,119], [117,115,119], [149,127,151], [149,129,127], [147,129,149], [147,131,129], [137,131,147], [137,133,131], [135,133,137], [141,139,137], [143,141,137], [145,143,137], [147,145,137], [123,121,125], [151,127,115], [ 40, 42, 12], [ 12, 42, 44], [ 12, 44, 10], [ 10, 44, 46], [ 10, 46, 4], [ 4, 46, 48], [ 4, 48, 2], [ 2, 48, 50], [ 2, 50, 0], [ 0, 50, 52], [ 0, 52, 38], [ 38, 52, 54], [ 38, 54, 56], [ 36, 38, 56], [ 36, 56, 20], [ 36, 20, 22], [ 36, 22, 34], [ 56, 40, 20], [ 20, 40, 12], [ 20, 12, 18], [ 18, 12, 14], [ 18, 14, 16], [ 8, 10, 4], [ 8, 4, 6], [ 30, 32, 34], [ 30, 34, 22], [ 30, 22, 24], [ 30, 24, 26], [ 30, 26, 28], [ 58, 60,110], [110, 60, 62], [110, 62,108], [108, 62, 64], [108, 64,106], [106, 64, 66], [106, 66,100], [100, 66, 98], [ 72, 74, 96], [ 96, 74, 76], [ 96, 76, 88], [ 88, 76, 78], [ 88, 78, 86], [ 86, 78, 80], [ 86, 80, 58], [ 84, 86, 58], [ 84, 58,110], [ 84,110,112], [ 84,112, 82], [104,106,100], [104,100,102], [ 98, 66, 68], [ 98, 68, 70], [ 98, 70, 72], [ 98, 72, 96], [ 96, 88, 90], [ 96, 90, 92], [ 96, 92, 94], [118,120,124], [118,124,126], [118,126,114], [118,114,116], [150,126,148], [148,126,128], [148,128,146], [146,128,130], [146,130,136], [136,130,132], [136,132,134], [136,138,140], [136,140,142], [136,142,144], [136,144,146], [124,120,122], [114,126,150]]); $this->{Material} = new PDL::Graphics::TriD::Material( Shine => 0.212766, Specular =>[0.753217,0.934416,1], Ambient =>[0,0,0], Diffuse =>[0.09855,0.153113,0.191489], Emissive =>[0, 0, 0]); $this->{Pos} = defined($pos) ? $pos : [0,1.2,0]; $this->{Size} = defined($size) ? $size : 0.1; return $this; } 1; # ***add these lines to, e.g. tvrml2.pl # # use PDL::Graphics::TriD::Logo; # $win->add_object(new PDL::Graphics::TriD::Logo); �������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/MathGraph.pm�����������������������������������������������������������0000644�0601750�0601001�00000010700�12562522364�016056� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Graphics::TriD::MathGraph -- Mathematical Graph objects for PDL =head1 SYNOPSIS see the file Demos/TriD/tmathgraph.p in the PDL distribution. =head1 WARNING This module is experimental and the interface will probably change. =head1 DESCRIPTION This module exists for plotting mathematical graphs (consisting of nodes and arcs between them) in 3D and optimizing the placement of the nodes so that the graph is visualizable in a clear way. =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka (lukka@husc.harvard.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Graphics::TriD::MathGraph; use base qw/PDL::Graphics::TriD::GObject/; use fields qw/ArrowLen ArrowWidth/; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } sub gdraw { my($this,$points) = @_; glDisable(&GL_LIGHTING); # print "Color: $this->{Color} @{$this->{Color}}\n"; glColor3d(@{$this->{Options}{Color}}); PDL::Graphics::OpenGLQ::gl_arrows($points,$this->{Options}{From}, $this->{Options}{To},$this->{ArrowLen},$this->{ArrowWidth}); glEnable(&GL_LIGHTING); } sub get_valid_options { return {UseDefcols => 0,From => [],To => [],Color => [1,1,1], ArrowWidth => 0.05, ArrowLen => 0.1} } package PDL::GraphEvolverOLD; use PDL::LiteF; sub new { my($type,$nnodes) = @_; bless {NNodes => $nnodes,Coords => 500*PDL::random(PDL->zeroes(3,$nnodes))}, $type; } sub set_links { my($this,$from,$to,$strength) = @_; my $cd = $this->{NNodes}; $this->{DistMult} = PDL->zeroes($cd,$cd); $distmult = PDL->zeroes($cd,$cd); (my $t1 = $this->{DistMult}->index2d($from,$to)) += $strength; (my $t2 = $this->{DistMult}->index2d($to,$from)) += $strength; print "DM: $distmult\n" if $verbose; } sub set_distmult { my($this,$mat) = @_; $this->{DistMult} = $mat; } sub set_fixed { my($this,$ind,$coord) = @_; $this->{FInd} = $ind; $this->{FCoord} = $coord; } sub step { # $verbose=1; my($this) = @_; my $c = $this->{Coords}; my $vecs = $c - $c->dummy(1); my $dists = sqrt(($vecs**2)->sumover)+0.0001; print "D: $dists\n" if $verbose; (my $t1 = $dists->diagonal(0,1)) .= 1000000; my $d2 = $dists ** -0.5; # inverse my $m = $d2**4 - 2*($this->{DistMult})*($dists+5*$dists**2) + 0.00001 - 0.000001 * $dists; print "DN: $m\n" if $verbose; print "V: $vecs\n" if $verbose; my $tst = 1; $this->{Velo} -= $tst * 0.04 * (inner($m->dummy(1), $vecs->mv(1,0))); $this->{Velo} *= ((0.96*50/(50+sqrt(($this->{Velo}**2)->sumover->dummy(0)))))**$tst; $c += $tst * 0.05 * $this->{Velo}; (my $tmp = $c->xchg(0,1)->index($this->{FInd}->dummy(0))) .= $this->{FCoord} if (defined $this->{FInd}); print "C: $c\n" if $verbose; } sub getcoords {return $_[0]{Coords}} package PDL::GraphEvolver; use PDL::Lite; use PDL::Graphics::TriD::Rout ":Func"; sub new { my($type,$nnodes) = @_; bless {NNodes => $nnodes,Coords => PDL::random(PDL->zeroes(3,$nnodes)), BoxSize => 3, DMult => 5000, A => -100.0, B => -5, C => -0.1, D => 0.01, M => 30, MS => 1, },$type; } sub set_links { my($this,$from,$to,$strength) = @_; $this->{From} = $from; $this->{To} = $to; $this->{Strength} = $strength; } sub set_fixed { my($this,$ind,$coord) = @_; $this->{FInd} = $ind; $this->{FCoord} = $coord; } sub step { # $verbose=1; my($this) = @_; my $c = $this->{Coords}; my $velr = repulse($c,@{$this}{BoxSize,DMult,A,B,C,D}); my $vela; if("ARRAY" eq ref $this->{From}) { my $ind; for $_ (0..$#{$this->{From}}) { $vela += attract($c, $this->{From}[$_], $this->{To}[$_], $this->{Strength}[$_],$this->{M},$this->{MS}); } } else { $vela = attract($c,@{$this}{From,To,Strength},$this->{M}, $this->{MS}); } # print "V: $velr $vela\n"; $tst = 0.10; $this->{Velo} += $tst * 0.02 * ($velr + $vela); $this->{Velo} *= ((0.92*50/(50+sqrt(($this->{Velo}**2)->sumover->dummy(0)))))**$tst; $c += $tst * 0.05 * $this->{Velo}; (my $tmp = $c->xchg(0,1)->index($this->{FInd}->dummy(0))) .= $this->{FCoord} if (defined $this->{FInd}); print "C: $c\n" if $verbose; } sub getcoords {return $_[0]{Coords}} 1; 1; ����������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Mesh.pm����������������������������������������������������������������0000644�0601750�0601001�00000013451�12562522364�015105� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������############################################## # # Given 2D data, make a mesh. # # This is only for a set of rectangular meshes. # # Use PDL::Graphics::TriD::Surface for more general stuff. # # I try to make this general enough that all Surface methods # work on this data also. # # The different types of normals are a headache. # If we have a normal per vertex, we get smoothing. # If we want flat shading, ... need normal / square or triangle. # But: if we have # normal(3, polygons, vertices, @overdims), # we could possibly map it for both cases. # Flat: normal(3,polygon, (), @) # Smooth: normal(3,(), vertex, @) package PDL::Graphics::TriD::Mesh; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use PDL::LiteF; @ISA=qw/PDL::Graphics::TriD::Object/; # For now, x and y coordinates = values. sub new { my($type,$data,$xaxis,$yaxis) = @_; my @dims = $data->dims; my @xydims = splice @dims,0,2; my @overdims = @dims; my $this = { Vertices => PDL->zeroes(3,@xydims,@overdims)->double, XYDims => [@xydims], OverDims => [@overdims], Data => $data, }; PDL::Primitive::axisvalues($this->{Vertices}->slice('(0),:,:')); PDL::Primitive::axisvalues($this->{Vertices}->slice('(1),:,:')->xchg(0,1)); PDL::Ops::assgn($this->{Data},$this->{Vertices}->slice('(2),:,:')); bless $this,$type; } sub printdims {print $_[0].": ".(join ', ',$_[1]->dims)," and ", (join ', ',$_[1]->threadids),"\n"} sub get_boundingbox { my($this) = @_; my $foo = PDL->zeroes(6)->double; $a = $this->{Vertices}; printdims "A",$a; $b = $a->thread(0); printdims "B",$b; $c = $b->clump(-1); printdims "C",$c; $d = $c->unthread(1); printdims "D",$d; $this->{Vertices}->thread(0); PDL::Primitive::minimum($this->{Vertices}->thread(0)->clump(-1)->unthread(1), $foo->slice('0:2')); PDL::Primitive::maximum($this->{Vertices}->thread(0)->clump(-1)->unthread(1), $foo->slice('3:5')); print "MeshBound: ",(join ',',$foo->list()),"\n"; return PDL::Graphics::TriD::BoundingBox->new( $foo->list() ); } sub normals_flat { my($this) = @_; $this->_allocnormalspoly(); my $v00 = $this->{Vertices}->slice('(2),0:-2,0:-2'); my $v01 = $this->{Vertices}->slice('(2),0:-2,1:-1'); my $v10 = $this->{Vertices}->slice('(2),1:-1,0:-2'); my $v11 = $this->{Vertices}->slice('(2),1:-1,1:-1'); # $this->{Normals}->printdims("NORMALS"); my $nx = $this->{Normals}->slice('(0),:,:,(0),(0)'); # $nx->printdims("NX"); $v00->printdims("V0"); $nx *= PDL->pdl(0); $nx += $v11; $nx -= $v01; $nx += $v10; $nx -= $v00; $nx *= PDL->pdl(-0.5); my $ny = $this->{Normals}->slice('(1),:,:,(0),(0)'); $ny *= PDL->pdl(0); $ny += $v11; $ny -= $v10; $ny += $v01; $ny -= $v00; $ny *= PDL->pdl(-0.5); my $nz = $this->{Normals}->slice('(2),:,:,(0),(0)'); $nz .= PDL->pdl(1); print $this->{Vertices}; print $this->{Normals}; print $nx,$ny,$nz; } sub _allocnormalspoly { my($this) = @_; $this->{Normals} = (PDL->zeroes(3, (map {$_-1} @{$this->{XYDims}}), @{$this->{OverDims}})->double ) -> dummy(3,$this->{XYDims}[1]) -> dummy(3,$this->{XYDims}[0]); } sub _allocnormalsvertex { my($this) = @_; $this->{Normals} = (double zeroes(3, (@{$this->{XYDims}}), @{$this->{OverDims}})) -> dummy(1,$this->{XYDims}[1]-1) -> dummy(1,$this->{XYDims}[0]-1); } # Right now, I assume the flat model. sub togl { my($this) = @_; my ($x,$y); # forextradims ([$this->{Vertices},_], for $x (0..$this->{XYDims}[0]-2) { for $y (0..$this->{XYDims}[1]-2) { my ($x1,$y1) = ($x+1,$y+1); glBegin(GL_TRIANGLE_STRIP); print "ONESTRIP\n", (join '', $this->{Normals}->slice(":,($x),($y),($x),($y)") ),"\n"; glNormal3d( $this->{Normals}->slice(":,($x),($y),($x),($y)") ->list()); # print "VERTEX0: ",(join ',', # $this->{Vertices}->slice(":,($x),($y)")->list()), # "\n"; glVertex3d($this->{Vertices}->slice(":,($x),($y)")->list()); glVertex3d($this->{Vertices}->slice(":,($x1),($y)")->list()); glVertex3d($this->{Vertices}->slice(":,($x),($y1)")->list()); glVertex3d($this->{Vertices}->slice(":,($x1),($y1)")->list()); glEnd(); # Show normal # glBegin(&GL_LINES); # glVertex3d($this->{Vertices}->slice(":,($x),($y)")->list()); # glVertex3d( # ($this->{Vertices}->slice(":,($x),($y)") + # $this->{Normals}->slice(":,($x),($y),($x),($y)")) # ->list()); # glEnd(); } } } package PDL::Graphics::TriD; #use PDL::Graphics::OpenGL; use PDL::Graphics::OpenGL::Perl::OpenGL; use PDL::Core ''; sub pdltotrianglemesh { my($pdl,$x0,$x1,$y0,$y1) = @_; if($#{$pdl->{Dims}} != 1) { barf "Too many dimensions for PDL::GL::Mesh: $#{$pdl->{Dims}} \n"; } my ($d0,$d1); my($x,$y); $xincr = ($x1 - $x0) / ($pdl->{Dims}[0]-1.0); $yincr = ($y1 - $y0) / ($pdl->{Dims}[1]-1.0); $x = $x0; my($v00,$v01,$v11,$v10); my($nx,$ny); for $d0 (0..$pdl->{Dims}[0]-2) { $y = $y0; for $d1 (0..$pdl->{Dims}[1]-2) { glBegin(GL_TRIANGLE_STRIP); ($v00,$v01,$v11,$v10) = (PDL::Core::at($pdl,$d0,$d1) ,PDL::Core::at($pdl,$d0,$d1+1) ,PDL::Core::at($pdl,$d0+1,$d1+1) ,PDL::Core::at($pdl,$d0+1,$d1)); ($nx,$ny) = (-0.5*($v11+$v10-$v01-$v00)/$xincr, -0.5*($v11-$v10+$v01-$v00)/$yincr); glNormal3d($nx,$ny,1); glVertex3d($x,$y,$v00); glVertex3d($x+$xincr,$y,$v10); glVertex3d($x,$y+$yincr,$v01); glVertex3d($x+$xincr,$y+$yincr,$v11); glEnd(); if(0) { glBegin(GL_LINES); glVertex3d($x,$y,$v00); glVertex3d($x+$nx/10,$y+$ny/10,$v00+1/10); glEnd(); } $y += $yincr; } $x += $xincr; } } sub pdl2normalizedmeshlist { my($pdl) = @_; my $mult = 1.0/($pdl->{Dims}[0]-1); my $lno = glGenLists(1); glNewList($lno,GL_COMPILE); pdltotrianglemesh($pdl, 0, 1, 0, ($pdl->{Dims}[1]-1)*$mult); glEndList(); return $lno; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Object.pm��������������������������������������������������������������0000644�0601750�0601001�00000003741�12562522364�015420� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������################################### # # package PDL::Graphics::TriD::Object; use strict; use fields qw(Objects ValidList ChangedSub List VRML); sub new{ my $class = shift; my $self = fields::new($class); $self; } sub clear_objects { my($this) = @_; $this->{Objects} = []; $this->{ValidList} = 0; } sub delete_object { my($this,$object) = @_; return unless(defined $object && defined $this->{Objects}); for(0..$#{$this->{Objects}}){ if($object == $this->{Objects}[$_]){ splice(@{$this->{Objects}},$_,1); redo; } } } # XXXXXXXXX sub {} makes all these objects and this window immortal! sub add_object { my($this,$object) = @_; push @{$this->{Objects}},$object; $this->{ValidList} = 0; for(@{$this->{ChangedSub}}) { $object->add_changedsub($_); } if($this->i_keep_list) { $object->add_changedsub(sub {$this->changed_from_above()}); } } sub changed_from_above { my($this) = @_; print "CHANGED_FROM_ABOVE\n" if $PDL::Graphics::TriD::verbose; $this->changed(); } sub add_changedsub { my($this,$chsub) = @_; push @{$this->{ChangedSub}}, $chsub; for (@{$this->{Objects}}) { $_->add_changedsub($chsub); } } sub clear { my($this) = @_; # print "Clear: $this\n"; for(@{$this->{Objects}}) { $_->clear(); } $this->delete_displist(); delete $this->{ChangedSub}; delete $this->{Objects}; } sub changed { my($this) = @_; print "VALID0 $this\n" if $PDL::Graphics::TriD::verbose; $this->{ValidList} = 0; for(@{$this->{ChangedSub}}) { &$_($this); } } sub i_keep_list { return 0; } sub vrml_update { my ($this) = @_; use PDL::Graphics::VRML; $this->{VRML} = new PDL::Graphics::VRMLNode('Transform', 'translation' => "-1 -1 -1", 'scale' => "2 2 2"); $this->{ValidList} = 1; } sub tovrml { my($this) = @_; print ref($this)," valid=",$this->{ValidList}," tovrml\n"; if (!$this->{ValidList}) { $this->vrml_update(); } $this->{VRML}->add('children', [map {$_->tovrml()} @{$this->{Objects}}]); } 1; �������������������������������PDL-2.018/Graphics/TriD/TriD/Objects.pm�������������������������������������������������������������0000644�0601750�0601001�00000023053�12562522364�015601� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Graphics::TriD::Objects - Simple Graph Objects for TriD =head1 SYNOPSIS Look in PDL/Demos/TkTriD_demo.pm for several examples, the code in PDL/Demos/TriD1.pm and PDL/Demos/TriD2.pm also uses objects but it hides them from the user. =head1 DESCRIPTION GObjects can be either stand-alone or in Graphs, scaled properly. All the points used by the object must be in the member {Points}. I guess we can afford to force data to be copied (X,Y,Z) -> (Points)... =head1 OBJECTS =head2 PDL::Graphics::TriD::GObject Inherits from base PDL::Graphics::TriD::Object and adds fields Points, Colors and Options. Need lots more here... =cut package PDL::Graphics::TriD::GObject; use base qw/PDL::Graphics::TriD::Object/; use fields qw/Points Colors Options/; sub new { my($type,$points,$colors,$options) = @_; print "GObject new.. calling SUPER::new...\n" if($PDL::debug_trid); my $this = $type->SUPER::new(); print "GObject new - back (SUPER::new returned $this)\n" if($PDL::debug_trid); if(!defined $options and ref $colors eq "HASH") { $options = $colors; undef $colors; } print "GObject new - calling realcoords\n" if($PDL::debug_trid); $points = PDL::Graphics::TriD::realcoords($type->r_type,$points); print "GObject new - back from realcoords\n" if($PDL::debug_trid); if(!defined $colors) {$colors = PDL->pdl(1,1,1); $colors = $type->cdummies($colors,$points); $options->{UseDefcols} = 1; # for VRML efficiency } else { $colors = PDL::Graphics::TriD::realcoords("COLOR",$colors); } $this->{Options} = $options; $this->{Points} = $points; $this->{Colors} = $colors; $this->check_options(); print "GObject new - returning\n" if($PDL::debug_trid); return $this; } sub check_options { my($this) = @_; my %newopts; my $opts = $this->get_valid_options(); print "FETCHOPT: $this ".(join ',',%$opts)."\n" if $PDL::Graphics::TriD::verbose; for(keys %$opts) { if(!exists $this->{Options}{$_}) { $newopts{$_} = $opts->{$_}; } else { $newopts{$_} = delete $this->{Options}{$_}; } } if(keys %{$this->{Options}}) { die("Invalid options left: ".(join ',',%{$this->{Options}})); } $this->{Options} = \%newopts; } sub set_colors { my($this,$colors) = @_; if(ref($colors) eq "ARRAY"){ $colors = PDL::Graphics::TriD::realcoords("COLOR",$colors); } $this->{Colors}=$colors; $this->data_changed; } sub get_valid_options { return {UseDefcols => 0}; } sub get_points { return $_[0]->{Points}; } # In the future, have this happen automatically by the piddles. sub data_changed { my($this) = @_; $this->changed(); } sub cdummies {return $_[1];} sub r_type { return ""; } sub defcols { return defined($_[0]->{Options}->{UseDefcols}) && $_[0]->{Options}->{UseDefcols}; } 1; package PDL::Graphics::TriD::Points; use base qw/PDL::Graphics::TriD::GObject/; sub get_valid_options { return {UseDefcols => 0, PointSize=> 1}; } package PDL::Graphics::TriD::Spheres; use base qw/PDL::Graphics::TriD::GObject/; sub get_valid_options { # need to add radius return {UseDefcols => 0, PointSize=> 1}; } ########################################################################### ################# JNK 15mar11 added section start ######################### # JNK 06dec00 -- edited from PDL::Graphics/TriD/GObject in file Objects.pm # GObjects can be either stand-alone or in Graphs, scaled properly. # All the points used by the object must be in the member {Points}. # I guess we can afford to force data to be copied (X,Y,Z) -> (Points)... # JNK: I don't like that last assumption for all cases.. # JNK 27nov00 new object type: package PDL::Graphics::TriD::GPObject; # @ISA=qw/PDL::Graphics::TriD::GObject/; use base qw/PDL::Graphics::TriD::GObject/; # use fields qw/.../; sub new { my($type,$points,$faceidx,$colors,$options) = @_; # faceidx is 2D pdl of indices into points for each face if(!defined $options and ref $colors eq "HASH") { $options = $colors;undef $colors; } $points = PDL::Graphics::TriD::realcoords($type->r_type,$points); $faces = $points->dice_axis(1,$faceidx->clump(-1))->splitdim(1,3); # faces is 3D pdl slices of points, giving cart coords of face verts if(!defined $colors) { $colors = PDL->pdl(1,1,1); $colors = $type->cdummies($colors,$faces); $options->{ UseDefcols } = 1; } # for VRML efficiency else { $colors = PDL::Graphics::TriD::realcoords("COLOR",$colors); } my $this = bless { Points => $points, Faceidx => $faceidx, Faces => $faces, Colors => $colors, Options => $options},$type; $this->check_options();return $this; } sub get_valid_options { return { UseDefcols=>0, Lines=>0, Smooth=>1, Material=>0 }; } sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); } # JNK 13dec00 new object type: package PDL::Graphics::TriD::STrigrid_S; # @ISA=qw/PDL::Graphics::TriD::GPObject/; use base qw/PDL::Graphics::TriD::GPObject/; # use fields qw/.../; sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); } sub get_valid_options { return { UseDefcols=>0, Lines=>0, Smooth=>1, Material=>0 }; } # calculate smooth normals sub smoothn { my ($this,$ddd) = @_; my $v=$this->{Points};my $f=$this->{Faces};my $fvi=$this->{Faceidx}; # ---------------------------------------------------------------------------- my @p = map { $f->slice(":,($_),:") } (0..(($fvi->dims)[0]-1)); # ---------------------------------------------------------------------------- # the following line assumes all faces are triangles my $fn = ($p[1]-$p[0])->crossp($p[2]-$p[1])->norm; # my $vfi = PDL::cat(map {PDL::cat(PDL::whichND($fvi==$_))->slice(':,(1)')} # (0..(($v->dims)[1]-1))); # the above, spread into several statements: # my @vfi2=();for my $idx (0..($v->dims)[1]-1) { # my @vfi0=PDL::whichND($fvi==$idx); # my $vfi1=PDL::cat(@vfi0); # $vfi2[$idx]=$vfi1->slice(':,(1)'); } # my $vfi=PDL::cat(@vfi2); # my $vmn = $fn->dice_axis(1,$vfi->clump(-1))->splitdim(1,($fvi->dims)[0]); # my $vn = $vmn->mv(1,0)->sumover->norm; # ---------------------------------------------------------------------------- my $vn=PDL::cat( map { my $vfi=PDL::cat(PDL::whichND($fvi==$_))->slice(':,(1)'); $fn->dice_axis(1,$vfi)->mv(1,0)->sumover->norm } (0..(($v->dims)[1]-1)) ); # ---------------------------------------------------------------------------- return $vn; } # JNK 06dec00 new object type: package PDL::Graphics::TriD::STrigrid; # @ISA=qw/PDL::Graphics::TriD::GPObject/; use base qw/PDL::Graphics::TriD::GPObject/; # use fields qw/.../; sub cdummies { # copied from SLattice_S; not yet modified... # called with (type,colors,faces) return $_[1]->dummy(1,$_[2]->getdim(2))->dummy(1,$_[2]->getdim(1)); } sub get_valid_options { # copied from SLattice_S; not yet modified... return { UseDefcols => 0, Lines => 1, Smooth => 0, Material => 0 }; } ################# JNK 15mar11 added section finis ######################### ########################################################################### package PDL::Graphics::TriD::Lattice; use base qw/PDL::Graphics::TriD::GObject/; sub r_type {return "SURF2D";} sub cdummies { return $_[1]->dummy(1)->dummy(1); } package PDL::Graphics::TriD::Lines; use base qw/PDL::Graphics::TriD::GObject/; sub cdummies { return $_[1]->dummy(1); } sub r_type { return "SURF2D";} sub get_valid_options { return {UseDefcols => 0, LineWidth => 1}; } package PDL::Graphics::TriD::LineStrip; use base qw/PDL::Graphics::TriD::GObject/; sub cdummies { return $_[1]->dummy(1); } sub r_type { return "SURF2D";} sub get_valid_options { return {UseDefcols => 0, LineWidth => 1}; } package PDL::Graphics::TriD::GObject_Lattice; use base qw/PDL::Graphics::TriD::GObject/; sub r_type {return "SURF2D";} sub get_valid_options { return {UseDefcols => 0,Lines => 1}; } # colors associated with vertices, smooth package PDL::Graphics::TriD::SLattice; use base qw/PDL::Graphics::TriD::GObject_Lattice/; sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2)) -> dummy(1,$_[2]->getdim(1)); } # colors associated with surfaces package PDL::Graphics::TriD::SCLattice; use base qw/PDL::Graphics::TriD::GObject_Lattice/; sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2)-1) -> dummy(1,$_[2]->getdim(1)-1); } # colors associated with vertices package PDL::Graphics::TriD::SLattice_S; use base qw/PDL::Graphics::TriD::GObject_Lattice/; use fields qw/Normals/; sub cdummies { return $_[1]->dummy(1,$_[2]->getdim(2)) -> dummy(1,$_[2]->getdim(1)); } sub get_valid_options { return {UseDefcols => 0,Lines => 1, Smooth => 0, Material => 0}; } # calculate smooth normals sub smoothn { my ($this,$p) = @_; # coords of parallel sides (left and right via 'lags') my $trip = $p->lags(1,1,2)->slice(':,:,:,1:-1') - $p->lags(1,1,2)->slice(':,:,:,0:-2'); # coords of diagonals with dim 2 having original and reflected diags my $tmp; my $trid = ($p->slice(':,0:-2,1:-1')-$p->slice(':,1:-1,0:-2')) ->dummy(2,2); # $ortho is a (3D,x-1,left/right triangle,y-1) array that enumerates # all triangles my $ortho = $trip->crossp($trid); $ortho->norm($ortho); # normalise inplace # now add to vertices to smooth my $aver = ref($p)->zeroes($p->dims); # step 1, upper right tri0, upper left tri1 ($tmp=$aver->lags(1,1,2)->slice(':,:,:,1:-1')) += $ortho; # step 2, lower right tri0, lower left tri1 ($tmp=$aver->lags(1,1,2)->slice(':,:,:,0:-2')) += $ortho; # step 3, upper left tri0 ($tmp=$aver->slice(':,0:-2,1:-1')) += $ortho->slice(':,:,(0)'); # step 4, lower right tri1 ($tmp=$aver->slice(':,1:-1,0:-2')) += $ortho->slice(':,:,(1)'); $aver->norm($aver); return $aver; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/OOGL.pm����������������������������������������������������������������0000644�0601750�0601001�00000001531�12562522364�014745� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������package PDL::Graphics::TriD::OOGL; $PDL::Graphics::TriD::create_window_sub = sub { return new PDL::Graphics::TriD::OOGL::Window; }; package PDL::Graphics::TriD::Object; #use PDL::Graphics::OpenGL; BEGIN { use PDL::Config; if ($PDL::Config{USE_POGL}) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; } } use PDL::Graphics::OpenGL::Perl::OpenGL; sub tooogl { my($this) = @_; join "\n",map { $_->togl() } (@{$this->{Objects}}) } package PDL::Graphics::TriD::GL::Window; use FileHandle; sub new {my($type) = @_; my($this) = bless {},$type; } sub update_list { local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager my($this) = @_; my $fh = new FileHandle("|togeomview"); my $str = join "\n",map {$_->tooogl()} (@{$this->{Objects}}) ; print $str; $fh->print($str); } sub twiddle { } �����������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Polygonize.pm����������������������������������������������������������0000644�0601750�0601001�00000005060�12562522364�016345� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# XXXX NOTHING BUT stupidpolygonize WORKS!!!! package PDL::Graphics::TriD::StupidPolygonize; use PDL::Core ''; # A very simplistic polygonizer... # Center = positive, outside = negative. sub stupidpolygonize { my($center, $initrad, $npatches, $nrounds, $func) = @_; $a = PDL->zeroes(PDL::float(),3,$npatches,$npatches); $mult = 2*3.14 / ($npatches-1); my $ya = ($a->slice("(0)"))->xvals; $ya *= $mult; my $za = ($a->slice("(0)"))->yvals; $za *= $mult/2; $za -= 3.14/2; (my $tmp0 = $a->slice("(0)")) += cos($ya); (my $tmp1 = $a->slice("(1)")) += sin($ya); (my $tmp01 = $a->slice("0:1")) *= cos($za)->dummy(0); (my $tmp2 = $a->slice("(2)")) += sin($za); my $add = $a->copy; $a *= $initrad; $a += $center; my $cur = $initrad; my $inita = $a->copy; for(1..$nrounds) { $cur /= 2; $vp = $func->($a); my $vps = ($vp > 0); $vps -= 0.5; $vps *= 2; $a += $vps->dummy(0) * $cur * $add; } return $a; } sub polygonizeraw { my($data,$coords) = @_; } sub contours { } package PDL::Graphics::TriD::ContourPolygonize; # # First compute contours. use vars qw/$cube $cents/; $cube = PDL->pdl([ [-1,-1,-1], [-1,-1,1], [-1,1,-1], [-1,1,1], [1,-1,-1], [1,-1,1], [1,1,-1], [1,1,1] ]); $cents = PDL->pdl([ [0,0,-1], [0,0,1], [0,-1,0], [0,1,0], [-1,0,0], [1,0,0], ]); sub contourpolygonize { my($in,$oscale,$scale,$func) = @_; my $ccube = $cube * $oscale; my $maxstep=0; while(($func->($ccube)>=0)->sum > 0) { $ccube *= 1.5; if($maxstep ++ > 30) { die("Too far inside"); } } # Now, we have a situation with a cube that has inside a I point # and as corners O points. This does not guarantee that we have all # the surface but it's enough for now. } ############# #sub trianglepolygonize { # # find_3nn( #} package PDL::Graphics::TriD::Polygonize; use PDL::Core ''; # Inside positive, outside negative! # # XXX DOESN'T WORK sub polygonize { my($inv,$outv,$cubesize,$func) = @_; barf "Must be positive" if $cubesize <= 0; my $iv = $func->($inv); my $ov = $func->($outv); my $s; # Find a close enough point to zero. while(((sqrt(($iv-$ov))**2))->sum > $cubesize) { my $s = $iv + $ov; $s /= 2; my $v = $func->($s); $v->sum < 0 ? $ov = $s : $iv = $s; } # Correct the smaller distance to cubesize. $iv = $ov + ($iv-$ov) * $cubesize / sqrt(($iv-$ov)**2) # If it went outside, do it the other way around. # if($func->($iv)->sum < 0) { # $ov = $iv + ($ov-$iv) * $cubesize / sqrt(($iv-$ov)**2) # } # Now, |$iv-$ov| = $cubesize # Make the first cube # Then, start the cubes march. } # Cube coordinates. sub marchcubes { my($init) = @_; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Quaternion.pm����������������������������������������������������������0000644�0601750�0601001�00000007704�12562522364�016342� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������############################################## # # Quaternions... inefficiently. # # Should probably use PDL and C... ? # # Stored as [c,x,y,z]. # # XXX REMEMBER!!!! First component = cos(angle*2), *NOT* cos(angle) package PDL::Graphics::TriD::Quaternion; sub new { my($type,$c,$x,$y,$z) = @_; my $this; if(ref($type)){ $this = $type; }else{ $this = bless [$c,$x,$y,$z],$type; } return $this; } sub copy { return new PDL::Graphics::TriD::Quaternion(@{$_[0]}); } sub new_vrmlrot { my($type,$x,$y,$z,$a) = @_; my $l = sqrt($x**2+$y**2+$z**2); my $this = bless [cos($a/2),map {sin($a/2)*$_/$l} $x,$y,$z],$type; $this->normalize_this(); return $this; } sub to_vrmlrot { my($this) = @_; my $d = POSIX::acos($this->[0]); if(abs($d) < 0.0000001) { return [0,0,1,0]; } return [(map {$_/sin($d)} @{$this}[1..3]),2*$d]; } # Yuck sub multiply { my($this,$with) = @_; return PDL::Graphics::TriD::Quaternion->new( $this->[0] * $with->[0] - $this->[1] * $with->[1] - $this->[2] * $with->[2] - $this->[3] * $with->[3], $this->[2] * $with->[3] - $this->[3] * $with->[2] + $this->[0] * $with->[1] + $this->[1] * $with->[0], $this->[3] * $with->[1] - $this->[1] * $with->[3] + $this->[0] * $with->[2] + $this->[2] * $with->[0], $this->[1] * $with->[2] - $this->[2] * $with->[1] + $this->[0] * $with->[3] + $this->[3] * $with->[0], ); } sub multiply_scalar { my($this,$scalar) = @_; my $ang = POSIX::acos($this->[0]); my $d = sin($ang); if(abs($d) < 0.0000001) { return new PDL::Graphics::TriD::Quaternion(1,0,0,0); } $ang *= $scalar; my $d2 = sin($ang); return new PDL::Graphics::TriD::Quaternion( cos($ang), map {$_*$d2/$d} @{$this}[1..3] ); } sub set { my($this,$new) = @_; @$this = @$new; } sub add { my($this,$with) = @_; return PDL::Graphics::TriD::Quaternion->new( $this->[0] * $with->[0], $this->[1] * $with->[1], $this->[2] * $with->[2], $this->[3] * $with->[3]); } sub abssq { my($this) = @_; return $this->[0] ** 2 + $this->[1] ** 2 + $this->[2] ** 2 + $this->[3] ** 2 ; } sub invert { my($this) = @_; my $abssq = $this->abssq(); return PDL::Graphics::TriD::Quaternion->new( 1/$abssq * $this->[0] , -1/$abssq * $this->[1] , -1/$abssq * $this->[2] , -1/$abssq * $this->[3] ); } sub invert_rotation_this { my($this) = @_; $this->[0] = - $this->[0]; } sub normalize_this { my($this) = @_; my $abs = sqrt($this->abssq()); @$this = map {$_/$abs} @$this; } sub rotate { my($this,$vec) = @_; my $q = (PDL::Graphics::TriD::Quaternion)->new(0,@$vec); my $m = $this->multiply($q->multiply($this->invert)); return [@$m[1..3]]; } sub rotate_foo { my ($this,$vec) = @_; # print "CP: ",(join ',',@$this)," and ",(join ',',@$vec),"\n"; return $vec if $this->[0] == 1 or $this->[0] == -1; # 1. cross product of my vector and rotated vector # XXX I'm not sure of any signs! my @u = @$this[1..3]; my @v = @$vec; my $tl = sqrt($u[0]**2 + $u[1]**2 + $u[2]**2); my $up = sqrt($v[0]**2 + $v[1]**2 + $v[2]**2); my @cp = ( $u[1] * $v[2] - $u[2] * $v[1], $u[0] * $v[2] - $u[2] * $v[0], $u[0] * $v[1] - $u[1] * $v[0], ); # Cross product of this and my vector my @cp2 = ( $u[1] * $cp[2] - $u[2] * $cp[1], $u[0] * $cp[2] - $u[2] * $cp[0], $u[0] * $cp[1] - $u[1] * $cp[0], ); my $cpl = 0.00000001 + sqrt($cp[0]**2 + $cp[1]**2 + $cp[2]**2); my $cp2l = 0.0000001 + sqrt($cp2[0]**2 + $cp2[1]**2 + $cp2[2]**2); for(@cp) {$_ /= $cpl} for(@cp2) {$_ /= $cp2l} my $mult1 = $up * sqrt(1-$this->[0]**2); # my $mult1 = $up * sqrt(1-$this->[0]**2); my $mult2 = $up * $this->[0]; print "ME: ",(join ' ',@u),"\n"; print "VEC: ",(join ' ',@v),"\n"; print "CP: ",(join ' ',@cp),"\n"; print "CP2: ",(join ' ',@cp2),"\n"; print "MULT1: $mult1, MULT2: $mult2\n"; print "CPL: ",$cpl, " TL: $tl CPLTL: ",$cpl/$tl,"\n"; my $res = [map { $v[$_] + $mult1 * $cp[$_] + ($mult2 - $cpl/$tl)* $cp2[$_] } 0..2]; # print "RES: ",(join ',',@$res),"\n"; return $res; } 1; ������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/SimpleScaler.pm��������������������������������������������������������0000644�0601750�0601001�00000003051�12562522364�016567� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������###################################################################### ###################################################################### ## ScaleController -- this is the module that controls 3-D window scaling ## when you drag the mouse in the display window. package PDL::Graphics::TriD::ScaleController; use base qw/PDL::Graphics::TriD::ButtonControl/; use fields qw/Dist/; sub new { my($type,$win,$dist) = @_; my $this = $type->SUPER::new( $win); $this->{Dist} = $dist; $win->add_resizecommand(sub {print "Resized window: ",join(",",@_),"\n" if $PDL::debug_trid; $this->set_wh(@_); }); return $this; } # coordinates normalised relative to center sub xy2norm { my($this,$x,$y) = @_; print "xy2norm: this->{W}=$this->{W}; this->{H}=$this->{H}; this->{SC}=$this->{SC}\n" if($PDL::Graphics::TriD::verbose); $x -= $this->{W}/2; $y -= $this->{H}/2; $x /= $this->{SC}; $y /= $this->{SC}; return ($x,$y); } sub mouse_moved { my($this,$x0,$y0,$x1,$y1) = @_; # $this->{Dist} *= ${$this->{Dist}} *= $this->xy2fac($this->xy2norm($x0,$y0),$this->xy2norm($x1,$y1)); } ############################################################## # # a very simple unsophisticated scaler that # takes advantage of the nice infrastructure provided by # TJL # ############################################################## package PDL::Graphics::TriD::SimpleScaler; use base qw/PDL::Graphics::TriD::ScaleController/; # x,y to distance from center sub xy2fac { my($this,$x0,$y0,$x1,$y1) = @_; my $dy = $y0-$y1; return $dy>0 ? 1+2*$dy : 1/(1-2*$dy); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/Surface.pm�������������������������������������������������������������0000644�0601750�0601001�00000001601�12562522364�015573� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������� package PDL::Graphics::TriD::Surface; BEGIN { use PDL::Config; if ( $PDL::Config{USE_POGL} ) { eval "use OpenGL $PDL::Config{POGL_VERSION} qw(:all)"; eval 'use PDL::Graphics::OpenGL::Perl::OpenGL'; } else { eval 'use PDL::Graphics::OpenGL'; } } use PDL::Lite; sub new { my($nvertices,$nfaces,$nvertpface) = @_; my $this = { NVertices => $nvertices, NFaces => $nfaces, NVPF => $nvertpface, Vertices => zeroes(3,$nvertices), Faces => -1*ones($nvertices,$nvertpface) }; } # XXX Refit to use sub new_pdl2d { my($pdl,%opts) = @_; defined($opts{X}) or $opts{X} = xvals zeroes $pdl->getdim(0); defined($opts{Y}) or $opts{Y} = xvals zeroes $pdl->getdim(1); } # Make normals as with no shared vertices. # 1 normal / face. sub normals_flat { } # Make normals as with round objects # 1 normal / vertice sub normals_smooth { } sub togl { } 1; �������������������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/TextObjects.pm���������������������������������������������������������0000644�0601750�0601001�00000000613�12562522364�016443� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# These objects contain textual descriptions of the graph. # Placed suitably in relation to origin to be used with a graph. package PDL::Graphics::TriD::Description; @ISA=qw/PDL::Graphics::TriD::Object/; sub new { my($type,$text) = @_; local $_ = $text; s/\\/\\\\/g; s/"/\\"/g; my $this = bless { TText => "[".(join ',',map {"\"$_\""} split "\n",$_)."]" },$type; return $this; } 1; ���������������������������������������������������������������������������������������������������������������������PDL-2.018/Graphics/TriD/TriD/ViewPort.pm������������������������������������������������������������0000644�0601750�0601001�00000003761�12562522364�015773� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # The PDL::Graphics::TriD::ViewPort is already partially defined in # the appropriate gdriver (GL or VRML), items defined here are common # to both # package PDL::Graphics::TriD::ViewPort; use strict; sub new { my($type,$x0,$y0,$w,$h) = @_; my $this= $type->SUPER::new(); $this->{X0} = $x0; $this->{Y0} = $y0; $this->{W} = $w; $this->{H} = $h; $this->{DefMaterial} = new PDL::Graphics::TriD::Material; return $this; } sub graph { my($this,$graph) = @_; if(defined($graph)){ $this->add_object($graph); push(@{$this->{Graphs}},$graph); }elsif(defined $this->{Graphs}){ $graph = $this->{Graphs}[0]; } return($graph); } sub delete_graph { my($this,$graph) = @_; $this->delete_object($graph); for(0..$#{$this->{Graphs}}){ if($graph == $this->{Graphs}[$_]){ splice(@{$this->{Graphs}},$_,1); redo; } } } sub resize { my($this,$x0,$y0,$w,$h) = @_; $this->{X0} = $x0; $this->{Y0} = $y0; $this->{W} = $w; $this->{H} = $h; return $this; } sub add_resizecommand { my($this,$com) = @_; push @{$this->{ResizeCommands}},$com; print "ARC: $this->{W},$this->{H}\n" if($PDL::Graphics::TriD::verbose); &$com($this->{W},$this->{H}); } sub set_material { $_[0]->{DefMaterial} = $_[1]; } sub eventhandler { my ($this,$eh) = @_; if(defined $eh){ $this->{EHandler} = $eh; } return $this->{EHandler}; } sub set_transformer { $_[0]->transformer($_[1]); } sub transformer { my ($this,$t) = @_; if(defined $t){ $this->{Transformer} = $t; } return $this->{Transformer}; } # # restore the image view to a known value # sub setview{ my($vp,$view) = @_; my $transformer = $vp->transformer(); if(ref($view) eq "ARRAY"){ $transformer->set({WRotation=>$view}); }elsif($view eq "Top"){ $transformer->set({WRotation=>[1,0,0,0]}); }elsif($view eq "East"){ $transformer->set({WRotation=>[0.5,-0.5,-0.5,-0.5]}); }elsif($view eq "South"){ $transformer->set({WRotation=>[0.6,-0.6,0,0]}); } } 1; ���������������PDL-2.018/Graphics/TriD/TriD/VRML.pm����������������������������������������������������������������0000644�0601750�0601001�00000047776�12562522364�015012� 0����������������������������������������������������������������������������������������������������ustar �chm�����������������������������None�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME PDL::Graphics::TriD::VRML -- TriD VRML backend =head1 SYNOPSIS BEGIN { $PDL::Graphics::TriD::device = "VRML"; } use PDL::Graphics::TriD; use PDL::LiteF; # set some vrml parameters my $set = tridsettings(); # get the defaults $set->browser_com('netscape/unix'); $set->compress(); $set->file('/www-serv/vrml/dynamic_scene.wrl.gz'); line3d([$x,$y,$z]); # plot some lines and view the scene with a browser =head1 DESCRIPTION This module implements the VRML for PDL::Graphics::TriD (the generic 3D plotting interface for PDL). You can use this backend either (a) for generating 3D graphics on your machine which can be directly viewed with a VRML browser or (b) generate dynamic VRML worlds to distribute over the web. With VRML, you can generate objects for everyone to see with e.g. Silicon Graphics' Cosmo Player. You can find out more about VRML at C<http://vrml.sgi.com/> or C<http://www.vrml.org/> =cut #' ################################### ## package PDL::Graphics::TriD::VRML; use PDL::Core ''; # barf use PDL::Graphics::VRML; use PDL::LiteF; use PDL::Config; PDL::Graphics::VRMLNode->import(); PDL::Graphics::VRMLProto->import(); $PDL::homepageURL = 'http://pdl.perl.org/'; sub PDL::Graphics::TriD::Logo::tovrml { my ($this) = @_; my ($p,$tri) = ("",""); PDL::Graphics::VRMLPdlNode::v3array($this->{Points},\$p,""); PDL::Graphics::VRMLPdlNode::triangles((map {$this->{Index}->slice("($_)")} (0..2)),\$tri,""); my $indface = vrn('IndexedFaceSet', 'coord' => vrn('Coordinate', 'point' => "[ $p ]"), 'coordIndex' => "[ $tri ]", 'solid' => 'TRUE'); return vrn('Transform', 'children' => [vrn('Anchor', 'description' => "\"The PDL Homepage\"", 'url' => "\"$PDL::homepageURL\"", 'children' => vrn('Shape', 'appearance' => vrn('Appearance', 'material' => $this->{Material}->tovrml), 'geometry' => $indface)), vrn(Viewpoint, position => '0 0 25', description => "\"PDL Logo\"" ) ], 'translation' => vrml3v($this->{Pos}), 'scale' => vrml3v([map {$this->{Size}} (0..2)])); } sub PDL::Graphics::TriD::Description::tovrml { my($this) = @_; # print "DESCRTIPTION : TOVRML\n"; return vrn(Transform, rotation => '1 0.1 0 1.1', translation => '1.5 0 0.5', children => [ vrn(Shape, geometry => vrn(Text, string => $this->{TText}, fontStyle => vrn(FontStyle, 'family' => "\"SANS\"", size => '0.075', spacing => '1.33', justify => '["BEGIN","MIDDLE"]' ), ), appearance => vrn(Appearance, material => vrn(Material, diffuseColor => '0.9 0.9 0.9', ambientIntensity => '0.1' ) ) ), vrn(Viewpoint, position => '0 0 3', description => "\"Description\"" ) ] ); } sub PDL::Graphics::VRML::vrmltext { my ($this,$text,$coords) = @_; $this->uses('TriDGraphText'); return vrn('TriDGraphText', 'text' => "\"$text\"", 'position' => vrml3v($coords)); } sub PDL::Graphics::TriD::Material::tovrml { my $this = shift; my $ambi = (pdl(@{$this->{Ambient}})**2)->sum / (pdl(@{$this->{Diffuse}})**2)->sum; $ambi = sqrt($ambi); new PDL::Graphics::VRMLNode('Material', 'diffuseColor' => vrml3v($this->{Diffuse}), 'emissiveColor' => vrml3v($this->{Emissive}), 'shininess' => $this->{Shine}, 'ambientIntensity' => $ambi, 'specularColor' => vrml3v($this->{Specular}), ); } sub PDL::Graphics::TriD::Scale::tovrml {my ($this) = @_; print "Scale ",(join ',',@{$this->{Args}}),"\n"; new PDL::Graphics::VRMLNode('Transform', 'scale',vrml3v(@{$this->{Args}})); } sub PDL::Graphics::TriD::Translation::tovrml { my ($this) = @_; new PDL::Graphics::VRMLNode('Transform', 'translation',vrml3v(@{$this->{Args}})); } # XXXXX this has to be fixed -> wrap in one transform + children sub PDL::Graphics::TriD::Transformation::tovrml { my($this) = @_; my @nodes = map {$_->tovrml()} @{$this->{Transforms}}; push @nodes,$this->SUPER::tovrml(); } sub PDL::Graphics::TriD::Quaternion::tovrml {my($this) = @_; if(abs($this->[0]) == 1) { return ; } if(abs($this->[0]) >= 1) { # die "Unnormalized Quaternion!\n"; $this->normalize_this(); } new PDL::Graphics::VRMLNode('Transform', 'rotation',vrml3v(@{$this}[1..3])." $this->[0]"); } # this 'poor mans viewport' implementation makes an image from its objects # and writes it as a gif file sub PDL::Graphics::TriD::ViewPort::togif_vp { require PDL::IO::Pic; my ($this,$win,$rec,$file) = @_; my $p; # this needs more thinking for (@{$this->{Objects}}) { barf "can't display object type" unless $_->can('toimage'); $p = $_->toimage; } $p->wpic($file); } sub PDL::Graphics::TriD::GObject::tovrml { return $_[0]->vdraw($_[0]->{Points}); } sub PDL::Graphics::TriD::GObject::tovrml_graph { return $_[0]->vdraw($_[2]); } sub PDL::Graphics::TriD::Points::vdraw { my($this,$points) = @_; new PDL::Graphics::VRMLNode('Shape', 'geometry' => new PDL::Graphics::VRMLPdlNode($points,$this->{Colors}, {Title => 'PointSet', DefColors => $this->defcols})); } sub PDL::Graphics::TriD::LineStrip::vdraw { my($this,$points) = @_; new PDL::Graphics::VRMLNode('Shape', 'geometry' => new PDL::Graphics::VRMLPdlNode($points,$this->{Colors}, {Title => 'IndexedLineSet', DefColors => $this->defcols})); } sub PDL::Graphics::TriD::Lattice::vdraw { my($this,$points) = @_; new PDL::Graphics::VRMLNode('Shape', 'geometry' => new PDL::Graphics::VRMLPdlNode($points,$this->{Colors}, {Title => 'IndexedLineSet', DefColors => $this->defcols, IsLattice => 1})); } sub PDL::Graphics::TriD::SLattice::vdraw { my($this,$points) = @_; my $children = [vrn('Shape', 'geometry' => new PDL::Graphics::VRMLPdlNode($points,$this->{Colors}, {Title => 'IndexedFaceSet', DefColors => $this->defcols, IsLattice => 1, }))]; push @$children, vrn('Shape', 'geometry' => new PDL::Graphics::VRMLPdlNode($points,$this->{Colors}, {Title => 'IndexedLineSet', DefColors => 0, Surface => 1, Lines => 1, IsLattice => 1, })) if $this->{Options}->{Lines}; vrn('Group', 'children' => $children); } sub PDL::Graphics::TriD::SLattice_S::vdraw { my($this,$points) = @_; my $vp = &PDL::Graphics::TriD::get_current_window()->current_viewport; my $mat = $vp->{DefMaterial}->tovrml; my $children = [vrn('Shape', 'appearance' => vrn('Appearance', 'material' => $mat), 'geometry' => new PDL::Graphics::VRMLPdlNode($points,$this->{Colors}, {Title => 'IndexedFaceSet', DefColors => 1, IsLattice => 1, Smooth => $this->{Options}->{Smooth}, }))]; push @$children, vrn('Shape', 'geometry' => new PDL::Graphics::VRMLPdlNode($points,$this->{Colors}, {Title => 'IndexedLineSet', DefColors => 0, Surface => 1, Lines => 1, IsLattice => 1, })) if $this->{Options}->{Lines}; vrn('Group', 'children' => $children); } ################################## # PDL::Graphics::TriD::Image # # sub PDL::Graphics::TriD::Image::tovrml { $_[0]->vdraw(); } sub PDL::Graphics::TriD::Image::tovrml_graph { &PDL::Graphics::TriD::Image::tovrml; } # The quick method is to use texturing for the good effect. # XXXXXXXXXXXX wpic currently rescales $im 0..255, that's not correct (in $url->save)! fix sub PDL::Graphics::TriD::Image::vdraw { my ($this,$vert) = @_; my $p = $this->flatten(0); # no binary alignment if(!defined $vert) {$vert = $this->{Points}} my $url = new PDL::Graphics::TriD::VRML::URL('image/JPG'); $url->save($p); vrn('Shape', 'appearance' => vrn('Appearance', 'texture' => vrn('ImageTexture', 'url' => '"'.$url->totext.'"')), 'geometry' => vrn('IndexedFaceSet', 'coord' => vrn('Coordinate', 'point' => [map {vrml3v([$vert->slice(":,($_)")->list])} (0..3)]), 'coordIndex' => '[0, 1, 2, 3, -1]', 'solid' => 'FALSE'), ); } sub PDL::Graphics::TriD::Graph::tovrml { my($this) = @_; my @children = (); for(keys %{$this->{Axis}}) { if($_ eq "Default") {next} push @children, @{$this->{Axis}{$_}->tovrml_axis($this)}; } for(keys %{$this->{Data}}) { push @children, $this->{Data}{$_}->tovrml_graph($this,$this->get_points($_)); } return vrn('Group', 'children' => [@children]); } sub PDL::Graphics::TriD::EuclidAxes::tovrml_axis { my($this,$graph) = @_; my $vrml = $PDL::Graphics::VRML::cur; my $lset = vrn('Shape', 'geometry' => vrn('IndexedLineSet', 'coord', vrn('Coordinate', 'point',["0 0 0", "1 0 0", "0 1 0", "0 0 1"]), 'coordIndex',["0,1,-1", "0,2,-1", "0,3,-1"])); my ($vert,$indx,$j) = ([],[],0); my @children = ($lset); for $dim (0..2) { my @coords = (0,0,0); my @coords0 = (0,0,0); for(0..2) { if($dim != $_) { $coords[$_] -= 0.1 } } my $s = $this->{Scale}[$dim]; my $ndiv = 3; my $radd = 1.0/$ndiv; my $nadd = ($s->[1]-$s->[0])/$ndiv; my $nc = $s->[0]; for(0..$ndiv) { push @children, $vrml->vrmltext(sprintf("%.3f",$nc),[@coords]); push @$vert,(vrml3v([@coords0]),vrml3v([@coords])); push @$indx,$j++.", ".$j++.", -1"; $coords[$dim] += $radd; $coords0[$dim] += $radd; $nc += $nadd; } $coords0[$dim] = 1.1; push @children, $vrml->vrmltext($this->{Names}[$dim],[@coords0]); } push @children, vrn('Shape', 'geometry' => vrn('IndexedLineSet', 'coord' => vrn('Coordinate', 'point' => $vert), 'coordIndex' => $indx)); return [@children]; } sub PDL::Graphics::TriD::SimpleController::tovrml { # World origin is disregarded XXXXXXX my $this = shift; my $inv = new PDL::Graphics::TriD::Quaternion(@{$this->{WRotation}}); $inv->invert_rotation_this; my $pos = $inv->rotate([0,0,1]); # print "SC: POS0:",(join ',',@$pos),"\n"; for (@$pos) { $_ *= $this->{CDistance}} # print "SC: POS:",(join ',',@$pos),"\n"; # ASSUME CRotation 0 for now return vrn('Viewpoint', 'position' => vrml3v($pos), # 'orientation' => vrml3v(@{$this->{CRotation}}[1..3]). # " $this->{CRotation}->[0]", 'orientation' => vrml3v([@{$inv}[1..3]])." ". -atan2(sqrt(1-$this->{WRotation}[0]**2), $this->{WRotation}[0]), 'description' => "\"Home\""); } package #split this line so the # CPAN indexer doesn't complain Win32; sub Win32::fn_win32_format { my ($file) = @_; $file =~ s|\\|/|g; $file = "//$file" if $file =~ m|^[a-z,A-Z]+:|; return $file; } package Win32::DDE::Netscape; use PDL::Core ''; # barf require Win32::DDE::Client if $^O =~ /win32/i; sub checkerr { my $this = shift; if ($this->Error) { print Win32::DDE::ErrorText($this->Error), "\n# ", $this->ErrorText; barf "client: couldn't connect to netscape"; } return $this; } sub activate { my $client = new Win32::DDE::Client ('Netscape','WWW_Activate'); checkerr($client); $client->Request('0xFFFFFFFF,0x0'); barf "can't disconnect" unless $client->Disconnect; } sub geturl { my ($url) = @_; my $client = new Win32::DDE::Client ('Netscape','WWW_OpenURL'); checkerr($client); $status = $client->Request("\"$url\",,0xFFFFFFFF,0x1"); barf "can't disconnect" unless $client->Disconnect; } package PDL::Graphics::TriD::VRML::Parameter; use PDL::Core ''; # barf sub new { my ($type,%hash) = @_; my $this = bless {},$type; $this->{Mode} = 'VRML'; for (keys %hash) { $this->{$_} = $hash{$_} } return $this; } sub gifmode { my ($this) = @_; $this->{Mode} = 'GIF'; } sub vrmlmode { my ($this) = @_; $this->{Mode} = 'VRML'; } sub set { my ($this,%hash) = @_; for (keys %hash) { $this->{$_} = $hash{$_} } return $this; } sub browser { my ($this) = @_; $this->{'Browser'} = $_[1] if $#_ > 0; return $this->{'Browser'}; } sub file { my ($this) = @_; if ($#_ > 0) { $this->{'GifFile'} = $_[1]; $this->{'GifFile'} =~ s/[.][^.]+$/.gif/; $this->{'HTMLFile'} = $_[1]; $this->{'HTMLFile'} =~ s/[.][^.]+$/.html/; $this->{'File'} = $_[1]; $this->{'File'} =~ s/[.][^.]+$/.wrl/; } if ($this->{Mode} eq 'VRML') { return $this->{'File'}; } elsif ($this->{Mode} eq 'GIF') { return $this->{'HTMLFile'}; } else { barf "wfile error: unknown mode"; } } sub wfile { my ($this) = @_; my $file = $this->{Mode} eq 'GIF' ? $this->{GifFile} : $this->{File}; if (defined $this->{Compress} && $this->{Compress}) { $file .= '.gz' unless $file =~ /[.]gz$/; $this->file($file); $file = '|gzip -c' . ($file =~ /^\s*>/ ? '' : '>') . $file; } return $file; } $PDL::Graphics::TriD::VRML::Parameter::lastfile = ''; my %subs = ( 'netscape/unix' => sub {my $file = $_[0]->file; my $cmd; if ($file eq $PDL::Graphics::TriD::VRML::Parameter::lastfile) { $cmd = 'reload' } else { my $target = $#_ > 0 ? "#$_[1]" : ''; $cmd = "openURL(file:$file$target)"} system('netscape','-remote',$cmd); $PDL::Graphics::TriD::VRML::Parameter::lastfile = $file}, 'netscape/win32' => sub {my $file = $_[0]->file; $file = Win32::fn_win32_format $file; Win32::DDE::Netscape::activate; my $target = $#_ > 0 ? "#$_[1]" : ''; Win32::DDE::Netscape::geturl("file:$file$target"); }, 'none' => sub {print STDERR "not sending it anywhere\n"}, ); sub browser_com { my ($this,$browser) = @_; barf("unknown browser '$browser'") unless defined $subs{$browser}; $this->{'Browser'} = $subs{$browser}; } sub send_to_browser {my $this=$_[0]; &{$this->{'Browser'}}(@_) if defined $this->{'Browser'}} package PDL::Graphics::TriD::VRML::URL; use PDL::Core ''; # barf my %types = ( 'image/JPG' => {'save' => sub {local $PDL::debug=0; $_[1]->wpic($_[0]->wfile)}, 'ext' => 'jpg', 'setup' => sub {require PDL::IO::Pic}, }, ); my $urlnum = 0; sub new { my ($type,$mime) = @_; my $this = bless {},$type; barf "unknown mime type '$mime'" unless defined $types{$mime}; $this->{'Type'} = $types{$mime}; &{$this->{'Type'}->{'setup'}} if defined $this->{'Type'}->{'setup'}; $this->{'Binding'} = 'local'; $this->{'Filestem'} = $PDL::Config{TEMPDIR} . "/tridim_$urlnum"; $urlnum++; return $this; } sub wfile { my ($this) = @_; return $this->{'Filestem'}.'.'.$this->{'Type'}->{'ext'}; } sub totext { my ($this) = @_; my $proto; if ($this->{'Binding'} eq 'local') { $proto = 'file' } elsif ($this->{'Binding'} eq 'publish') { $proto = 'http'; barf "not yet implemented" } else { barf "unknown binding" } return "$proto:".$this->wfile; } sub save { &{$_[0]->{Type}->{save}}(@_) } package PDL::Graphics::TriD::VRML; $PDL::Graphics::VRML::cur = undef; $PDL::Graphics::TriD::create_window_sub = sub { return new PDL::Graphics::TriD::Window; }; # set up the default parameters for VRML my $tmpdir = $PDL::Config{TEMPDIR} || die "TEMPDIR not found in %PDL::Config"; my $tmpname = "$tmpdir/tridvrml_$$.wrl"; my $para = $PDL::Graphics::TriD::Settings = PDL::Graphics::TriD::VRML::Parameter->new() ; $para->file($tmpname); $para->browser_com($^O =~ /win32/i ? 'netscape/win32' : 'none'); package PDL::Graphics::TriD::VRMLObject; use base qw/PDL::Graphics::TriD::Object/; use fields qw/Node/; sub new { my($type,$node) = @_; my $this = $type->SUPER::new(); $this->{Node} = $node; return $this; } sub tovrml { return $_[0]->{Node}; } #package PDL::Graphics::TriD::VRML::Window; package PDL::Graphics::TriD::Window; use PDL::Graphics::TriD::Control3D; PDL::Graphics::VRMLNode->import(); PDL::Graphics::VRMLProto->import(); use PDL::Core ''; # barf use base qw/PDL::Graphics::TriD::Object/; use fields qw/Width Height Interactive _ViewPorts _CurrentViewPort VRMLTop DefMaterial/; use strict; sub gdriver { my($this) = @_; require PDL::Version if not defined $PDL::Version::VERSION; $this->{Width} = 300; $this->{Height} = 300; $this->{VRMLTop} = new PDL::Graphics::VRML("\"PDL::Graphics::TriD::VRML Scene\"", ["\"generated by the PDL::Graphics::TriD module\"", "\"version $PDL::Version::VERSION\""]); my $fontstyle = new PDL::Graphics::VRMLNode('FontStyle', 'size' => 0.04, 'family' => "\"SANS\"", 'justify' => "\"MIDDLE\""); $PDL::Graphics::TriD::VRML::fontstyle = $fontstyle; $this->{VRMLTop}->add_proto(PDL::Graphics::TriD::SimpleController->new->tovrml); $PDL::Graphics::VRML::cur = $this->{VRMLTop}; $this->{VRMLTop}->register_proto( vrp('TriDGraphText', [fv3f('position',"0 0 0"), fmstr('text')], vrn('Transform', 'translation' => "IS position", 'children' => [vrn('Billboard', 'axisOfRotation' => '0 0 0', 'children' => [vrn('Shape', 'geometry' => vrn('Text', 'string' => "IS text", 'fontStyle' => $fontstyle))])]))); return 0; } #sub set_material { # $_[0]->{DefMaterial} = $_[1]; #} # we only allow [0,0,1,1] viewports and just write a gif of the write size # for any children sub new_viewport { my($this,$x0,$y0,$x1,$y1) = @_; # print STDERR "Installing new viewport\n"; barf "only allowing [0,1,0,1] viewports with VRML backend" if abs(PDL->pdl($x0,$y0,$x1-1,$y1-1))->max > 0.01; my $vp = new PDL::Graphics::TriD::ViewPort($x0,$y0,$x1,$y1); push @{$this->{_ViewPorts}},$vp; return $vp; } sub clear_viewports { my($this) = @_; $this->{_ViewPorts} = []; } sub display { my $this = shift; my $vrmlparam = $PDL::Graphics::TriD::Settings; # if (@{$this->{_ViewPorts}}) { if (0) { # show the image $vrmlparam->gifmode(); # print STDERR "writing a GIF image\n"; # print STDERR "Filename: ",$vrmlparam->wfile,"\n"; for(@{$this->{_ViewPorts}}) { $_->togif_vp($this,$_,$vrmlparam->wfile); } my ($hfile,$gfile) = ($vrmlparam->file,$vrmlparam->wfile); $hfile = '>'.$hfile unless $hfile =~ /^\s*[>|]/; $gfile = Win32::fn_win32_format($gfile) if $^O =~ /win32/i; open HTML, $hfile or barf "couldn't open html file $hfile"; print HTML <<"EOH"; <HTML> <HEAD> <TITLE> PDL::Graphics::TriD Display Gif image{H} WIDTH=$this->{W}> EOH close HTML; $vrmlparam->send_to_browser(); } else { # a 'normal' world # print STDERR "printing a VRML world\n"; # print STDERR "Filename: ",$vrmlparam->wfile,"\n"; my $vp = $this->current_viewport; $vp->tovrml; if ($vp->{Transformer}) { $this->{VRMLTop}->addview($vp->{Transformer}->tovrml) } $this->{VRMLTop}->ensure_protos(); # use Data::Dumper; # my $out = Dumper($this->{VRML}); # print $out; $this->{VRMLTop}->set_vrml($vp->{VRML}); $vrmlparam->vrmlmode(); local $| = 1; print "*********starting output\n"; $this->{VRMLTop}->print($vrmlparam->wfile); print "*********finished output\n"; $vrmlparam->send_to_browser('Home'); #XXX make target selectable } } sub twiddle { my $this = shift; if ($PDL::Graphics::TriD::keeptwiddling) { $this->display(); print "---- (press enter)"; <> } # should probably wait for input of character 'q' ? } package PDL::Graphics::TriD::ViewPort; use base qw/PDL::Graphics::TriD::Object/; use fields qw/X0 Y0 W H Transformer EHandler Active ResizeCommands DefMaterial AspectRatio Graphs/; 1; =head1 BUGS Probably incomplete/buggy implementation of some TriD features. =head1 AUTHOR Copyright (C) 1997, 1998 Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut PDL-2.018/Graphics/TriD/TriD/Window.pm0000644060175006010010000001302412776222612015454 0ustar chmNone# # The PDL::Graphics::TriD::Window is already partially defined in # the appropriate gdriver (GL or VRML) items defined here are common # to both # # A function declaration so indirect object method works when defining $ev # in new_viewport: sub PDL::Graphics::TriD::EventHandler::new; package PDL::Graphics::TriD::Window; use PDL::Graphics::TriD::ViewPort; use Data::Dumper; use strict; sub new { my($arg,$options) = @_; print "PDL::Graphics::TriD::Window - calling SUPER::new...\n" if($PDL::debug_trid); my $this = $arg->SUPER::new(); print "PDL::Graphics::TriD::Window - got back $this\n" if($PDL::debug_trid); # Make sure the Graphics has been initialized $options->{width} = 300 unless defined $options->{width}; $options->{height} = 300 unless defined $options->{height}; $this->{Width} = $options->{width}; $this->{Height} = $options->{height}; print "PDL::Graphics::TriD::Window: calling gdriver....\n" if($PDL::debug_trid); $this->{Interactive} = $this->gdriver($options); print "PDL::Graphics::TriD::Window: gdriver gave back $this->{Interactive}....\n" if($PDL::debug_trid); # set default values if($this->{Interactive}){ print "\tIt's interactive... calling ev_defaults...\n" if($PDL::debug_trid); $this->{Ev} = $this->ev_defaults(); print "\tcalling new_viewport...\n" if($PDL::debug_trid); $this->new_viewport(0,0,$this->{Width},$this->{Height}); }else{ $this->new_viewport(0,0,1,1); } $this->current_viewport(0); return($this); } # # adds to all viewports # sub add_object { my($this,$object) = @_; # print "add_object ",ref($this),"\n"; for(@{$this->{_ViewPorts}}) { $_->add_object($object); } } sub new_viewport { my($this,$x0,$y0,$x1,$y1, $options) = @_; my $vp = new PDL::Graphics::TriD::ViewPort($x0,$y0,$x1,$y1); # print "Adding viewport $x0,$y0,$x1,$y1\n" if($PDL::Graphics::TriD::verbose); push @{$this->{_ViewPorts}}, $vp; # if($this->{Interactive} ){ # set a default controller use PDL::Graphics::TriD::ArcBall; use PDL::Graphics::TriD::SimpleScaler; use PDL::Graphics::TriD::Control3D; if (defined($PDL::Graphics::TriD::offline) and $PDL::Graphics::TriD::offline==1 ) { eval "use PDL::Graphics::TriD::VRML"; } else { eval "use PDL::Graphics::TriD::GL"; } my $ev = $options->{EHandler}; $ev = new PDL::Graphics::TriD::EventHandler($vp) unless defined($ev); my $cont = $options->{Transformer}; $cont = new PDL::Graphics::TriD::SimpleController() unless defined($cont); $vp->transformer($cont); if(ref($ev)){ $ev->set_button(0,new PDL::Graphics::TriD::ArcCone( $vp, 0, $cont->{WRotation})); $ev->set_button(2,new PDL::Graphics::TriD::SimpleScaler( $vp, \$cont->{CDistance})); $vp->eventhandler($ev); } } print "new_viewport: ",ref($vp)," ",$#{$this->{_ViewPorts}},"\n" if($PDL::Graphics::TriD::verbose); return $vp; } sub resize_viewport { my($this,$x0,$y0,$x1,$y1,$vpnum) = @_; $vpnum = $this->{_CurrentViewPort} unless(defined $vpnum); my $vp; if(defined($this->{_ViewPorts}[$vpnum])){ $vp = $this->{_ViewPorts}[$vpnum]->resize($x0,$y0,$x1,$y1); } return $vp; } sub current_viewport { my($this,$num) = @_; if(defined $num){ if(ref($num)){ my $cnt=0; foreach (@{$this->{_ViewPorts}}){ if($num == $_){ $this->{_CurrentViewPort} = $cnt; $_->{Active}=1; }elsif(defined $_){ $_->{Active}=0; } $cnt++; } }else{ if(defined $this->{_ViewPorts}[$num]){ $this->{_CurrentViewPort} = $num; $this->{_ViewPorts}[$num]->{Active}=1; }else{ print "ERROR: ViewPort $num undefined\n"; } } } return $this->{_ViewPorts}[$this->{_CurrentViewPort}]; } sub viewports { my ($this) = shift; return $this->{_ViewPorts}; } sub _vp_num_fromref { my ($this,$vp) = @_; if(! defined $vp){ $vp = $this->{_CurrentViewPort}; }elsif(ref($vp)){ my $cnt=0; foreach(@{$this->{_ViewPorts}}){ last if($vp == $_); $cnt++; } $vp = $cnt; } return $vp; } sub delete_viewport { my($this, $vp) = @_; my $cnt; if(($cnt=$#{$this->{_ViewPorts}})<= 0){ print "WARNING: Cannot delete final viewport - request ignored\n"; return; } $vp = $this->_vp_num_fromref($vp); $this->{_ViewPorts}[$vp]->DESTROY(); splice(@{$this->{_ViewPorts}},$vp,1); if($vp == $cnt){ $this->current_viewport($vp-1); } } sub clear_viewports { my($this) = @_; foreach(@{$this->{_ViewPorts}}){ $_->clear_objects(); } } sub clear_viewport { my($this, $vp) = @_; my $cnt; $vp = $this->_vp_num_fromref($vp); $this->{_ViewPorts}[$vp]->clear_objects(); } sub set_eventhandler { my($this,$handler) = @_; $this->{EHandler} = $handler; # for(@{$this->{_ViewPorts}}) { # $_->eventhandler($handler); # } } #sub set_transformer { # my($this,$transformer) = @_; # # for(@{$this->{_ViewPorts}}) { # $_->transformer($transformer); # } #} sub AUTOLOAD { my ($self,@args)=@_; use vars qw($AUTOLOAD); my $sub = $AUTOLOAD; # If an unrecognized function is called for window it trys to apply it # to all of the defined ViewPorts $sub =~ s/.*:://; print "AUTOLOAD: $sub at ",__FILE__," line ", __LINE__ ,".\n" if($PDL::Graphics::TriD::verbose); print "Window AUTOLOADing '$sub': self=$self, args='".join("','",@args),"'\n" if($PDL::debug_trid); if($sub =~ /^gl/ && defined $self->{_GLObject}){ return $self->{_GLObject}->$sub(@args); } for(@{$self->{_ViewPorts}}) { next unless defined $_; $_->$sub(@args); } } 1; PDL-2.018/Graphics/TriD/TriD.pm0000644060175006010010000007063013036512175014207 0ustar chmNone=head1 NAME PDL::Graphics::TriD -- PDL 3D interface =head1 SYNOPSIS use PDL::Graphics::TriD; # Generate a somewhat interesting sequence of points: $t = sequence(100)/10; $x = sin($t); $y = cos($t), $z = $t; $coords = cat($x, $y, $z)->xchg(0,1); $r = cos(2*$t); $g = sin($t); $b = $t; $colors = cat($r, $g, $b)->xchg(0,1); # After each graph, let the user rotate and # wait for him to press 'q', then make new graph line3d($coords); # $coords = (3,n,...) line3d($coords,$colors); # $colors = (3,n,...) line3d([$x,$y,$z]); # Generate a somewhat interesting sequence of surfaces $surf1 = (rvals(100, 100) / 50)**2 + sin(xvals(100, 100) / 10); $surf2 = sqrt(rvals(zeroes(50,50))/2); $x = sin($surface); $y = cos($surface), $z = $surface; $coords = cat($x, $y, $z)->xchg(0,1); $r = cos(2*$surface); $g = sin($surface); $b = $surface; $colors = cat($r, $g, $b)->xchg(0,1); imagrgb([$r,$g,$b]); # 2-d piddles lattice3d([$surf1]); points3d([$x,$y,$z]); spheres3d([$x,$y,$z]); # preliminary implementation hold3d(); # the following graphs are on top of each other and the previous line3d([$x,$y,$z]); line3d([$x,$y,$z+1]); $pic = grabpic3d(); # Returns the picture in a (3,$x,$y) float piddle (0..1). release3d(); # the next graph will again wipe out things. =head1 WARNING These modules are still in a somewhat unfocused state: don't use them yet if you don't know how to make them work if they happen to do something strange. =head1 DESCRIPTION This module implements a generic 3D plotting interface for PDL. Points, lines and surfaces (among other objects) are supported. With OpenGL, it is easy to manipulate the resulting 3D objects with the mouse in real time - this helps data visualization a lot. =for comment With VRML, you can generate objects for everyone to see with e.g. Silicon Graphics' Cosmo Player. You can find out more about VRML at C or C =head1 SELECTING A DEVICE The default device for TriD is currently OpenGL. You can specify a different device either in your program or in the environment variable C. The one specified in the program takes priority. The currently available devices are =over 8 =item GL OpenGL =item GLpic OpenGL but off-line (pixmap) rendering and writing to a graphics file. =item VRML (I< Not available this release >) VRML objects rendering. This writes a VRML file describing the scene. This VRML file can then be read with a browser. =back =head1 ONLINE AND OFFLINE VISUALIZATION TriD offers both on- and off-line visualization. Currently the interface w.r.t. this division is still much in motion. For OpenGL you can select either on- or off-line rendering. VRML is currently always offline (this may change later, if someone bothers to write the java(script) code to contact PDL and wait for the next PDL image over the network. =head1 COORDINATE SPECIFICATIONS Specifying a set of coordinates is generally a context-dependent operation. For a traditional 3D surface plot, you'll want two of the coordinates to have just the xvals and yvals of the piddle, respectively. For a line, you would generally want to have one coordinate held at zero and the other advancing. This module tries to make a reasonable way of specifying the context while letting you do whatever you want by overriding the default interpretation. The alternative syntaxes for specifying a set of coordinates (or colors) are $piddle # MUST have 3 as first dim. [$piddle] [$piddle1,$piddle2] [$piddle1,$piddle2,$piddle3] [CONTEXT,$piddle] [CONTEXT,$piddle1,$piddle2] [CONTEXT,$piddle1,$piddle2,$piddle3] where C is a string describing in which context you wish these piddles to be interpreted. Each routine specifies a default context which is explained in the routines documentation. Context is usually used only to understand what the user wants when he/she specifies less than 3 piddles. The following contexts are currently supported: =over 8 =item SURF2D A 2-D lattice. C< [$piddle] > is interpreted as the Z coordinate over a lattice over the first dimension. Equivalent to C<< [$piddle->xvals, $piddle->yvals, $piddle] >>. =item POLAR2D A 2-D polar coordinate system. C< [$piddle] > is interpreted as the z coordinate over theta and r (theta = the first dimension of the piddle). =item COLOR A set of colors. C< [$piddle] > is interpreted as grayscale color (equivalent to C< [$piddle,$piddle,$piddle] >). =item LINE A line made of 1 or 2 coordinates. C< [$piddle] > is interpreted as C<< [$piddle->xvals,$piddle,0] >>. C< [$piddle1,$piddle2] > is interpreted as C<< [$piddle1,$piddle2,$piddle1->xvals] >>. =back What makes contexts useful is that if you want to plot points instead of the full surface you plotted with imag3d([$zcoords]); you don't need to start thinking about where to plot the points: points3d([SURF2D,$zcoords]); will do exactly the same. =head2 Wrapping your head around 3d surface specifications Let's begin by thnking about how you might make a 2d data plot. If you sampled your data at regular intervals, you would have a time serires y(t) = (y0, y1, y2, ...). You could plot y vs t by computing t0 = 0, t1 = dt, t2 = 2 * dt, and then plotting (t0, y0), (t1, y1), etc. Next suppose that you measured x(t) and y(t). You can still plot y vs t, but you can also plot y vs x by plotting (x0, y0), (x1, y1), etc. The x-values don't have to increase monotonically: they could back-track on each other, for example, like the latitude and longitude of a boat on a lake. If you use plplot, you would plot this data using C<< $pl->xyplot($x, $y, PLOTTYPE => 'POINTS') >>. Good. Now let's add a third coordinate, z(t). If you actually sampled x and y at regular intervals, so that x and y lie on a grid, then you can construct a grid for z(x, y), and you would get a surface. This is the situation in which you would use C. Of course, your data is not required to be regularly gridded. You could, for example, be measuring the flight path of a bat flying after mosquitos, which could be wheeling and arching all over the space. This is what you might plot using C. You could plot the trajectories of multiple bats, in which case C<$x>, C<$y>, and C<$z> would have multiple columns, but in general you wouldn't expect them to be coordinated. Finally, imagine that you have an air squadron flying in formation. Your (x, y, z) data is not regularly gridded, but the (x, y, z) data for each plane should be coordinated and we can imagine that their flight path sweep out a surface. We could draw this data using C, where each column in the variables corresponds to a different plane, but it would also make sense to draw this data using C, since the planes' proximity to each other should be fairly consistent. In other words, it makes sense to think of the planes as sweeping out a coordinated surface, which C would draw for you, whereas you would not expect the trajectories of the various bats to describe a meaningful surface (unless you're into fractals, perhaps). #!/usr/bin/perl use PDL; use PDL::Graphics::TriD; # Draw out a trajectory in three-space $t = sequence(100)/10; $x = sin($t); $y = cos($t); $z = $t; # Plot the trajectory as (x(t), y(t), z(t)) print "using line3d to plot a trajectory (press q when you're done twiddling)\n"; line3d [$x,$y,$z]; # If you give it a single piddle, it expects # the data to look like # ((x1, y1, z1), (x2, y2, z2), ...) # which is why we have to do the exchange: $coords = cat($x, $y, $z)->xchg(0,1); print "again, with a different coordinate syntax (press q when you're done twiddling)\n"; line3d $coords; # Draw a regularly-gridded surface: $surface = sqrt(rvals(zeroes(50,50))/2); print "draw a mesh of a regularly-gridded surface using mesh3d\n"; mesh3d [$surface]; print "draw a regularly-gridded surface using imag3d\n"; imag3d [$surface], {Lines=>0}; # Draw a mobius strip: $two_pi = 8 * atan2(1,1); $t = sequence(50) / 50 * $two_pi; # We want two paths: $mobius1_x = cos($t) + 0.5 * sin($t/2); $mobius2_x = cos($t); $mobius3_x = cos($t) - 0.5 * sin($t/2); $mobius1_y = sin($t) + 0.5 * sin($t/2); $mobius2_y = sin($t); $mobius3_y = sin($t) - 0.5 * sin($t/2); $mobius1_z = $t - $two_pi/2; $mobius2_z = zeroes($t); $mobius3_z = $two_pi/2 - $t; $mobius_x = cat($mobius1_x, $mobius2_x, $mobius3_x); $mobius_y = cat($mobius1_y, $mobius2_y, $mobius3_y); $mobius_z = cat($mobius1_z, $mobius2_z, $mobius3_z); $mobius_surface = cat($mobius_x, $mobius_y, $mobius_z)->mv(2,0); print "A mobius strip using line3d one way\n"; line3d $mobius_surface; print "A mobius strip using line3d the other way\n"; line3d $mobius_surface->xchg(1,2); print "A mobius strip using mesh3d\n"; mesh3d $mobius_surface; print "The same mobius strip using imag3d\n"; imag3d $mobius_surface, {Lines => 0}; =head1 SIMPLE ROUTINES Because using the whole object-oriented interface for doing all your work might be cumbersome, the following shortcut routines are supported: =head1 FUNCTIONS =head2 line3d =for ref 3D line plot, defined by a variety of contexts. =for usage line3d piddle(3,x), {OPTIONS} line3d [CONTEXT], {OPTIONS} =for example Example: pdl> line3d [sqrt(rvals(zeroes(50,50))/2)] - Lines on surface pdl> line3d [$x,$y,$z] - Lines over X, Y, Z pdl> line3d $coords - Lines over the 3D coordinates in $coords. Note: line plots differ from mesh plots in that lines only go in one direction. If this is unclear try both! See module documentation for more information on contexts and options =head2 imag3d =for ref 3D rendered image plot, defined by a variety of contexts =for usage imag3d piddle(3,x,y), {OPTIONS} imag3d [piddle,...], {OPTIONS} =for example Example: pdl> imag3d [sqrt(rvals(zeroes(50,50))/2)], {Lines=>0}; - Rendered image of surface See module documentation for more information on contexts and options =head2 mesh3d =for ref 3D mesh plot, defined by a variety of contexts =for usage mesh3d piddle(3,x,y), {OPTIONS} mesh3d [piddle,...], {OPTIONS} =for example Example: pdl> mesh3d [sqrt(rvals(zeroes(50,50))/2)] - mesh of surface Note: a mesh is defined by two sets of lines at right-angles (i.e. this is how is differs from line3d). See module documentation for more information on contexts and options =head2 lattice3d =for ref alias for mesh3d =head2 points3d =for ref 3D points plot, defined by a variety of contexts =for usage points3d piddle(3), {OPTIONS} points3d [piddle,...], {OPTIONS} =for example Example: pdl> points3d [sqrt(rvals(zeroes(50,50))/2)]; - points on surface See module documentation for more information on contexts and options =head2 spheres3d =for ref 3D spheres plot (preliminary implementation) =for usage spheres3d piddle(3), {OPTIONS} spheres3d [piddle,...], {OPTIONS} =for example Example: pdl> spheres3d ndcoords(10,10,10)->clump(1,2,3) - lattice of spheres at coordinates on 10x10x10 grid This is a preliminary implementation as a proof of concept. It has fixed radii for the spheres being drawn and no control of color or transparency. =head2 imagrgb =for ref 2D RGB image plot (see also imag2d) =for usage imagrgb piddle(3,x,y), {OPTIONS} imagrgb [piddle,...], {OPTIONS} This would be used to plot an image, specifying red, green and blue values at each point. Note: contexts are very useful here as there are many ways one might want to do this. =for example e.g. pdl> $a=sqrt(rvals(zeroes(50,50))/2) pdl> imagrgb [0.5*sin(8*$a)+0.5,0.5*cos(8*$a)+0.5,0.5*cos(4*$a)+0.5] =head2 imagrgb3d =for ref 2D RGB image plot as an object inside a 3D space =for usage imagrdb3d piddle(3,x,y), {OPTIONS} imagrdb3d [piddle,...], {OPTIONS} The piddle gives the colors. The option allowed is Points, which should give 4 3D coordinates for the corners of the polygon, either as a piddle or as array ref. The default is [[0,0,0],[1,0,0],[1,1,0],[0,1,0]]. =for example e.g. pdl> imagrgb3d $colors, {Points => [[0,0,0],[1,0,0],[1,0,1],[0,0,1]]}; - plot on XZ plane instead of XY. =head2 grabpic3d =for ref Grab a 3D image from the screen. =for usage $pic = grabpic3d(); The returned piddle has dimensions (3,$x,$y) and is of type float (currently). XXX This should be altered later. =head2 hold3d, release3d =for ref Keep / don't keep the previous objects when plotting new 3D objects =for usage hold3d(); release3d(); or hold3d(1); hold3d(0); =head2 keeptwiddling3d, nokeeptwiddling3d =for ref Wait / don't wait for 'q' after displaying a 3D image. Usually, when showing 3D images, the user is given a chance to rotate it and then press 'q' for the next image. However, sometimes (for e.g. animation) this is undesirable and it is more desirable to just run one step of the event loop at a time. =for usage keeptwiddling3d(); nokeeptwiddling3d(); or keeptwiddling3d(1); keeptwiddling3d(0); When an image is added to the screen, keep twiddling it until user explicitly presses 'q'. =for example keeptwiddling3d(); imag3d(..); nokeeptwiddling3d(); $o = imag3d($c); while(1) { $c .= nextfunc($c); $o->data_changed(); twiddle3d(); # animate one step, then return. } =head2 twiddle3d =for ref Wait for the user to rotate the image in 3D space. Let the user rotate the image in 3D space, either for one step or until (s)he presses 'q', depending on the 'keeptwiddling3d' setting. If 'keeptwiddling3d' is not set the routine returns immediately and indicates that a 'q' event was received by returning 1. If the only events received were mouse events, returns 0. =head1 CONCEPTS The key concepts (object types) of TriD are explained in the following: =head2 Object In this 3D abstraction, everything that you can "draw" without using indices is an Object. That is, if you have a surface, each vertex is not an object and neither is each segment of a long curve. The whole curve (or a set of curves) is the lowest level Object. Transformations and groups of Objects are also Objects. A Window is simply an Object that has subobjects. =head2 Twiddling Because there is no eventloop in Perl yet and because it would be hassleful to do otherwise, it is currently not possible to e.g. rotate objects with your mouse when the console is expecting input or the program is doing other things. Therefore, you need to explicitly say "$window->twiddle()" in order to display anything. =head1 OBJECTS The following types of objects are currently supported. Those that do not have a calling sequence described here should have their own manual pages. There are objects that are not mentioned here; they are either internal to PDL3D or in rapidly changing states. If you use them, you do so at your own risk. The syntax C here means that you create an object like $a = new PDL::Graphics::TriD::Scale($x,$y,$z); =head2 PDL::Graphics::TriD::LineStrip This is just a line or a set of lines. The arguments are 3 1-or-more-D piddles which describe the vertices of a continuous line and an optional color piddle (which is 1-D also and simply defines the color between red and blue. This will probably change). =head2 PDL::Graphics::TriD::Lines This is just a line or a set of lines. The arguments are 3 1-or-more-D piddles where each contiguous pair of vertices describe a line segment and an optional color piddle (which is 1-D also and simply defines the color between red and blue. This will probably change). =head2 PDL::Graphics::TriD::Image This is a 2-dimensional RGB image consisting of colored rectangles. With OpenGL, this is implemented by texturing so this should be relatively memory and execution-time-friendly. =head2 PDL::Graphics::TriD::Lattice This is a 2-D set of points connected by lines in 3-space. The constructor takes as arguments 3 2-dimensional piddles. =head2 PDL::Graphics::TriD::Points This is simply a set of points in 3-space. Takes as arguments the x, y and z coordinates of the points as piddles. =head2 PDL::Graphics::TriD::Scale(x,y,z) Self-explanatory =head2 PDL::Graphics::TriD::Translation(x,y,z) Ditto =head2 PDL::Graphics::TriD::Quaternion(c,x,y,z) One way of representing rotations is with quaternions. See the appropriate man page. =head2 PDL::Graphics::TriD::ViewPort This is a special class: in order to obtain a new viewport, you need to have an earlier viewport on hand. The usage is: $new_vp = $old_vp->new_viewport($x0,$y0,$x1,$y1); where $x0 etc are the coordinates of the upper left and lower right corners of the new viewport inside the previous (relative to the previous viewport in the (0,1) range. Every implementation-level window object should implement the new_viewport method. =head1 EXAMPLE SCRIPT FOR VARIOUS =cut #KGB: NEEDS DOCS ON COMMON OPTIONS!!!!! # List of global variables # # $PDL::Graphics::TriD::offline # $PDL::Graphics::TriD::Settings # $PDL::Graphics::TriD::verbose # $PDL::Graphics::TriD::keeptwiddling # $PDL::Graphics::TriD::hold_on # $PDL::Graphics::TriD::curgraph # $PDL::Graphics::TriD::cur # $PDL::Graphics::TriD::create_window_sub # $PDL::Graphics::TriD::current_window # # ' package PDL::Graphics::TriD::Basic; package PDL::Graphics::TriD; use PDL::Exporter; use PDL::Core ''; # barf use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS/; @ISA = qw/PDL::Exporter/; @EXPORT_OK = qw/imag3d_ns imag3d line3d mesh3d lattice3d points3d spheres3d describe3d imagrgb imagrgb3d hold3d release3d keeptwiddling3d nokeeptwiddling3d twiddle3d grabpic3d tridsettings/; %EXPORT_TAGS = (Func=>[@EXPORT_OK]); #use strict; use PDL::Graphics::TriD::Object; use PDL::Graphics::TriD::Window; use PDL::Graphics::TriD::ViewPort; use PDL::Graphics::TriD::Graph; use PDL::Graphics::TriD::Quaternion; use PDL::Graphics::TriD::Objects; use PDL::Graphics::TriD::Rout; # Then, see which display method are we using: BEGIN { my $dev; $dev ||= $::PDL::Graphics::TriD::device; # First, take it from this variable. $dev ||= $::ENV{PDL_3D_DEVICE}; if(!defined $dev) { # warn "Default PDL 3D device is GL (OpenGL): # Set PDL_3D_DEVICE=GL in your environment in order not to see this warning. # You must have OpenGL or Mesa installed and the PDL::Graphics::OpenGL extension # compiled. Otherwise you will get strange warnings."; $dev = "GL"; # default GL works on all platforms now } my $dv; # The following is just a sanity check. for($dev) { # (/^OOGL$/ and $dv="PDL::Graphics::TriD::OOGL") or (/^GL$/ and $dv="PDL::Graphics::TriD::GL") or (/^GLpic$/ and $dv="PDL::Graphics::TriD::GL" and $PDL::Graphics::TriD::offline=1) or (/^VRML$/ and $dv="PDL::Graphics::TriD::VRML" and $PDL::Graphics::TriD::offline=1) or (barf "Invalid PDL 3D device '$_' specified!"); } my $mod = $dv; $mod =~ s|::|//|g; print "dev = $dev mod=$mod\n" if($verbose); require "$mod.pm"; $dv->import; my $verbose; } # currently only used by VRML backend sub tridsettings {return $PDL::Graphics::TriD::Settings} # Allowable forms: # x(3,..) [x(..),y(..),z(..)] sub realcoords { my($type,$c) = @_; if(ref $c ne "ARRAY") { if($c->getdim(0) != 3) { barf "If one piddle given for coordinate, must be (3,...) or have default interpretation"; } return $c ; } if(!ref $c->[0]) {$type = shift @$c} if($#$c < 0 || $#$c>2) { barf "Must have 1..3 array members for coordinates"; } if($#$c == 0 and $type =~ /^SURF2D$/) { # surf2d -> this is z axis @$c = ($c->[0]->xvals,$c->[0]->yvals,$c->[0]); } elsif($#$c == 0 and $type eq "POLAR2D") { my $t = 6.283 * $c->[0]->xvals / ($c->[0]->getdim(0)-1); my $r = $c->[0]->yvals / ($c->[0]->getdim(1)-1); @$c = ($r * sin($t), $r * cos($t), $c->[0]); } elsif($#$c == 0 and $type eq "COLOR") { # color -> 1 piddle = grayscale @$c = ($c->[0], $c->[0], $c->[0]); } elsif($#$c == 0 and $type eq "LINE") { @$c = ($c->[0]->xvals, $c->[0], 0); } elsif($#$c == 1 and $type eq "LINE") { @$c = ($c->[0], $c->[1], $c->[0]->xvals); } # XXX if($#$c != 2) { barf("Must have 3 coordinates if no interpretation (here '$type')"); } # allow a constant (either pdl or not) to be introduced in one dimension foreach(0..2){ if(ref($c->[$_]) ne "PDL" or $c->[$_]->nelem==1){ $c->[$_] = $c->[$_]*(PDL->ones($c->[($_+1)%3]->dims)); } } my $g = PDL->null; &PDL::Graphics::TriD::Rout::combcoords(@$c,$g); $g->dump if $PDL::Graphics::TriD::verbose; return $g; } sub objplotcommand { my($object) = @_; my $win = PDL::Graphics::TriD::get_current_window(); my $world = $win->world(); } sub checkargs { if(ref $_[$#_] eq "HASH" and $PDL::Graphics::TriD::verbose) { print "enter checkargs \n"; for([KeepTwiddling,\&keeptwiddling3d]) { print "checkargs >$_<\n"; if(defined $_[$#_]{$_->[0]}) { &{$_->[1]}(delete $_[$#_]{$_->[0]}); } } } } *keeptwiddling3d = \&PDL::keeptwiddling3d; sub PDL::keeptwiddling3d { $PDL::Graphics::TriD::keeptwiddling = (defined $_[0] ? $_[0] : 1); } *nokeeptwiddling3d = \&PDL::nokeeptwiddling3d; sub PDL::nokeeptwiddling3d { $PDL::Graphics::TriD::keeptwiddling = 0 ; } keeptwiddling3d(); *twiddle3d = \&PDL::twiddle3d; sub PDL::twiddle3d { twiddle_current(); } sub graph_object { my($obj) = @_; if(!defined $obj or !ref $obj) { barf("Invalid object to TriD::graph_object"); } print "graph_object: calling get_new_graph\n" if($PDL::debug_trid); my $g = get_new_graph(); print "graph_object: back from get_new_graph\n" if($PDL::debug_trid); my $name = $g->add_dataseries($obj); $g->bind_default($name); $g->scalethings(); print "ADDED TO GRAPH: '$name'\n" if $PDL::Graphics::TriD::verbose; twiddle_current(); return $obj; } # Plotting routines that use the whole viewport *describe3d=\&PDL::describe3d; sub PDL::describe3d { require PDL::Graphics::TriD::TextObjects; my ($text) = @_; my $win = PDL::Graphics::TriD::get_current_window(); my $imag = new PDL::Graphics::TriD::Description($text); $win->add_object($imag); # $win->twiddle(); } *imagrgb=\&PDL::imagrgb; sub PDL::imagrgb { require PDL::Graphics::TriD::Image; my (@data) = @_; &checkargs; my $win = PDL::Graphics::TriD::get_current_window(); my $imag = new PDL::Graphics::TriD::Image(@data); $win->clear_viewports(); $win->current_viewport()->add_object($imag); $win->twiddle(); } # Plotting routines that use the 3D graph # Call: line3d([$x,$y,$z],[$color]); *line3d=\&PDL::line3d; sub PDL::line3d { &checkargs; my $obj = new PDL::Graphics::TriD::LineStrip(@_); print "line3d: object is $obj\n" if($PDL::debug_trid); &graph_object($obj); } *contour3d=\&PDL::contour3d; sub PDL::contour3d { # &checkargs; require PDL::Graphics::TriD::Contours; &graph_object(new PDL::Graphics::TriD::Contours(@_)); } # XXX Should enable different positioning... *imagrgb3d=\&PDL::imagrgb3d; sub PDL::imagrgb3d { &checkargs; require PDL::Graphics::TriD::Image; &graph_object(new PDL::Graphics::TriD::Image(@_)); } *imag3d_ns=\&PDL::imag3d_ns; sub PDL::imag3d_ns { &checkargs; &graph_object(new PDL::Graphics::TriD::SLattice(@_)); } *imag3d=\&PDL::imag3d; sub PDL::imag3d { &checkargs; &graph_object(new PDL::Graphics::TriD::SLattice_S(@_)); } #################################################################### ################ JNK 15mar11 added section start ################### *STrigrid_S_imag3d=\&PDL::STrigrid_S_imag3d; sub PDL::STrigrid_S_imag3d { &checkargs; &graph_object(new PDL::Graphics::TriD::STrigrid_S(@_)); } *STrigrid_imag3d=\&PDL::STrigrid_imag3d; sub PDL::STrigrid_imag3d { &checkargs; &graph_object(new PDL::Graphics::TriD::STrigrid(@_)); } ################ JNK 15mar11 added section finis ################### #################################################################### *mesh3d=\&PDL::mesh3d; *lattice3d=\&PDL::mesh3d; *PDL::lattice3d=\&PDL::mesh3d; sub PDL::mesh3d { &checkargs; &graph_object(new PDL::Graphics::TriD::Lattice(@_)); } *points3d=\&PDL::points3d; sub PDL::points3d { &checkargs; &graph_object(new PDL::Graphics::TriD::Points(@_)); } *spheres3d=\&PDL::spheres3d; sub PDL::spheres3d { &checkargs; &graph_object(new PDL::Graphics::TriD::Spheres(@_)); } *grabpic3d=\&PDL::grabpic3d; sub PDL::grabpic3d { my $win = PDL::Graphics::TriD::get_current_window(); barf "backend doesn't support grabing the rendered scene" unless $win->can('read_picture'); my $pic = $win->read_picture(); return ($pic->float) / 255; } $PDL::Graphics::TriD::hold_on = 0; sub PDL::hold3d {$PDL::Graphics::TriD::hold_on =(!defined $_[0] ? 1 : $_[0]);} sub PDL::release3d {$PDL::Graphics::TriD::hold_on = 0;} *hold3d=\&PDL::hold3d; *release3d=\&PDL::release3d; sub get_new_graph { print "get_new_graph: calling PDL::Graphics::TriD::get_current_window...\n" if($PDL::debug_trid); my $win = PDL::Graphics::TriD::get_current_window(); print "get_new_graph: calling get_current_graph...\n" if($PDL::debug_trid); my $g = get_current_graph($win); print "get_new_graph: back get_current_graph returned $g...\n" if($PDL::debug_trid); if(!$PDL::Graphics::TriD::hold_on) { $g->clear_data(); $win->clear_viewport(); } $g->default_axes(); $win->add_object($g); return $g; } sub get_current_graph { my $win = shift; my $g = $win->current_viewport()->graph(); if(!defined $g) { $g = new PDL::Graphics::TriD::Graph(); $g->default_axes(); $win->current_viewport()->graph($g); } return $g; } # $PDL::Graphics::TriD::cur = {}; # $PDL::Graphics::TriD::create_window_sub = undef; sub get_current_window { my $opts = shift @_; my $win = $PDL::Graphics::TriD::cur; if(!defined $win) { if(!$PDL::Graphics::TriD::create_window_sub) { barf("PDL::Graphics::TriD must be used with a display mechanism: for example PDL::Graphics::TriD::GL!\n"); } print "get_current_window - creating window...\n" if($PDL::debug_trid); $win = new PDL::Graphics::TriD::Window($opts); print "get_current_window - calling set_material...\n" if($PDL::debug_trid); $win->set_material(new PDL::Graphics::TriD::Material); $PDL::Graphics::TriD::current_window = $win; $PDL::Graphics::TriD::cur = $win } return $PDL::Graphics::TriD::current_window; } # Get the current graphbox sub get_current_graphbox { die "get_current_graphbox: ERROR graphbox is not implemented! \n"; my $graph = $PDL::Graphics::TriD::curgraph; if(!defined $graph) { $graph = new PDL::Graphics::TriD::Graph(); $graph->default_axes(); $PDL::Graphics::TriD::curgraph = $graph; } return $graph; } sub twiddle_current { my $win = get_current_window(); $win->twiddle(); } ################################### # # package PDL::Graphics::TriD::Material; sub new { my ($type,%ops) = @_; my $this = bless {}, $type; for (['Shine',40], ['Specular',[1,1,0.3,0]], ['Ambient',[0.3,1,1,0]], ['Diffuse',[1,0.3,1,0]], ['Emissive',[0,0,0]]) { if (!defined $ops{$_->[0]}) { $this->{$_->[0]} = $_->[1]; } else { $this->{$_->[0]} = $ops{$_->[0]}; } } return $this; } package PDL::Graphics::TriD::BoundingBox; use base qw/PDL::Graphics::TriD::Object/; use fields qw/Box/; sub new { my($type,$x0,$y0,$z0,$x1,$y1,$z1) = @_; my $this = $type->SUPER::new(); $this->{Box} = [$x0,$y0,$z0,$x1,$y1,$z1]; } sub normalize {my($this,$x0,$y0,$z0,$x1,$y1,$z1) = @_; $this = $this->{Box}; my $trans = PDL::Graphics::TriD::Transformation->new(); my $sx = ($x1-$x0)/($this->[3]-$this->[0]); my $sy = ($y1-$y0)/($this->[4]-$this->[1]); my $sz = ($z1-$z0)/($this->[5]-$this->[2]); $trans->add_transformation( PDL::Graphics::TriD::Translation->new( ($x0-$this->[0]*$sx), ($y0-$this->[1]*$sy), ($z0-$this->[2]*$sz) )); $trans->add_transformation(PDL::Graphics::TriD::Scale->new($sx,$sy,$sz)); return $trans; } ################################### # # package PDL::Graphics::TriD::OneTransformation; use fields qw/Args/; sub new { my($type,@args) = @_; my $this = fields::new($type); $this->{Args} = [@args]; $this; } package PDL::Graphics::TriD::Scale; use base qw/PDL::Graphics::TriD::OneTransformation/; package PDL::Graphics::TriD::Translation; use base qw/PDL::Graphics::TriD::OneTransformation/; package PDL::Graphics::TriD::Transformation; use base qw/PDL::Graphics::TriD::Object/; #sub new { # my($type) = @_; # bless {},$type; #} sub add_transformation { my($this,$trans) = @_; push @{$this->{Transforms}},$trans; } =head1 BUGS Not enough is there yet. =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka (lukka@husc.harvard.edu). Documentation contributions from Karl Glazebrook (kgb@aaoepp.aao.gov.au). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut PDL-2.018/Graphics/TriD/VRML/0000755060175006010010000000000013110402046013545 5ustar chmNonePDL-2.018/Graphics/TriD/VRML/Makefile.PL0000644060175006010010000000036012562522364015536 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => "PDL::Graphics::VRML", 'VERSION_FROM' => '../../../Basic/Core/Version.pm', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Graphics/TriD/VRML/VRML/0000755060175006010010000000000013110402044014323 5ustar chmNonePDL-2.018/Graphics/TriD/VRML/VRML/Protos.pm0000644060175006010010000000244012562522364016171 0ustar chmNone package PDL::Graphics::VRML::Protos; PDL::Graphics::VRMLNode->import(); PDL::Graphics::VRMLProto->import(); sub PDLBlockText10 { vrp('PDLBlockText10', [fv3f('position',"0 0 0"), fv3f('size',"1 1 0.1"), fmstr('text','["TESTING PDL","TEXTBLOCK","LONG LONG LONG LONG LONG TEXT","Short","FOOOOOOOOOOOOOOOO"]')], vrn('Transform', 'translation' => 'IS position', 'scale' => 'IS size', 'children' => [ vrn(Transform, translation => '0 0 -0.55', 'children' => [vrn('Shape', geometry => vrn('Box', size => '1 1 0.45'), appearance => vrn(Appearance, material => vrn(Material, diffuseColor => '0.9 0.9 0.9', ambientIntensity => '0.1' ) ) )] ), vrn(Transform, translation => '-0.45 0.35 0', scale => '0.9 0.9 0', children => [ vrn(Shape, geometry => vrn(Text, string => 'IS text', maxExtent => '1.0', fontStyle => vrn(FontStyle, size => '0.075', spacing => '1.33', justify => 'end' ), ), appearance => vrn(Appearance, material => vrn(Material, diffuseColor => '0 0 0', ambientIntensity => '0' ) ) ) ]) ] ) ); } 1; PDL-2.018/Graphics/TriD/VRML/VRML.pm0000644060175006010010000002001312562522364014677 0ustar chmNone# XXXXX print methods need to be changed to # reduce memory consumption ################### # # VRMLProto package PDL::Graphics::VRMLProto; use Exporter; use PDL::Core ''; @ISA = qw/ Exporter /; @EXPORT = qw/ vrp fv3f fmstr /; sub new { my $type = shift; my ($name,$fields,$node) = @_; my $this = bless {},$type; $this->{Name} = $name; $this->{Fields} = $fields; $this->{Node} = $node; return $this; } sub vrp { return PDL::Graphics::VRMLProto->new(@_); } sub fv3f { my ($name,$def) = @_; return ["field SFVec3f", "$name", "$def"]; } sub fmstr { my ($name,$def) = @_; return ["field MFString", "$name", defined $def ? "$def" : "[]"]; } sub to_text { my $this = shift; my $text = "PROTO $this->{Name} [\n"; for (@{$this->{Fields}}) { $text .= " $_->[0] $_->[1]\t$_->[2]\n"; } $text .= "]\n{\n"; $text .= $this->{Node}->to_text; return $text . "}\n"; } ##################### # # VRMLNode package PDL::Graphics::VRMLNode; use Exporter; @ISA = qw/ Exporter /; @EXPORT = qw/ vrn vrml3v /; @EXPORT_OK = qw/ tabs postfix prefix /; sub vrn { return PDL::Graphics::VRMLNode->new(@_); } sub new { my $type = shift; my $title = shift; my $this = bless {},$type; $this->{'Container'} = {}; $this->{'Title'} = $title; $this->add(@_); return $this; } sub add { my ($this,%items) = @_; for (keys %items) { $this->{Container}{$_} = $items{$_}; } return $this; } sub add_children { my ($this) = shift; for(@_) { push @{$this->{Container}{children}}, $_; } } sub to_text { my $this = shift; my $level = $#_ > -1 ? shift : 1; my $text = $this->prefix($level); my($k,$v); while (($k,$v) = each %{$this->{Container}}) { $text .= tabs($level) . "$k". (ref $v ? ref $v eq "ARRAY" ? $this->array_out($v,$level+1) : (" ".$v->to_text($level+1)) : "\t$v\n"); } return $text.$this->postfix($level); } sub array_out { my ($this,$array,$level) = @_; my $text = " [\n"; for (@$array) { $text .= tabs($level) . (ref $_ ? $_->to_text($level+1) : "$_,\n") } $text .= tabs($level-1) . "]\n"; return $text; } sub prefix { return $_[0]->{Title}." {\n"; } sub postfix { return "\t"x($_[1]-1)."}\n"; } sub tabs { return "\t"x$_[0]; } sub vrml3v { my $list = shift; return sprintf '%.3f %.3f %.3f', @{$list}[0..2]; } ################# # # VRMLPdlNode package PDL::Graphics::VRMLPdlNode; @ISA = qw/ PDL::Graphics::VRMLNode /; use PDL::Lite; use PDL::Core qw(barf); use PDL::Dbg; PDL::Graphics::VRMLNode->import(qw/tabs vrml3v postfix prefix/); sub new { my ($type,$points,$colors,$options) = @_; my $this = bless {},$type; $this->{'Points'} = $points; $this->{'Colors'} = $colors; $this->checkoptions($options); return $this; } sub checkoptions { my ($this,$options) = @_; my $aopts = $this->getvopts(); for (keys %$aopts) { if (!defined $options->{$_}) { $this->{$_} = $aopts->{$_}; } else { $this->{$_} = delete $options->{$_}; } } if (keys %$options) { barf "Invalid options left: ".(join ',',%$options); } } sub getvopts { my ($this) = @_; return {Title => 'PointSet', PerVertex => 0, Lighting => 0, Surface => 0, Lines => 1, Smooth => 0, IsLattice => 0, DefColors => 0}; } sub to_text { my $this = shift; my $level = $#_ > -1 ? shift : 1; my $text = $this->prefix($level); my ($vtxt,$vidx,$ctxt,$extra,$useidx) = ("","","","",0); if ($this->{Title} eq 'PointSet') { coords($this->{Points},$this->{Colors},\$vtxt,\$ctxt,tabs($level+2)); } elsif ($this->{Title} eq 'IndexedLineSet') { my @dims = $this->{Points}->dims; shift @dims; my $cols = $this->{Colors}; my $seq = PDL->sequence(@dims); require PDL::Dbg; local $PDL::debug = 0; $cols = pdl(0,0,0)->dummy(1)->dummy(2)->px if $this->{IsLattice} && $this->{Surface} && $this->{Lines}; lines($this->{Points},$cols,$seq, \$vtxt,\$ctxt,\$vidx,tabs($level+1)); lines($this->{Points}->xchg(1,2),$cols->xchg(1,2), $seq->xchg(0,1),undef,\$ctxt,\$vidx, tabs($level+1)) if $this->{IsLattice}; $useidx = 1; } elsif ($this->{Title} eq 'IndexedFaceSet') { my @dims = $this->{Points}->dims; shift @dims; my @sls1 = ("0:-2,0:-2", "1:-1,0:-2", "0:-2,1:-1"); my @sls2 = ("1:-1,1:-1", "0:-2,1:-1", "1:-1,0:-2" ); my $seq = PDL->sequence(@dims); coords($this->{Points},$this->{Colors},\$vtxt,\$ctxt,tabs($level+2)); triangles((map {$seq->slice($_)} @sls1),\$vidx,tabs($level+1)); triangles((map {$seq->slice($_)} @sls2),\$vidx,tabs($level+1)); $useidx = 1; $extra = tabs($level)."colorPerVertex\tTRUE\n". tabs($level)."solid\tFALSE\n"; $extra .= tabs($level)."creaseAngle\t3.14\n" if $this->{Smooth}; } $text .= vprefix('coord',$level).$vtxt.vpostfix('coord',$level); $text .= vprefix('index',$level).$vidx.vpostfix('index',$level) if $useidx; $text .= vprefix('color',$level).$ctxt.vpostfix('color',$level) unless $this->{DefColors}; return $text.$extra.$this->postfix($level); } sub vprefix { my ($type,$level) = @_; return tabs($level) . "coord Coordinate {\n" . tabs($level+1) . "point [\n" if $type eq 'coord'; return tabs($level) . "color Color {\n" . tabs($level+1) . "color [\n" if $type eq 'color'; return tabs($level) . "coordIndex [\n" if $type eq 'index'; } sub vpostfix { my ($type,$level) = @_; return tabs($level+1)."]\n".tabs($level)."}\n" unless $type eq 'index'; return tabs($level)."]\n"; } PDL::thread_define 'coords(vertices(n=3); colors(n)) NOtherPars => 3', PDL::over { ${$_[2]} .= $_[4] . sprintf("%.3f %.3f %.3f,\n",$_[0]->list); ${$_[3]} .= $_[4] . sprintf("%.3f %.3f %.3f,\n",$_[1]->list); }; PDL::thread_define 'v3array(vecs(n=3)) NOtherPars => 2', PDL::over { ${$_[1]} .= $_[2] . sprintf("%.3f %.3f %.3f,\n",$_[0]->list); }; PDL::thread_define 'lines(vertices(n=3,m); colors(n,m); index(m))'. 'NOtherPars => 4', PDL::over { my ($lines,$cols,$index,$vt,$ct,$it,$sp) = @_; v3array($lines,$vt,$sp."\t") if defined $vt; v3array($cols,$ct,$sp."\t") if defined $ct; $$it .= $sp.join(',',$index->list).",-1,\n" if defined $it; }; PDL::thread_define 'triangles(inda();indb();indc()), NOtherPars => 2', PDL::over { ${$_[3]} .= $_[4].join(',',map {$_->at} @_[0..2]).",-1,\n"; }; ##################### # # VRML package PDL::Graphics::VRML; use PDL::Core ''; %PDL::Graphics::VRML::Protos = (); sub new { my ($type,$title,$info) = @_; my $this = bless {},$type; $this->{Header} = '#VRML V2.0 utf8'; $this->{Info} = new PDL::Graphics::VRMLNode('WorldInfo', 'title' => $title, 'info' => $info); $this->{NaviInfo} = new PDL::Graphics::VRMLNode('NavigationInfo', 'type' => '["EXAMINE", "ANY"]'); $this->{Protos} = {}; $this->{Uses} = {}; $this->{Scene} = undef; return $this; } sub register_proto { my ($this,@protos) = @_; for (@protos) { barf "proto already registered" if defined $PDL::Graphics::VRML::Protos{$_->{Name}}; $PDL::Graphics::VRML::Protos{$_->{Name}} = $_; } } sub set_vrml { print "set_vrml ",ref($_[0]),"\n"; $_[0]->{Scene} = $_[1]; } sub uses { $_[0]->{Uses}->{$_[1]} = 1; } sub ensure_protos { my $this = shift; for (keys %{$this->{Uses}}) { barf "unknown Prototype $_" unless defined $PDL::Graphics::VRML::Protos{$_}; delete $this->{Uses}->{$_}; $this->add_proto($PDL::Graphics::VRML::Protos{$_}); } } sub add_proto { my ($this,$proto) = @_; $this->{Protos}->{$proto->{Name}} = $proto unless exists $this->{Protos}->{$proto->{Name}}; return $this; } sub print { my $this = shift; if ($#_ > -1) { my $file = ($_[0] =~ /^\s*[|>]/ ? '' : '>') .$_[0]; open VRML,"$file" or barf "can't open $file"; } else { *VRML = *STDOUT } print VRML "$this->{Header}\n"; print VRML $this->{Info}->to_text; print VRML $this->{NaviInfo}->to_text; for (keys %{$this->{Protos}}) { print VRML $this->{Protos}->{$_}->to_text } barf "no scene hierarchy" unless defined $this->{Scene}; print VRML $this->{Scene}->to_text; close VRML if $#_ > -1; } 1; PDL-2.018/inc/0000755060175006010010000000000013110402046011134 5ustar chmNonePDL-2.018/inc/Alien/0000755060175006010010000000000013110402045012163 5ustar chmNonePDL-2.018/inc/Alien/Proj4.pm0000644060175006010010000001427613036512175013546 0ustar chmNonepackage Alien::Proj4; use strict; use warnings; use Config; use Devel::CheckLib; my $find_libs = [ "libproj.$Config{dlext}", "libproj$Config{lib_ext}" ]; my @NEEDED = qw(projects.h proj_api.h); my @DEFAULT_LIB = ( '/usr/lib64', '/usr/local/lib64', '/lib64', '/usr/lib', '/usr/local/lib', '/lib', split(/ /, $Config{libpth}), ); my @DEFAULT_INC = ( '/usr/include', '/usr/local/include', $Config{usrinc}, ); my @lib_locations = @DEFAULT_LIB; my @inc_locations = @DEFAULT_INC; sub import { my ($class, $lib, $inc) = @_; @lib_locations = @$lib if $lib and @$lib; @inc_locations = @$inc if $inc and @$inc; } sub default_lib { my ($class) = @_; @DEFAULT_LIB; } sub default_inc { my ($class) = @_; @DEFAULT_INC; } sub libdir { my ($class) = @_; foreach my $libdir ( @lib_locations ) { foreach my $find_lib ( @$find_libs ) { next unless -e "$libdir/$find_lib"; return $libdir; } } } sub libflags { my ($class) = @_; my $lib_path = $class->libdir; $lib_path = qq{"$lib_path"} if $lib_path =~ /\s/; # conditional as EU::Liblist::Kid doesn't understand this on Cygwin my $libflags = qq{-L$lib_path -lproj -lm}; $libflags; } sub incdir { my ($class) = @_; my %dir2true; my %stillneeded = map { ($_=>1) } @NEEDED; my @inc; # array because need to keep ordering foreach my $incdir ( @inc_locations ) { foreach my $find_inc ( keys %stillneeded ) { next unless -e "$incdir/$find_inc"; push @inc, $incdir unless $dir2true{$incdir}; $dir2true{$incdir} = 1; delete $stillneeded{$find_inc}; } } @inc; } sub incflags { my ($class) = @_; join ' ', map qq{"-I$_"}, $class->incdir; } sub installed { my ($class) = @_; return 0 unless my $lib_path = $class->libdir; return 0 unless my @incdirs = $class->incdir; return 0 unless check_lib( function=>'projPJ mypj = pj_init_plus("+proj=eqc +lon_0=0 +datum=WGS84"); if (! mypj) return 1; else return 0;', header=>'proj_api.h', incpath=>\@incdirs, lib=>'proj', libpath=>$lib_path, ); return 1; } # dup of code currently in PDL::GIS::Proj sub load_projection_descriptions { my ($class) = @_; my $libflags = $class->libflags; my $incflags = $class->incflags; require Inline; Inline->bind(C => <<'EOF', inc => $incflags, libs => $libflags) unless defined &list_projections; #include "projects.h" HV *list_projections() { struct PJ_LIST *lp; SV* scalar_val; HV *hv = newHV(); for (lp = pj_get_list_ref() ; lp->id ; ++lp) { scalar_val = newSVpv( *lp->descr, 0 ); hv_store( hv, lp->id, strlen( lp->id ), scalar_val, 0 ); } return hv; } EOF list_projections(); } # dup of code currently in PDL::GIS::Proj sub load_projection_information { my ($class) = @_; my $descriptions = $class->load_projection_descriptions(); my $info = {}; foreach my $projection ( keys %$descriptions ) { my $description = $descriptions->{$projection}; my $hash = {}; $hash->{CODE} = $projection; my @lines = split( /\n/, $description ); chomp @lines; # Full name of this projection: $hash->{NAME} = $lines[0]; # The second line is usually a list of projection types this one is: my $temp = $lines[1]; $temp =~ s/no inv\.*,*//; $temp =~ s/or//; my @temp_types = split(/[,&\s]/, $temp ); my @types = grep( /.+/, @temp_types ); $hash->{CATEGORIES} = \@types; # If there's more than 2 lines, then it usually is a listing of parameters: # General parameters for all projections: $hash->{PARAMS}->{GENERAL} = [ qw( x_0 y_0 lon_0 units init no_defs geoc over ) ]; # Earth Figure Parameters: $hash->{PARAMS}->{EARTH} = [ qw( ellps b f rf e es R R_A R_V R_a R_g R_h R_lat_g ) ]; # Projection Specific Parameters: my @proj_params = (); if( $#lines >= 2 ) { foreach my $i ( 2 .. $#lines ) { my $text = $lines[$i]; my @temp2 = split( /\s+/, $text ); my @params = grep( /.+/, @temp2 ); foreach my $param (@params) { $param =~ s/=//; $param =~ s/[,\[\]]//sg; next if $param =~ /^and|or|Special|for|Madagascar|fixed|Earth|For|CH1903$/; push(@proj_params, $param); } } } $hash->{PARAMS}->{PROJ} = \@proj_params; # Can this projection do inverse? $hash->{INVERSE} = ( $description =~ /no inv/ ) ? 0 : 1; $info->{$projection} = $hash; } # A couple of overrides: $info->{ob_tran}->{PARAMS}->{PROJ} = [ 'o_proj', 'o_lat_p', 'o_lon_p', 'o_alpha', 'o_lon_c', 'o_lat_c', 'o_lon_1', 'o_lat_1', 'o_lon_2', 'o_lat_2' ]; $info->{nzmg}->{CATEGORIES} = [ 'fixed Earth' ]; return $info; } 1; __END__ =head1 NAME Alien::Proj4 - Give install info for already-installed proj4 =head1 SYNOPSIS In Makefile.PL: use Alien::Proj4 [ 'overridelibdirs' ], [ 'overrideincdirs' ]; my $proj4_installed = Alien::Proj4->installed; my $proj4_lib = Alien::Proj4->libflags; my $proj4_inc = Alien::Proj4->incflags; In a module like L that wants available proj4 projections: my @projections = Alien::Proj4->projections; =head1 DESCRIPTION If no override is given for the library or include directories, the defaults are used. The projections are listed using L, so that needs to be installed. An alternative idiom to the above compile-time example of supplying overrides for directories is: use Alien::Proj4; Alien::Proj4->import(\@libdirs, undef) if @libdirs; # set to different Alien::Proj4->import(undef, [ Alien::Proj4->default_inc, @incdirs ]); # add since the overrides have no effect if C is supplied as the array-ref, OR the array is empty. Note as above that there are C and C methods to get the defaults. Currently the C method includes a separate search for F and F. This is so that if (as in C) there is no F supplied, you can provide one and add the location to the list of directories searched, using import as above. =head1 AUTHOR Ed J PDL-2.018/inc/Carp/0000755060175006010010000000000013110402045012020 5ustar chmNonePDL-2.018/inc/Carp/Heavy.pm0000644060175006010010000000044112562522365013453 0ustar chmNonepackage Carp; # On one line so MakeMaker will see it. use Carp; our $VERSION = $Carp::VERSION; 1; # Most of the machinery of Carp used to be there. # It has been moved in Carp.pm now, but this placeholder remains for # the benefit of modules that like to preload Carp::Heavy directly. PDL-2.018/inc/Carp.pm0000644060175006010010000004247112562522365012410 0ustar chmNonepackage Carp; use strict; use warnings; our $VERSION = '1.20'; $VERSION = eval $VERSION; our $MaxEvalLen = 0; our $Verbose = 0; our $CarpLevel = 0; our $MaxArgLen = 64; # How much of each argument to print. 0 = all. our $MaxArgNums = 8; # How many arguments to print. 0 = all. require Exporter; our @ISA = ('Exporter'); our @EXPORT = qw(confess croak carp); our @EXPORT_OK = qw(cluck verbose longmess shortmess); our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode # The members of %Internal are packages that are internal to perl. # Carp will not report errors from within these packages if it # can. The members of %CarpInternal are internal to Perl's warning # system. Carp will not report errors from within these packages # either, and will not report calls *to* these packages for carp and # croak. They replace $CarpLevel, which is deprecated. The # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval # text and function arguments should be formatted when printed. our %CarpInternal; our %Internal; # disable these by default, so they can live w/o require Carp $CarpInternal{Carp}++; $CarpInternal{warnings}++; $Internal{Exporter}++; $Internal{'Exporter::Heavy'}++; # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") # then the following method will be called by the Exporter which knows # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word # 'verbose'. sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } sub _cgc { no strict 'refs'; return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"}; return; } sub longmess { # Icky backwards compatibility wrapper. :-( # # The story is that the original implementation hard-coded the # number of call levels to go back, so calls to longmess were off # by one. Other code began calling longmess and expecting this # behaviour, so the replacement has to emulate that behaviour. my $cgc = _cgc(); my $call_pack = $cgc ? $cgc->() : caller(); if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) { return longmess_heavy(@_); } else { local $CarpLevel = $CarpLevel + 1; return longmess_heavy(@_); } } our @CARP_NOT; sub shortmess { my $cgc = _cgc(); # Icky backwards compatibility wrapper. :-( local @CARP_NOT = $cgc ? $cgc->() : caller(); shortmess_heavy(@_); } sub croak { die shortmess @_ } sub confess { die longmess @_ } sub carp { warn shortmess @_ } sub cluck { warn longmess @_ } sub caller_info { my $i = shift(@_) + 1; my %call_info; my $cgc = _cgc(); { package DB; @DB::args = \$i; # A sentinel, which no-one else has the address of @call_info{ qw(pack file line sub has_args wantarray evaltext is_require) } = $cgc ? $cgc->($i) : caller($i); } unless ( defined $call_info{pack} ) { return (); } my $sub_name = Carp::get_subname( \%call_info ); if ( $call_info{has_args} ) { my @args; if ( @DB::args == 1 && ref $DB::args[0] eq ref \$i && $DB::args[0] == \$i ) { @DB::args = (); # Don't let anyone see the address of $i local $@; my $where = eval { my $func = $cgc or return ''; my $gv = B::svref_2object($func)->GV; my $package = $gv->STASH->NAME; my $subname = $gv->NAME; return unless defined $package && defined $subname; # returning CORE::GLOBAL::caller isn't useful for tracing the cause: return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; " in &${package}::$subname"; }; $where = defined($where) ? $where : ''; @args = "** Incomplete caller override detected$where; \@DB::args were not set **"; } else { ## @args = map { Carp::format_arg($_) } @DB::args; for my $db_arg (@DB::args) { push @args, Carp::format_arg($db_arg) }; } if ( $MaxArgNums and @args > $MaxArgNums ) { # More than we want to show? $#args = $MaxArgNums; push @args, '...'; } # Push the args onto the subroutine $sub_name .= '(' . join( ', ', @args ) . ')'; } $call_info{sub_name} = $sub_name; return wantarray() ? %call_info : \%call_info; } # Transform an argument to a function into a string. sub format_arg { my $arg = shift; if ( ref($arg) ) { $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; } if ( defined($arg) ) { $arg =~ s/'/\\'/g; $arg = str_len_trim( $arg, $MaxArgLen ); # Quote it? $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/; } # 0-9, not \d, as \d will try to else { # load Unicode tables $arg = 'undef'; } # The following handling of "control chars" is direct from # the original code - it is broken on Unicode though. # Suggestions? utf8::is_utf8($arg) or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; return $arg; } # Takes an inheritance cache and a package and returns # an anon hash of known inheritances and anon array of # inheritances which consequences have not been figured # for. sub get_status { my $cache = shift; my $pkg = shift; $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ]; return @{ $cache->{$pkg} }; } # Takes the info from caller() and figures out the name of # the sub/require/eval sub get_subname { my $info = shift; if ( defined( $info->{evaltext} ) ) { my $eval = $info->{evaltext}; if ( $info->{is_require} ) { return "require $eval"; } else { $eval =~ s/([\\\'])/\\$1/g; return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'"; } } return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; } # Figures out what call (from the point of view of the caller) # the long error backtrace should start at. sub long_error_loc { my $i; my $lvl = $CarpLevel; { ++$i; my $cgc = _cgc(); my $pkg = $cgc ? $cgc->($i) : caller($i); unless ( defined($pkg) ) { # This *shouldn't* happen. if (%Internal) { local %Internal; $i = long_error_loc(); last; } else { # OK, now I am irritated. return 2; } } redo if $CarpInternal{$pkg}; redo unless 0 > --$lvl; redo if $Internal{$pkg}; } return $i - 1; } sub longmess_heavy { return @_ if ref( $_[0] ); # don't break references as exceptions my $i = long_error_loc(); return ret_backtrace( $i, @_ ); } # Returns a full stack backtrace starting from where it is # told. sub ret_backtrace { my ( $i, @error ) = @_; my $mess; my $err = join '', @error; $i++; my $tid_msg = ''; if ( defined &threads::tid ) { my $tid = threads->tid; $tid_msg = " thread $tid" if $tid; } my %i = caller_info($i); $mess = "$err at $i{file} line $i{line}$tid_msg\n"; while ( my %i = caller_info( ++$i ) ) { $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; } return $mess; } sub ret_summary { my ( $i, @error ) = @_; my $err = join '', @error; $i++; my $tid_msg = ''; if ( defined &threads::tid ) { my $tid = threads->tid; $tid_msg = " thread $tid" if $tid; } my %i = caller_info($i); return "$err at $i{file} line $i{line}$tid_msg\n"; } sub short_error_loc { # You have to create your (hash)ref out here, rather than defaulting it # inside trusts *on a lexical*, as you want it to persist across calls. # (You can default it on $_[2], but that gets messy) my $cache = {}; my $i = 1; my $lvl = $CarpLevel; { my $cgc = _cgc(); my $called = $cgc ? $cgc->($i) : caller($i); $i++; my $caller = $cgc ? $cgc->($i) : caller($i); return 0 unless defined($caller); # What happened? redo if $Internal{$caller}; redo if $CarpInternal{$caller}; redo if $CarpInternal{$called}; redo if trusts( $called, $caller, $cache ); redo if trusts( $caller, $called, $cache ); redo unless 0 > --$lvl; } return $i - 1; } sub shortmess_heavy { return longmess_heavy(@_) if $Verbose; return @_ if ref( $_[0] ); # don't break references as exceptions my $i = short_error_loc(); if ($i) { ret_summary( $i, @_ ); } else { longmess_heavy(@_); } } # If a string is too long, trims it with ... sub str_len_trim { my $str = shift; my $max = shift || 0; if ( 2 < $max and $max < length($str) ) { substr( $str, $max - 3 ) = '...'; } return $str; } # Takes two packages and an optional cache. Says whether the # first inherits from the second. # # Recursive versions of this have to work to avoid certain # possible endless loops, and when following long chains of # inheritance are less efficient. sub trusts { my $child = shift; my $parent = shift; my $cache = shift; my ( $known, $partial ) = get_status( $cache, $child ); # Figure out consequences until we have an answer while ( @$partial and not exists $known->{$parent} ) { my $anc = shift @$partial; next if exists $known->{$anc}; $known->{$anc}++; my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc ); my @found = keys %$anc_knows; @$known{@found} = (); push @$partial, @$anc_partial; } return exists $known->{$parent}; } # Takes a package and gives a list of those trusted directly sub trusts_directly { my $class = shift; no strict 'refs'; no warnings 'once'; return @{"$class\::CARP_NOT"} ? @{"$class\::CARP_NOT"} : @{"$class\::ISA"}; } 1; __END__ =head1 NAME Carp - alternative warn and die for modules =head1 SYNOPSIS use Carp; # warn user (from perspective of caller) carp "string trimmed to 80 chars"; # die of errors (from perspective of caller) croak "We're outta here!"; # die of errors with stack backtrace confess "not implemented"; # cluck not exported by default use Carp qw(cluck); cluck "This is how we got here!"; =head1 DESCRIPTION The Carp routines are useful in your own modules because they act like die() or warn(), but with a message which is more likely to be useful to a user of your module. In the case of cluck, confess, and longmess that context is a summary of every call in the call-stack. For a shorter message you can use C or C which report the error as being from where your module was called. There is no guarantee that that is where the error was, but it is a good educated guess. You can also alter the way the output and logic of C works, by changing some global variables in the C namespace. See the section on C below. Here is a more complete description of how C and C work. What they do is search the call-stack for a function call stack where they have not been told that there shouldn't be an error. If every call is marked safe, they give up and give a full stack backtrace instead. In other words they presume that the first likely looking potential suspect is guilty. Their rules for telling whether a call shouldn't generate errors work as follows: =over 4 =item 1. Any call from a package to itself is safe. =item 2. Packages claim that there won't be errors on calls to or from packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or (if that array is empty) C<@ISA>. The ability to override what @ISA says is new in 5.8. =item 3. The trust in item 2 is transitive. If A trusts B, and B trusts C, then A trusts C. So if you do not override C<@ISA> with C<@CARP_NOT>, then this trust relationship is identical to, "inherits from". =item 4. Any call from an internal Perl module is safe. (Nothing keeps user modules from marking themselves as internal to Perl, but this practice is discouraged.) =item 5. Any call to Perl's warning system (eg Carp itself) is safe. (This rule is what keeps it from reporting the error at the point where you call C or C.) =item 6. C<$Carp::CarpLevel> can be set to skip a fixed number of additional call levels. Using this is not recommended because it is very difficult to get it to behave correctly. =back =head2 Forcing a Stack Trace As a debugging aid, you can force Carp to treat a croak as a confess and a carp as a cluck across I modules. In other words, force a detailed stack trace to be given. This can be very helpful when trying to understand why, or from where, a warning or error is being generated. This feature is enabled by 'importing' the non-existent symbol 'verbose'. You would typically enable it by saying perl -MCarp=verbose script.pl or by including the string C<-MCarp=verbose> in the PERL5OPT environment variable. Alternately, you can set the global variable C<$Carp::Verbose> to true. See the C section below. =head1 GLOBAL VARIABLES =head2 $Carp::MaxEvalLen This variable determines how many characters of a string-eval are to be shown in the output. Use a value of C<0> to show all text. Defaults to C<0>. =head2 $Carp::MaxArgLen This variable determines how many characters of each argument to a function to print. Use a value of C<0> to show the full length of the argument. Defaults to C<64>. =head2 $Carp::MaxArgNums This variable determines how many arguments to each function to show. Use a value of C<0> to show all arguments to a function call. Defaults to C<8>. =head2 $Carp::Verbose This variable makes C and C generate stack backtraces just like C and C. This is how C is implemented internally. Defaults to C<0>. =head2 @CARP_NOT This variable, I, says which packages are I to be considered as the location of an error. The C and C functions will skip over callers when reporting where an error occurred. NB: This variable must be in the package's symbol table, thus: # These work our @CARP_NOT; # file scope use vars qw(@CARP_NOT); # package scope @My::Package::CARP_NOT = ... ; # explicit package variable # These don't work sub xyz { ... @CARP_NOT = ... } # w/o declarations above my @CARP_NOT; # even at top-level Example of use: package My::Carping::Package; use Carp; our @CARP_NOT; sub bar { .... or _error('Wrong input') } sub _error { # temporary control of where'ness, __PACKAGE__ is implicit local @CARP_NOT = qw(My::Friendly::Caller); carp(@_) } This would make C report the error as coming from a caller not in C, nor from C. Also read the L section above, about how C decides where the error is reported from. Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>. Overrides C's use of C<@ISA>. =head2 %Carp::Internal This says what packages are internal to Perl. C will never report an error as being from a line in a package that is internal to Perl. For example: $Carp::Internal{ (__PACKAGE__) }++; # time passes... sub foo { ... or confess("whatever") }; would give a full stack backtrace starting from the first caller outside of __PACKAGE__. (Unless that package was also internal to Perl.) =head2 %Carp::CarpInternal This says which packages are internal to Perl's warning system. For generating a full stack backtrace this is the same as being internal to Perl, the stack backtrace will not start inside packages that are listed in C<%Carp::CarpInternal>. But it is slightly different for the summary message generated by C or C. There errors will not be reported on any lines that are calling packages in C<%Carp::CarpInternal>. For example C itself is listed in C<%Carp::CarpInternal>. Therefore the full stack backtrace from C will not start inside of C, and the short message from calling C is not placed on the line where C was called. =head2 $Carp::CarpLevel This variable determines how many additional call frames are to be skipped that would not otherwise be when reporting where an error occurred on a call to one of C's functions. It is fairly easy to count these call frames on calls that generate a full stack backtrace. However it is much harder to do this accounting for calls that generate a short message. Usually people skip too many call frames. If they are lucky they skip enough that C goes all of the way through the call stack, realizes that something is wrong, and then generates a full stack backtrace. If they are unlucky then the error is reported from somewhere misleading very high in the call stack. Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>. Defaults to C<0>. =head1 BUGS The Carp routines don't handle exception objects currently. If called with a first argument that is a reference, they simply call die() or warn(), as appropriate. PDL-2.018/INSTALL0000644060175006010010000001427413036512175011440 0ustar chmNoneHINT ---- For the latest install and per-platform guidance on how to get and install PDL, see the Install PDL page at: http://pdl.perl.org/?page=install INSTALLATION ------------ To install PDL on your machine, first check that you have a recent enough version of Perl. 5.10.x and above is required. See win32/INSTALL for details on installing PDL on windows platforms. See cygwin/INSTALL for details on installing PDL on cygwin platforms. The file DEPENDENCIES summarizes the dependencies of various PDL modules on libraries/other packages. The location of some of these files needs to be specified in the file perldl.conf. PDL depends on a number of other Perl modules for feature complete operation. These modules are generally available at the CPAN. The easiest way to resolve these dependencies is to use the CPAN module to install PDL. Installation should be as simple as cpan install PDL # if the cpan script is in your path or if you don't have the cpan script try perl -MCPAN -e shell cpan> install PDL NOTE: if this is your first time running the cpan shell, you'll be prompted to configure the running environment. IMPORTANT: Be sure your cpan build_dir location does not have white space in the name. To check or change the setting, start the cpan shell as above, then to check: cpan> o conf build_dir build_dir [/your/build dir/.cpan] Type 'o conf' to view all configuration items And to change to something better: cpan> o conf build_dir '/your/build_dir/.cpan' build_dir [/your/build_dir/.cpan] Please use 'o conf commit' to make the config permanent! perldl.conf ----------- Edit the file perldl.conf in the PDL source directory to specify configuration options for building PDL. The comments in this file specify what the options are and give examples. NOTE: If you are happy with your perldl.conf you can keep the file handy for future reference. Place it in ~/.perldl.conf where it will be picked up automatically or use this command perl Makefile.PL PDLCONF=your_conf_file the next time you configure PDL. (You should check if new config flags were introduced when installing a new version of PDL by consulting its perldl.conf.) After editing the configuration options just say perl Makefile.PL in the directory this file is in. (See 'perldoc ExtUtils::MakeMaker' for info on how to configure the installation location, etc.) and if that seems ok, try: make If there are any strange error messages, please contact the developers with a full bug report; response is often rapid (We would like to have PDL work right out of the box on as many platforms as possible). If the make command completed successfully, try: make test to run the regression tests. If you have issues, please read Known_problems to see if they have been seen before. Again, if there are errors, please contact the developers (via the pdl-devel mailing list, see Basic/Pod/FAQ.pod). If everything works and you wish to install PDL, type make install There is also another make item: make doctest which creates the documentation database for use in the PDL shell (pdl2 or perldl). It will be run automatically on PDL install, but you may wish to run it by hand to have access to PDL on-line docs when running from the build directory before/without install. F77 Configuration ----------------- F77 configuration information is normally picked up from ExtUtils::F77 to build modules like PDL::Slatec that rely on a working fortran compiler. In cases where you don't want to rely on ExtUtils::F77 for one reason or another (e.g., a win32 build or other platform without ExtUtils::F77 support) there is now the config variable F77CONF. It is supposed to point to a perl file that implements a minimal F77Conf class (see debian/f77conf.pl for an example). The use of F77CONF is similar to the PDLCONF variable, e.g. perl Makefile.PL F77CONF=debian/f77conf.pl Note that almost always it is better to use ExtUtils::F77. Only use the F77CONF mechanism if you have a good reason to. Win32 is special. See win32/INSTALL. COMMON PROBLEMS --------------- If you have problems building or installing PDL, we suggest contacting the PDL users and developers via the PDL mailing lists. See http://pdl.perl.org/?page=mailing-lists to get started. Links to searchable archives of the lists are available on the same page. The build process has been significantly cleaned up since PDL-2.4.3. If you are unable to install PDL, even after consulting the list archives or other users and developers on the PDL lists, please do submit a bug report (see the BUGS file for directions). * Test failures in t/gis_proj.t, t/proj_transform.t, or t/proj_transform2.t with error messages that look like this (in the body of the test output, not the summary): ... not found _fwd_trans_inplace[BADCODE](): Projection initialization failed: major axis or radius = 0 or not given ... This indicates that the PROJ4 library on the system is either missing or cannot find the transformation parameter files. They are typically in a directory like /usr/share/proj and contain files with names like: epsg, nad27, nad83, conus,... If you find such a directory, try setting the PROJ_LIB environment variable to that location. If you do not have that directory, you may need to use your platform's package manager to install the missing component. E.g.: - Ubuntu: These are included in the libproj-dev. - Fedora: You have to install the proj-nad package. * make failures for PDL with error messages like: make: Warning: File `Makefile.PL' has modification time 3.1e+05 s in the future Makefile out-of-date with respect to Makefile.PL This problem has been seen on some Linux Virtual Machines where there was a problem with the synchronization of the VM time with the host OS system time. A quick work- around for the problem is to 'touch Makefile.PL' which updates the file time for Makefile.PL to "now" so make runs correctly. * If you wish to avoid interactive prompts during the PDL configure process (e.g., the perl Makefile.PL stage), you can set the environment variable PERL_MM_USE_DEFAULT to 1 so the default values are taken automatically. PDL-2.018/INTERNATIONALIZATION0000644060175006010010000000067112562522364013377 0ustar chmNoneTODO PDL currently does not have internationalization support for its error messages although perl itself does support i18n and locales. Some of the tests for names and strings are specific to ASCII and English. Please report any issues regarding internationalization to the perldl mailing lists. Of course, volunteers to implement this or help with the translations would be welcome. We need to see how other perl modules handle this. PDL-2.018/IO/0000755060175006010010000000000013110402046010672 5ustar chmNonePDL-2.018/IO/Browser/0000755060175006010010000000000013110402046012315 5ustar chmNonePDL-2.018/IO/Browser/browse.c0000644060175006010010000002132512562522364014005 0ustar chmNone#include #include #ifdef bool #undef bool #endif #ifdef CURSES #define CURSES_INC CURSES #else #define CURSES_INC "ncurses/curses.h" #endif #include CURSES_INC #include #include "EXTERN.h" // #include "perl.h" // #include "XSUB.h" #include "pdl.h" #define CHBUF 256 #ifndef MIN #define MIN(a,b) ((a)<(b)?(a):(b)) #endif #define HLAB 4 static int colwid, dcols, drows; /* enum pdl_datatypes { PDL_B, PDL_S, PDL_US, PDL_L, PDL_LL, PDL_F, PDL_D }; */ char *format[] = { "%3d", "%6d", "%6hd", "%11ld", "%11lld", "%10.4g", "%11.4g" }; int width[] = { 4, 7, 7, 12, 12, 11, 12 }; char *str_value(int x, int y, int type, int nx, void *data, char *str) { switch (type) { case PDL_B: sprintf(str,format[type],*(((char *)data)+y*nx+x)); break; case PDL_S: sprintf(str,format[type],*(((short *)data)+y*nx+x)); break; case PDL_US: sprintf(str,format[type],*(((unsigned short *)data)+y*nx+x)); break; case PDL_L: sprintf(str,format[type],*(((int *)data)+y*nx+x)); break; case PDL_LL: sprintf(str,format[type],*(((long long *)data)+y*nx+x)); break; case PDL_F: sprintf(str,format[type],*(((float *)data)+y*nx+x)); break; case PDL_D: sprintf(str,format[type],*(((double *)data)+y*nx+x)); break; default: Perl_croak("type (val=%d) not implemented",type); break; } return str; } void set_value(int x, int y, int type, int nx, void *data, char *str) { switch (type) { case PDL_B: *(((PDL_Byte *)data)+y*nx+x) = atol(str); break; case PDL_S: *(((PDL_Short *)data)+y*nx+x) = atol(str); break; case PDL_US: *(((PDL_Ushort *)data)+y*nx+x) = atol(str); break; case PDL_L: *(((PDL_Long *)data)+y*nx+x) = atol(str); break; case PDL_LL: *(((PDL_LongLong *)data)+y*nx+x) = atol(str); break; case PDL_F: *(((PDL_Float *)data)+y*nx+x) = atof(str); break; case PDL_D: *(((PDL_Double *)data)+y*nx+x) = atof(str); break; default: Perl_croak("type (val=%d) not implemented",type); break; } return; } void update_vlab(WINDOW *win, int x, int ioff) { char line[BUFSIZ]; int len, k, d; chtype chline[BUFSIZ]; extern int colwid; for (k=0;k= 32 && ch <= 127) { clear_cell(warray,i-ioff,j-joff); wrefresh(warray); } mvwaddch(warray,j-joff,(i-ioff)*colwid+MIN(eps,colwid-2),ch|A_UNDERLINE); line[eps++]=ch; continue; } switch (ch) { case KEY_LEFT: i = (i<2)?0:i-1; if (i-ioff == -1) { ioff--; wtmp = newwin(1,mycols-colwid,1,HLAB); overwrite(wvlab,wtmp); mvwin(wtmp,1,HLAB+colwid); overwrite(wtmp,wvlab); delwin(wtmp); update_vlab(wvlab,0,ioff); wtmp = newwin(drows,mycols-colwid,2,HLAB); overwrite(warray,wtmp); mvwin(wtmp,2,HLAB+colwid); overwrite(wtmp,warray); delwin(wtmp); update_col(warray,0,ioff,joff,type,nc,in); wrefresh(warray); wrefresh(wvlab); } break; case KEY_RIGHT: case '\t': i = (i>nc-2)?nc-1:i+1; if (i-ioff == dcols) { ioff++; wtmp = newwin(1,mycols-colwid,1,HLAB+colwid); overwrite(wvlab,wtmp); mvwin(wtmp,1,HLAB); overwrite(wtmp,wvlab); delwin(wtmp); update_vlab(wvlab,dcols-1,ioff); wtmp = newwin(drows,mycols-colwid,2,HLAB+colwid); overwrite(warray,wtmp); mvwin(wtmp,2,HLAB); overwrite(wtmp,warray); delwin(wtmp); update_col(warray,dcols-1,ioff,joff,type,nc,in); wrefresh(warray); wrefresh(wvlab); } break; case KEY_UP: j = (j<2)?0:j-1; if (j-joff == -1) { joff--; wscrl(wscroll,-1); wrefresh(wscroll); update_hlab(whlab,0,joff); wrefresh(whlab); update_row(warray,0,ioff,joff,type,nc,in); wrefresh(warray); } break; case KEY_DOWN: case '\015': j = (j>nr-2)?nr-1:j+1; if (j-joff == drows) { joff++; wscrl(wscroll,1); wrefresh(wscroll); update_hlab(whlab,drows-1,joff); wrefresh(whlab); update_row(warray,drows-1,ioff,joff,type,nc,in); wrefresh(warray); } break; } } nl(); echo(); nocbreak(); endwin(); } #ifdef WITH_IO_BROWSER_MAIN main () { double b[27*15]; int i, j; j = 0; for (i=0; i<27*15; i++) { b[i] = j++; } browse(PDL_D, 27, 15, &b); } #endif PDL-2.018/IO/Browser/browser.pd0000644060175006010010000000204612562522364014347 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::IO::Browser -- 2D data browser for PDL =head1 DESCRIPTION cursor terminal browser for piddles. =head1 SYNOPSIS use PDL::IO::Browser; =cut EOD use PDL::Types; pp_def( 'browse', Pars => 'a(n,m);', Code => " browse(\$TBSULQFD($PDL_B,$PDL_S,$PDL_US,$PDL_L,$PDL_LL,$PDL_F,$PDL_D), \$SIZE(n),\$SIZE(m),\$P(a)); ", GenericTypes => [qw(B S U L Q F D)], Doc=><<'EOD'); =head2 browse =for ref browse a 2D array using terminal cursor keys =for usage browse $data This uses the CURSES library to allow one to scroll around a PDL array using the cursor keys. =cut EOD pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR Copyright (C) Robin Williams 1997 (rjrw@ast.leeds.ac.uk). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.018/IO/Browser/hints/0000755060175006010010000000000013110402046013442 5ustar chmNonePDL-2.018/IO/Browser/hints/dec_osf.pl0000644060175006010010000000044412562522364015423 0ustar chmNone# Achim Bohnet : # # /usr/include/curses.h claims that derwin() is part of: # # #ifdef _XOPEN_SOURCE_EXTENDED # # /* These are the ENHANCED CURSES interfaces in X/Open Curses, Issue 4 */ # $self->{'DEFINE'} .= ' -D_XOPEN_SOURCE_EXTENDED -D_POSIX_C_SOURCE=199506L'; PDL-2.018/IO/Browser/Makefile.PL0000644060175006010010000000274712562522364014321 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use File::Spec; use Devel::CheckLib; my @pack = (["browser.pd", qw(Browser PDL::IO::Browser)]); my %hash = pdlpp_stdargs_int(@pack); $hash{'OBJECT'} .= ' browse$(OBJ_EXT)'; $hash{'clean'}{FILES} .= ' browse$(OBJ_EXT) browse$(EXE_EXT) Browser.c Browser.pm Browser.xs Browser$(OBJ_EXT)'; # Here we check for working curses/ncurses # and the corresponding "curses.h" and "ncurses/curses.h" # # (1) Determine which library we have: curses or ncurses # (2) determine which include path # (3) determine which include file # (4) confirm configuration # (5) write Makefile or dummy as appropriate my $incstring; foreach my $incl ( qw( curses.h ncurses/curses.h ncurses.h ncurses/ncurses.h ncursesw/ncurses.h ) ) { if (check_lib(header=>$incl)) { print "IO/Browser: have '$incl'\n"; $incstring = $incl; last; } }; $hash{DEFINE} .= ' -DCURSES=' . '\\"' . $incstring . '\\"' if defined $incstring; my $libstring; foreach my $libr ( qw( curses ncurses ncursesw ) ) { if (check_lib(lib=>$libr)) { print "IO/Browser: have -l$libr\n"; $libstring = '-l' . $libr; last; } } push @{$hash{LIBS}} , $libstring if defined $libstring; # Add genpp rule undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; if (defined($incstring) && defined($libstring)) { WriteMakefile(%hash); } else { write_dummy_make("Curses capable library not found, not building PDL::IO::Browser"); } PDL-2.018/IO/Dicom/0000755060175006010010000000000013110402045011724 5ustar chmNonePDL-2.018/IO/Dicom/Dicom.pm0000644060175006010010000002772212562522364013350 0ustar chmNone=pod =head1 NAME PDL::IO::Dicom - a module for reading DICOM images. =head1 DESCRIPTION The PDL::IO::Dicom module enables reading 16-bit gray level Dicom images into PDL. As Dicom is an extremely complex format, this module can unfortunately not handle all different image types included in the DICOM standard. One common format that is currently not supported is the Papyrus format. =head1 USAGE use PDL; use PDL::IO::Dicom; $img = rdcm("image.dcm"); =head1 AUTHOR Copyright (C) Dov Grobgeld 2002. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::IO::Dicom; use PDL; use PDL::Core; use PDL::IO::Misc; use Exporter; @ISA = qw( Exporter ); @EXPORT = qw( rdcm ); use strict; my $debug = 0; my %element_table = ( "0002,0000" => ["Group length","UL"], "0002,0001" => ["File Meta Information Version","OB"], "0002,0002" => ["Media Storage SOP Class UID","UI"], "0002,0003" => ["Media Storage SOP Instance UID","UI"], "0002,0010" => ["Transfer Syntax UID","UI"], "0002,0012" => ["Implementation Class UID","UI"], "0002,0013" => ["Implementation Version Name","SH"], "0002,0016" => ["Source Application Entity Title","AE"], "0008,0000" => ["Identifying Group Length", "UL"], "0008,0001" => ["Length to End"], "0008,0005" => ["Specific Character Set","CS"], "0008,0008" => ["Image Type","CS"], "0008,0010" => ["Recognition Code"], "0008,0012" => ["Instance Creation Date"], "0008,0013" => ["Instance Creation Time"], "0008,0014" => ["Instance Creator UID"], "0008,0016" => ["SOP Class UID","UI"], "0008,0018" => ["SOP Instance UID","UI"], "0008,0020" => ["Study Date","DA"], "0008,0021" => ["Series date","DA"], "0008,0022" => ["Acquisition Date","DA"], "0008,0023" => ["Image Date","DA"], "0008,0030" => ["Study Time","TM"], "0008,0031" => ["Series Time","TM"], "0008,0032" => ["Acquisition Time","TM"], "0008,0033" => ["Image Time","TM"], "0008,103e" => ["Series Description"], "0008,1030" => ["Study Description"], "0008,0050" => ["Accession Number","SH"], "0008,0060" => ["Modality","CS"], "0008,0070" => ["Manufacturer","LO"], "0008,0080" => ["Institution Name","LO"], "0008,0090" => ["Referring Physician's Name","PN"], "0008,1010" => ["Station Name","SH"], "0008,1030" => ["Study Description","LO"], "0008,103e" => ["Series Description","LO"], "0008,1060" => ["Name of Physician(s)","PN"], "0008,1090" => ["Manufacturers Model Name",], "0010,0000" => ["Patient Information Group"], "0010,0010" => ["Patient Name","PN"], "0010,0020" => ["Patient ID"], "0010,0030" => ["Patient Birth Date"], "0010,0040" => ["Patient's Sex"], "0010,1010" => ["Patient Age"], "0010,1030" => ["Patient Weight"], "0018,0000" => ["Acquisition Gnformation Group"], "0018,0010" => ["Contrast/Bolus Agent"], "0018,0020" => ["Scanning Sequence"], "0018,0022" => ["Scan Options"], "0018,0050" => ["Slice thickness"], "0018,1050" => ["Spatial Resolution", "lO"], "0008,1060" => ["Name of Physician(s) Reading Study"], "0008,1070" => ["Operator's Name"], "0018,0080" => ["Repetition Time"], "0018,0081" => ["Echo Time"], "0018,0082" => ["Inversion Time"], "0018,0083" => ["Number of Averages"], "0018,0084" => ["Imaging Frequency"], "0018,0085" => ["Imaged Nucleus"], "0018,0086" => ["Echo Number(s)"], "0018,0087" => ["Magnetic Field Strength"], "0018,0088" => ["Spacing Between Slices"], "0018,0089" => ["Number of Phase Encoding Steps"], "0018,0090" => ["Data Collection Diameter"], "0018,0091" => ["Echo Train Length"], "0018,0093" => ["Percent Sampling"], "0018,0094" => ["Percent Phase Field of View"], "0018,0095" => ["Pixel Bandwidth"], "0018,1088" => ["Heart Rate","US"], "0018,1090" => ["Cardiac Number of Images","US"], "0018,1094" => ["Trigger Window","US"], "0018,1100" => ["Reconstruction Diameter"], "0018,1314" => ["Flip Angle"], "0018,1315" => ["Variable Flip Angle Flag"], "0018,1316" => ["SAR"], "0020,0000" => ["Relationship information group"], "0020,000d" => ["Study Instance UID"], "0020,000e" => ["Series Instance UID"], "0020,0010" => ["Study ID"], "0020,0011" => ["Series Number"], "0020,0012" => ["Acquisition Number"], "0020,0013" => ["Image Number"], "0020,0014" => ["Isotope Number"], "0020,0015" => ["Phase Number"], "0020,0016" => ["Interval Number"], "0020,0017" => ["Time Slot Number"], "0020,0018" => ["Angle Number"], "0020,0020" => ["Patient Orientation"], "0020,0022" => ["Overlay Number"], "0020,0024" => ["Curve Number"], "0020,0026" => ["LUT Number"], "0020,0030" => ["Image Position"], "0020,0032" => ["Image Position (Patient)"], "0020,0035" => ["Image Orientation"], "0020,0037" => ["Image Orientation (Patient)"], "0020,0050" => ["Location"], "0020,0052" => ["Frame of Reference UID"], "0020,0060" => ["Laterality"], "0020,1002" => ["Images in acqusition"], "0020,1040" => ["Position Reference Indicator"], "0020,1041" => ["Slice Location"], "0028,0000" => ["Relationship information group"], "0028,0002" => ["Samples per Pixel"], "0028,0004" => ["Photometric Interpretation"], "0028,0005" => ["Image Dimensions"], "0028,0010" => ["Rows", "US"], "0028,0011" => ["Columns", "US"], "0028,0030" => ["Pixel Spacing"], "0028,0100" => ["Bits Allocated","US"], "0028,0101" => ["Bits Stored", "US"], "0028,0102" => ["High Bit","US"], "0028,0103" => ["Pixel Representation","US"], "0028,1052" => ["Rescale Intercept"], "0028,1053" => ["Rescale Slope"], "0033,1002" => ["IMGF"], "7fe0,0000" => ["Pixel Data Information Group", "UL"], "7fe0,0010" => ["Pixel Data","OW"] ); =head1 FUNCTIONS =head2 rdcm =for ref Read a dicom image. =for usage $dcm = rdcm("filename") =cut sub rdcm { my $file = shift; my $options = shift; my $do_print_info = 0; my (%info, %bin); my $do_raw = 0; # Only for debugging my ($rescale_intercept, $rescale_slope) = (0, 1); my $do_explicit = 0; my $do_guess_endian = 1; # options if ($options) { if (defined $options->{do_print_info}) { $do_print_info = $options->{do_print_info}; } } open(IN, $file) || die "Failed opening image $file!\n"; binmode IN; # read the whole image my $header; read(IN, $header, -s $file); # File preamble - a fixed 128 byte field my $hpos = 0x80; # Next four bytes should be DICM if (substr($header, $hpos, 4) ne 'DICM') { die "This is not a DICM file!\n"; } $hpos+= 4; # Precheck if the first entry has explicit vr. Unfortunately this # is not enough to determine if the file always has explicit value # representation. if (substr($header, $hpos+4, 2)=~ /[A-Z]{2}/) { $do_explicit++; } while($hpos < length($header)) { my $is_binary = 0; my $groupword = unpack("v", substr($header, $hpos, 2)); $hpos+=2; my $elementword = unpack("v", substr($header, $hpos, 2)); $hpos+=2; my $value_rep = substr($header, $hpos, 2); my $key = sprintf("%04x,%04x", $groupword, $elementword); my ($lookup) = $element_table{$key}; my $override_vr = 0; # Check for explicit value representation. There must be a different # way to figure this out, but I still haven't figured out how! if ($value_rep =~ /[A-Z][A-Z]/) { $hpos+=2; } else { $override_vr++; $value_rep = $lookup->[1] || "UN"; } my $elementlength; if (substr($header, $hpos, 4) eq "IMGF") { die "No support for IMGF files at the moment!\n"; } # The following calculation agrees with dicom3tools if ($override_vr) { $elementlength = unpack("V", substr($header, $hpos, 4)); $hpos+= 4; } elsif (grep($value_rep eq $_, qw(OB OW SQ UN))) { # Long length $is_binary = 1; $hpos+= 2; # Always zero $elementlength = unpack("V", substr($header, $hpos, 4)); $hpos+= 4; } else { # Short length $elementlength = unpack("v", substr($header, $hpos, 2)); $hpos+= 2; } my ($descr) = ""; my $contents = substr($header, $hpos, $elementlength) . ""; ($descr) = @$lookup if $lookup; # recode contents if ($value_rep eq "UL") { $contents = unpack("V", $contents); } elsif ($value_rep eq "US") { $contents = unpack("v", $contents); } elsif ($value_rep eq "TM") { $contents = clean_time($contents); } elsif ($value_rep eq "DA") { $contents = clean_date($contents); } elsif (!$is_binary) { $contents=~ s/\s+$//; } # store the contents if ($key eq "7fe0,0010") { # Pixel data $bin{$descr} = $contents; } else { $info{$descr} = $contents if $descr; } if ($do_print_info) { $contents = "" unless $contents; $contents = "<>" if $is_binary; $contents=~ tr/\0-\037\200-\377//d; $contents= substr($contents, 0, 40) unless $do_raw; $contents=~ s/[\0-\037\200]/?/g; $value_rep=~ s/[\0-\037]/?/g; printf STDERR "%04x> %04x,%04x (%04x,$value_rep) %-30s : %s\n", $hpos, $groupword, $elementword, $elementlength, $descr, $contents; } $hpos+= $elementlength; } my($width, $height) = ($info{Columns}, $info{Rows}); my($bs) = $info{"Bits Allocated"}/8; my $img = $bin{"Pixel Data"}; # The following logics works on Intel endian my $do_toggle_endian = $info{"Pixel Representation"}; $rescale_intercept = $info{"Rescale Intercept"} if defined $info{"Rescale Intercept"}; $rescale_slope = $info{"Rescale Slope"} if defined $info{"Rescale Slope"}; my $pdl; # Create a pdl from the raw data if ($bs == 2) { $pdl = zeroes(ushort, $width,$height); my $hdr = $pdl->gethdr; $pdl->make_physical(); # Store the pixel data ${$pdl->get_dataref()} = $img; # Guess endian if ($do_guess_endian) { # Compare spread of high byte with low byte my $high_byte = ($pdl>>8)->byte; my $low_byte = ($pdl & 0xff)->byte; my $max_high = $high_byte->max; my $max_low = $low_byte->max; # print STDERR "max_high max-low = $max_high $max_low\n"; # The following might need to be adjusted on different # architectures. $do_toggle_endian = $max_high > $max_low; } # Endian swap if ($do_toggle_endian) { bswap2($pdl); } # Rescale and convert to double if ($rescale_intercept != 0 || $rescale_slope != 1) { print STDERR "scaling with $rescale_slope and $rescale_intercept\n"; $pdl = 1.0*($pdl * $rescale_slope) + $rescale_intercept; } } else { die "Sorry! PDL::IO::Dicom currently only supported DICOM with bs=2. bs = $bs\n"; } # Store the info in the pdl header $pdl->sethdr(\%info); return $pdl; } sub clean_time { my $time = shift; my ($hour, $min, $sec, $sec_frac); if ($time=~ /(\d+):(\d+):(\d+)\.?(\d*)/) { ($hour,$min,$sec,$sec_frac) = ($1,$2,$3,$4); } elsif ($time=~ /(\d\d)(\d\d)(\d\d)\.?(\d+)/) { ($hour,$min,$sec,$sec_frac) = ($1,$2,$3,$4); } if (defined $hour) { $time = sprintf("%02d:%02d:%02d", $hour, $min, $sec); $time .= ".$sec_frac" if $sec_frac; } return $time; } sub clean_date { my $date = shift; $date=~ s/(\d\d\d\d)(\d\d)(\d\d)/$1-$2-$3/; return $date; } =head1 AUTHOR Copyright (C) Dov Grobgeld 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut 1; PDL-2.018/IO/Dicom/Makefile.PL0000644060175006010010000000065012562522364013720 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; # With dmake a postamble is sometimes (incorrectly) written # in the Makefile. The following prevents that: undef &MY::postamble; # suppress warning *MY::postamble = sub { return ""; }; WriteMakefile( NAME => "PDL::IO::Dicom", 'VERSION_FROM' => '../../Basic/Core/Version.pm', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/Dumper.pm0000644060175006010010000004252213036512175012505 0ustar chmNone=head1 NAME PDL::IO::Dumper -- data dumping for structs with PDLs =head1 DESCRIPTION This package allows you cleanly to save and restore complex data structures which include PDLs, as ASCII strings and/or transportable ASCII files. It exports four functions into your namespace: sdump, fdump, frestore, and deep_copy. PDL::IO::Dumper traverses the same types of structure that Data::Dumper knows about, because it uses a call to Data::Dumper. Unlike Data::Dumper it doesn't crash when accessing PDLs. The PDL::IO::Dumper routines have a slightly different syntax than Data::Dumper does: you may only dump a single scalar perl expression rather than an arbitrary one. Of course, the scalar may be a ref to whatever humongous pile of spaghetti you want, so that's no big loss. The output string is intended to be about as readable as Dumper's output is for non-PDL expressions. To that end, small PDLs (up to 8 elements) are stored as inline perl expressions, midsized PDLs (up to 200 elements) are stored as perl expressions above the main data structure, and large PDLs are stored as FITS files that are uuencoded and included in the dump string. (You have to have access to either uuencode(1) or the CPAN module Convert::UU for this to work). No attempt is made to shrink the output string -- for example, inlined PDL expressions all include explicit reshape() and typecast commands, and uuencoding expands stuff by a factor of about 1.5. So your data structures will grow when you dump them. =head1 Bugs It's still possible to break this code and cause it to dump core, for the same reason that Data::Dumper crashes. In particular, other external-hook variables aren't recognized (for that a more universal Dumper would be needed) and will still exercise the Data::Dumper crash. This is by choice: (A) it's difficult to recognize which objects are actually external, and (B) most everyday objects are quite safe. Another shortfall of Data::Dumper is that it doesn't recognize tied objects. This might be a Good Thing or a Bad Thing depending on your point of view, but it means that PDL::IO::Dumper includes a kludge to handle the tied Astro::FITS::Header objects associated with FITS headers (see the rfits documentation in PDL::IO::Misc for details). There's currently no reference recursion detection, so a non-treelike reference topology will cause Dumper to buzz forever. That will likely be fixed in a future version. Meanwhile a warning message finds likely cases. =head1 Author, copyright, no warranty Copyright 2002, Craig DeForest. This code may be distributed under the same terms as Perl itself (license available at L). Copying, reverse engineering, distribution, and modification are explicitly allowed so long as this notice is preserved intact and modified versions are clearly marked as such. This package comes with NO WARRANTY. =head1 HISTORY =over 3 =item * 1.0: initial release =item * 1.1 (26-Feb-2002): Shorter form for short PDLs; more readability =item * 1.2 (28-Feb-2002): Added deep_copy() -- exported convenience function for "eval sdump" =item * 1.3 (15-May-2002): Added checking for tied objects in gethdr() [workaround for hole in Data::Dumper] =item * 1.4 (15-Jan-2003): Added support for Convert::UU as well as command-line uu{en|de}code =back =head1 FUNCTIONS =cut # use PDL::NiceSlice; package PDL::IO::Dumper; use File::Temp; BEGIN{ use Exporter (); package PDL::IO::Dumper; $PDL::IO::Dumper::VERSION = '1.3.2'; @PDL::IO::Dumper::ISA = ( Exporter ) ; @PDL::IO::Dumper::EXPORT_OK = qw( fdump sdump frestore deep_copy); @PDL::IO::Dumper::EXPORT = @EXPORT_OK; %PDL::IO::Dumper::EXPORT_TAGS = ( Func=>[@EXPORT_OK]); eval "use Convert::UU;"; $PDL::IO::Dumper::convert_ok = !$@; my $checkprog = sub { my($prog) = $_[0]; my $pathsep = $^O =~ /win32/i ? ';' : ':'; my $exe = $^O =~ /win32/i ? '.exe' : ''; for(split $pathsep,$ENV{PATH}){return 1 if -x "$_/$prog$exe"} return 0; }; # make sure not to use uuencode/uudecode # on MSWin32 systems (it doesn't work) # Force Convert::UU for BSD systems to see if that fixes uudecode problem if (($^O !~ /(MSWin32|bsd)$/) or ($^O eq 'gnukfreebsd')) { $PDL::IO::Dumper::uudecode_ok = &$checkprog('uudecode') and &$checkprog('uuencode') and ($^O !~ /MSWin32/); } use PDL; use PDL::Exporter; use PDL::Config; use Data::Dumper 2.121; use Carp; use IO::File; } ###################################################################### =head2 sdump =for ref Dump a data structure to a string. =for usage use PDL::IO::Dumper; $s = sdump(); ... = eval $s; =for description sdump dumps a single complex data structure into a string. You restore the data structure by eval-ing the string. Since eval is a builtin, no convenience routine exists to use it. =cut sub PDL::IO::Dumper::sdump { # Make an initial dump... my($s) = Data::Dumper->Dump([@_]); my(%pdls); # Find the bless(...,'PDL') lines while($s =~ s/bless\( do\{\\\(my \$o \= '?(-?\d+)'?\)\}\, \'PDL\' \)/sprintf('$PDL_%u',$1)/e) { $pdls{$1}++; } ## Check for duplicates -- a weak proxy for recursion... my($v); my($dups); foreach $v(keys %pdls) { $dups++ if($pdls{$v} >1); } print STDERR "Warning: duplicated PDL ref. If sdump hangs, you have a circular reference.\n" if($dups); # This next is broken into two parts to ensure $s is evaluated *after* the # find_PDLs call (which modifies $s using the s/// operator). my($s2) = "{my(\$VAR1);\n".&PDL::IO::Dumper::find_PDLs(\$s,@_)."\n\n"; return $s2.$s."\n}"; # } ###################################################################### =head2 fdump =for ref Dump a data structure to a file =for usage use PDL::IO::Dumper; fdump(,$filename); ... = frestore($filename); =for description fdump dumps a single complex data structure to a file. You restore the data structure by eval-ing the perl code put in the file. A convenience routine (frestore) exists to do it for you. I suggest using the extension '.pld' or (for non-broken OS's) '.pdld' to distinguish Dumper files. That way they are reminiscent of .pl files for perl, while still looking a little different so you can pick them out. You can certainly feed a dump file straight into perl (for syntax checking) but it will not do much for you, just build your data structure and exit. =cut sub PDL::IO::Dumper::fdump { my($struct,$file) = @_; my $fh = IO::File->new( ">$file" ); unless ( defined $fh ) { Carp::cluck ("fdump: couldn't open '$file'\n"); return undef; } $fh->print( "####################\n## PDL::IO::Dumper dump file -- eval this in perl/PDL.\n\n" ); $fh->print( sdump($struct) ); $fh->close(); return $struct; } ###################################################################### =head2 frestore =for ref Restore a dumped file =for usage use PDL::IO::Dumper; fdump(,$filename); ... = frestore($filename); =for description frestore() is a convenience function that just reads in the named file and executes it in an eval. It's paired with fdump(). =cut sub PDL::IO::Dumper::frestore { local($_); my($fname) = shift; my $fh = IO::File->new( "<$fname" ); unless ( defined $fh ) { Carp::cluck("frestore: couldn't open '$file'\n"); return undef; } my($file) = join("",<$fh>); $fh->close; return eval $file; } ###################################################################### =head2 deep_copy =for ref Convenience function copies a complete perl data structure by the brute force method of "eval sdump". =cut sub PDL::IO::Dumper::deep_copy { return eval sdump @_; } ###################################################################### =head2 PDL::IO::Dumper::big_PDL =for ref Identify whether a PDL is ``big'' [Internal routine] Internal routine takes a PDL and returns a boolean indicating whether it's small enough for direct insertion into the dump string. If 0, it can be inserted. Larger numbers yield larger scopes of PDL. 1 implies that it should be broken out but can be handled with a couple of perl commands; 2 implies full uudecode treatment. PDLs with Astro::FITS::Header objects as headers are taken to be FITS files and are always treated as huge, regardless of size. =cut $PDL::IO::Dumper::small_thresh = 8; # Smaller than this gets inlined $PDL::IO::Dumper::med_thresh = 400; # Smaller than this gets eval'ed # Any bigger gets uuencoded sub PDL::IO::Dumper::big_PDL { my($a) = shift; return 0 if($a->nelem <= $PDL::IO::Dumper::small_thresh && !(keys %{$a->hdr()}) ); return 1 if($a->nelem <= $PDL::IO::Dumper::med_thresh && ( !( ( (tied %{$a->hdr()}) || '' ) =~ m/^Astro::FITS::Header\=/) ) ); return 2; } ###################################################################### =head2 PDL::IO::Dumper::stringify_PDL =for ref Turn a PDL into a 1-part perl expr [Internal routine] Internal routine that takes a PDL and returns a perl string that evals to the PDL. It should be used with care because it doesn't dump headers and it doesn't check number of elements. The point here is that numbers are dumped with the correct precision for their storage class. Things we don't know about get stringified element-by-element by their builtin class, which is probably not a bad guess. =cut %PDL::IO::Dumper::stringify_formats = ( "byte"=>"%d", "short"=>"%d", "long"=>"%d", "float"=>"%.6g", "double"=>"%.16g" ); sub PDL::IO::Dumper::stringify_PDL{ my($pdl) = shift; if(!ref $pdl) { confess "PDL::IO::Dumper::stringify -- got a non-pdl value!\n"; die; } ## Special case: empty PDL if($pdl->nelem == 0) { return "which(pdl(0))"; } ## Normal case: Figure out how to dump each number and dump them ## in sequence as ASCII strings... my($pdlflat) = $pdl->flat; my($t) = $pdl->type; my($s); my(@s); my($dmp_elt); if(defined $PDL::IO::Dumper::stringify_formats{$t}) { $dmp_elt = eval "sub { sprintf '$PDL::IO::Dumper::stringify_formats{$t}',shift }"; } else { if(!$PDL::IO::Dumper::stringify_warned) { print STDERR "PDL::IO::Dumper: Warning, stringifying a '$t' PDL using default method\n\t(Will be silent after this)\n"; $PDL::IO::Dumper::stringify_warned = 1; } $dmp_elt = sub { my($a) = shift; "$a"; }; } $i = 0; my($i); for($i = 0; $i < $pdl->nelem; $i++) { push(@s, &{$dmp_elt}( $pdlflat->slice("($i)") ) ); } ## Assemble all the strings and bracket with a pdl() call. $s = ($PDL::IO::Dumper::stringify_formats{$t}?$t:'pdl'). "(" . join( "," , @s ) . ")". (($_->getndims > 1) && ("->reshape(" . join(",",$pdl->dims) . ")")); return $s; } ###################################################################### =head2 PDL::IO::Dumper::uudecode_PDL =for ref Recover a PDL from a uuencoded string [Internal routine] This routine encapsulates uudecoding of the dumped string for large piddles. It's separate to encapsulate the decision about which method of uudecoding to try (both the built-in Convert::UU and the shell command uudecode(1) are supported). =cut # should we use OS/library-level routines for creating # a temporary filename? # sub _make_tmpname () { # should we use File::Spec routines to create the file name? return File::Temp::tmpnam() . ".fits"; } # For uudecode_PDL: # # uudecode on OS-X needs the -s option otherwise it strips off the # path of the data file - which messes things up. We could change the # logic so that we explicitly tell uudecode where to create the output # file, except that this is also OS-dependent (-o on OS-X/linux, # -p on solaris/OS-X to write to stdout, any others?), # so we go this way for now as it is less-likely to break things # my $uudecode_string = "|uudecode"; $uudecode_string .= " -s" if (($^O =~ m/darwin|((free|open)bsd)|dragonfly/) and ($^O ne 'gnukfreebsd')); sub PDL::IO::Dumper::uudecode_PDL { my $lines = shift; my $out; my $fname = _make_tmpname(); if($PDL::IO::Dumper::uudecode_ok) { local $SIG{PIPE}= sub {}; # Prevent crashing if uudecode exits my $fh = IO::File->new( $uudecode_string ); $lines =~ s/^[^\n]*\n/begin 664 $fname\n/o; $fh->print( $lines ); $fh->close; } elsif($PDL::IO::Dumper::convert_ok) { my $fh = IO::File->new(">$fname"); my $fits = Convert::UU::uudecode($lines); $fh->print( $fits ); $fh->close(); } else { barf("Need either uudecode(1) or Convert::UU to decode dumped PDL.\n"); } $out = rfits($fname); unlink($fname); $out; } =head2 PDL::IO::Dumper::dump_PDL =for ref Generate 1- or 2-part expr for a PDL [Internal routine] Internal routine that produces commands defining a PDL. You supply (, ) and get back two strings: a prepended command string and an expr that evaluates to the final PDL. PDL is the PDL you want to dump. is a flag whether dump_PDL is being called inline or before the inline dump string (0 for before; 1 for in). is the name of the variable to be assigned (for medium and large PDLs, which are defined before the dump string and assigned unique IDs). =cut sub PDL::IO::Dumper::dump_PDL { local($_) = shift; my($pdlid) = @_; my(@out); my($style) = &PDL::IO::Dumper::big_PDL($_); if($style==0) { @out = ("", "( ". &PDL::IO::Dumper::stringify_PDL($_). " )"); } else { my(@s); ## midsized case if($style==1){ @s = ("my(\$$pdlid) = (", &PDL::IO::Dumper::stringify_PDL($_), ");\n"); } ## huge case else { ## ## Write FITS file, uuencode it, snarf it up, and clean up the ## temporary directory ## my $fname = _make_tmpname(); wfits($_,$fname); my(@uulines); if($PDL::IO::Dumper::uudecode_ok) { my $fh = IO::File->new( "uuencode $fname $fname |" ); @uulines = <$fh>; $fh->close; } elsif($PDL::IO::Dumper::convert_ok) { # Convert::UU::uuencode does not accept IO::File handles # (at least in version 0.52 of the module) # open(FITSFILE,"<$fname"); @uulines = ( Convert::UU::uuencode(*FITSFILE) ); } else { barf("dump_PDL: Requires either uuencode or Convert:UU"); } unlink $fname; ## ## Generate commands to uudecode the FITS file and resnarf it ## @s = ("my(\$$pdlid) = PDL::IO::Dumper::uudecode_PDL(<<'DuMPERFILE'\n", @uulines, "\nDuMPERFILE\n);\n", "\$$pdlid->hdrcpy(".$_->hdrcpy().");\n" ); ## ## Unfortunately, FITS format mangles headers (and gives us one ## even if we don't want it). Delete the FITS header if we don't ## want one. ## if( !scalar(keys %{$_->hdr()}) ) { push(@s,"\$$pdlid->sethdr(undef);\n"); } } ## ## Generate commands to reconstitute the header ## information in the PDL -- common to midsized and huge case. ## ## We normally want to reconstitute, because FITS headers mangle ## arbitrary hashes and we can reconsitute efficiently with a private ## sdump(). The one known exception to this is when there's a FITS ## header object (Astro::FITS::Header) tied to the original ## PDL's header. Other types of tied object will get handled just ## like normal hashes. ## ## Ultimately, Data::Dumper will get fixed to handle tied objects, ## and this kludge will go away. ## if( scalar(keys %{$_->hdr()}) ) { if( ((tied %{$_->hdr()}) || '') =~ m/Astro::FITS::Header\=/) { push(@s,"# (Header restored from FITS file)\n"); } else { push(@s,"\$$pdlid->sethdr( eval <<'EndOfHeader_${pdlid}'\n", &PDL::IO::Dumper::sdump($_->hdr()), "\nEndOfHeader_${pdlid}\n);\n", "\$$pdlid->hdrcpy(".$_->hdrcpy().");\n" ); } } @out = (join("",@s), undef); } return @out; } ###################################################################### =head2 PDL::IO::Dumper::find_PDLs =for ref Walk a data structure and dump PDLs [Internal routine] Walks the original data structure and generates appropriate exprs for each PDL. The exprs are inserted into the Data::Dumper output string. You shouldn't call this unless you know what you're doing. (see sdump, above). =cut sub PDL::IO::Dumper::find_PDLs { local($_); my($out)=""; my($sp) = shift; findpdl:foreach $_(@_) { next findpdl unless ref($_); if(UNIVERSAL::isa($_,'ARRAY')) { my($a); foreach $a(@{$_}) { $out .= find_PDLs($sp,$a); } } elsif(UNIVERSAL::isa($_,'HASH')) { my($a); foreach $a(values %{$_}) { $out .= find_PDLs($sp,$a) } } elsif(UNIVERSAL::isa($_,'PDL')) { # In addition to straight PDLs, # this gets subclasses of PDL, but NOT magic-hash subclasses of # PDL (because they'd be gotten by the previous clause). # So if you subclass PDL but your actual data structure is still # just a straight PDL (and not a hash with PDL field), you end up here. # my($pdlid) = sprintf('PDL_%u',$$_); my(@strings) = &PDL::IO::Dumper::dump_PDL($_,$pdlid); $out .= $strings[0]; $$sp =~ s/\$$pdlid/$strings[1]/g if(defined($strings[1])); } elsif(UNIVERSAL::isa($_,'SCALAR')) { # This gets other kinds of refs -- PDLs have already been gotten. # Naked PDLs are themselves SCALARs, so the SCALAR case has to come # last to let the PDL case run. $out .= find_PDLs( $sp, ${$_} ); } } return $out; } 1; PDL-2.018/IO/ENVI/0000755060175006010010000000000013110402044011431 5ustar chmNonePDL-2.018/IO/ENVI/readenvi.pdl0000755060175006010010000003177412562522364013770 0ustar chmNone#!/usr/bin/perl # # Created on: Wed 31 Mar 2010 02:30:20 PM # Last saved: Mon 28 Nov 2011 01:35:30 PM # # This file is the first step of an ENVI file IO module # to be named PDL::IO::ENVI. We read the header file # corresponding to the input file, parse the keywords # values structures, and return a hash ref of the file. # # Then we can use readflex to read the data # # TODO # # (1) verify that all required fields are present # (2) parse map_info for pixel geolocation # - handle keyword=value inside list # (3) check that all sensor keywords are parsed # (4) add support for offset/stride/count/reshape # (5) implement writeenvi/wenvi routine # (6) LATER: add support for complex data input, e.g. [2,S,L,B] # (7) LATER: support unsigned long long use strict; use PDL; use PDL::NiceSlice; use PDL::IO::FlexRaw; use FileHandle; use Config; my $verbose = 1; # for diagnostics my $run_envi_main = 0; # set to 1 for testing # This is a hash ref of the known/allowed keywords # in an ENVI header file. While these are the current # values, this implementation allows for new keywords # by parsing according to the following rules: # # (1) keywords are between the start of line and the = # (2) keywords are case insensitive # (3) white space is significant but amount and type is not # (4) string values will have leading and trailing whitespace removed # (5) canonical whitespace is a single ASCII space char # (6) single spaces in hash keywords will be replace by underscore # (7) canonical case for normalized keywords is lowercase # (8) required key-value pairs are always on a single line # (9) brace starting lists must be on same line as keyword = # (10) comment lines begin with ; in the first column # # Initially, we will parse all keyword = values but only fully # process for the required and optional entries needed for the # scissor data files. A hash value of 1 indicates required.. # my $envi_keywords = { 'band_names' => 0, # optional, CSV str of band names 'bands' => 1, # required, num of bands in image file 'bbl' => 0, # optional, (tbd) 'byte_order' => 1, # required, num 0 or 1 for LSF or MSF order 'class_lookup' => 0, # optional, (tbd) 'class_names' => 0, # optional, (tbd) 'classes' => 0, # optional, num of classes, including unclassified 'complex_function' => 0, # optional, (tbd) 'coordinate_system string' => 0, # optional, (tbd, for georeferencing) 'data_gain_values' => 0, # optional, CSV of gain vals for each band 'data_ignore_value' => 0, # optional, value of bad/missing element in data 'data_offset_values' => 0, # optional, CSV of offset vals for each band 'data_type' => 1, # required, id number in 1-6,9,12-15 'default_bands' => 0, # optional, CSV of 1 or 3 band numbers to display 'default_stretch' => 0, # optional, str of stretch to use for image display 'dem_band' => 0, # optional, (tbd) 'dem_file' => 0, # optional, (tbd) 'description' => 0, # optional, str describing the image or processing 'file_type' => 1, # required, ENVI Standard or from filetype.txt 'fwhm' => 0, # optional, CSV of band widths in wavelength units 'geo_points' => 0, # optional, CSV of x,y,lat,long of 1-4 image pts 'header_offset' => 1, # required, num bytes imbedded hdr in image file 'interleave' => 1, # required, str/num of BSQ/0, BIL/1, or BIP/2 'lines' => 1, # required, num lines in image 'map_info' => 0, # optional, CSV of values, as in # UTM, x0, y0, east0, north0, xpixsize, ypixsize, # UTM zone #, N or S (UTM only), datum, # units=str, rotation=val 'pixel_size' => 0, # optional, CSV of x and y pixel size in meters 'major_frame_offsets' => 0, # optional, (tbd) 'minor_frame_offsets' => 0, # optional, (tbd) 'projection_info' => 0, # optional, (tbd) 'reflectance_scale_factor' => 0, # optional, (tbd) 'rpc_info' => 0, # optional, (tbd) 'samples' => 1, # required, num samples per image line each band 'sensor_type' => 0, # optional, str Unknown or exact match in sensor.txt 'spectra_names' => 0, # optional, (tbd) 'wavelength' => 0, # optional, CSV of band center value in image 'wavelength_units' => 0, # optional, str with units for wavelength and fwhm 'x_start' => 0, # optional, (tbd) 'y_start' => 0, # optional, (tbd) 'z_plot_average' => 0, # optional, (tbd) 'z_plot_range' => 0, # optional, (tbd) 'z_plot_titles' => 0, # optional, (tbd) }; my $envi_required_keywords = []; foreach (keys %$envi_keywords) { push @$envi_required_keywords, $_ if $envi_keywords->{$_}; } my $interleave = { 'bsq' => [ qw( samples lines bands ) ], 'bil' => [ qw( samples bands lines ) ], 'bip' => [ qw( bands samples lines ) ], }; my $envi_data_types = []; $envi_data_types->[1] = 'byte'; $envi_data_types->[2] = 'short'; $envi_data_types->[3] = 'long'; $envi_data_types->[4] = 'float'; $envi_data_types->[5] = 'double'; $envi_data_types->[6] = undef; # complex, not supported, [2,shape] $envi_data_types->[9] = undef; # double complex, not supported, [2,shape] $envi_data_types->[12] = 'ushort'; $envi_data_types->[13] = 'ulong'; $envi_data_types->[14] = 'longlong'; $envi_data_types->[15] = undef; # unsigned long64, not supported, longlong? # Takes one arg, an ENVI hdr filename and # returns a hash reference of the header data # sub _read_envihdr { my $hdrname = $_[0]; my $hdr = {}; # an easy progress message if ($verbose>1) { print STDERR "_read_envihdr: reading ENVI hdr data from '@_'\n"; print STDERR "_read_envihdr: required ENVI keywords are:\n"; print STDERR " @{ [sort @$envi_required_keywords] }\n"; } # open hdr file my $hdrfile = FileHandle->new("$hdrname") or barf "_read_envihdr: couldn't open '$hdrname' for reading"; binmode $hdrfile; if ( eof($hdrfile) ) { barf "_read_envihdr: WARNING '$hdrname' is empty, invalid ENVI format" } ITEM: while (!eof($hdrfile)) { # check for ENVI hdr start word on first line my $line = <$hdrfile>; if ($line !~ /^ENVI\r?$/) { barf "_read_envihdr: '$hdrname' is not in ENVI hdr format" } $hdr->{ENVI} = 1; # this marks this header as ENVI # collect key=values into a hash my ($keyword,$val); my $in_list = 0; # used to track when we re reading a { } list LINE: while (defined($line = <$hdrfile>)) { next LINE if $line =~ /^;/; # skip comment line (maybe print?) $line =~ s/\s+$//; $line =~ s/^\s+//; next LINE if $line =~ /^$/; chomp $line; if ($in_list>0) { # append to value string $val .= " $line"; # need to keep whitespace for separation if ($line =~ /{/) { barf "_read_envihdr: warning, found nested braces for line '$line'\n"; } if ( $val =~ /}$/ ) { # got to end of list # parse $val list print STDERR "_read_envihdr: got list value = $val\n" if $verbose>1; # clear list parse flag $in_list--; } } else { # look for next keyword = line ($keyword,$val) = (undef, undef); ($keyword,$val) = $line =~ /^\s*([^=]+)=\s*(.*)$/; if (defined $keyword) { # warning exit in case underscores are used in keywords if ($keyword =~ /_/) { barf "_read_envihdr: WARNING keyword '$keyword' contains underscore!" } # normalize to lc and single underscore for whitespace $keyword =~ s/\s+$//; $keyword =~ s/\s+/_/g; $keyword = lc $keyword; $val =~ s/^\s+//; $val =~ s/\s+$//; $in_list++ if $val =~ /^{/ and not $in_list; $in_list-- if $val =~ /}$/ and $in_list; next LINE if $in_list>0; # parse ENVI hdr lists and convert to perl array ref if ($val =~ /^{/) { # strip off braces $val =~ s/^{\s*//; $val =~ s/\s*}$//; my @listval = split ',\s*', $val; print STDERR "_read_envihdr: expanded $keyword list value to (@listval)\n" if $verbose; $val = [@listval]; } my $reqoropt = $envi_keywords->{$keyword} ? 'required' : 'optional'; print STDERR " got $reqoropt $keyword = $val\n" if $verbose; # replace ignore_value by data_ignore_value $keyword =~ s/^ignore_value$/data_ignore_value/; $hdr->{$keyword} = $val; } else { print STDERR " NOT a 'keyword =' line: '$line'\n" if $verbose; } } } } # close hdr file close $hdrfile; return $hdr; } =head2 readenvi =for ref reads ENVI standard format image files =for usage $im = readenvi( filename ); # read image data ($im, $hdr) = readenvi( filename ); # read image data and hdr data hashref readenvi will look for an ENVI header file named filename.hdr If that file is not found, it will try with the windows convention of replacing the suffix of the filename by .hdr If valid header data is found, the image will be read and returned, with a ref to a hash of the hdr data in list context. NOTE: This routine only supports raw binary data at this time. =cut sub readenvi { barf 'Usage ($x [,$hdr]) = readenvi("filename")' if $#_ > 0; my $enviname = $_[0]; my $envi; # image data to return my $filehdr; # image file header (before ENVI image data) my $envihdr; # image hdr to return my $flexhdr = []; # an easy progress message print STDERR "readenvi: reading ENVI data from '@_'\n" if $verbose; # read ENVI header my $envihdrname; $envihdrname = $enviname . '.hdr'; if (! -f $envihdrname ) { $envihdrname = $enviname; $envihdrname =~ s/\.\w+$/.hdr/; } print STDERR "readenvi: ERROR could not find ENVI hdr file\n" unless -r $envihdrname; $envihdr = _read_envihdr($envihdrname); # add read of imbedded_header data if have header_offset non-zero if ($envihdr->{header_offset}) { push @$flexhdr, { Type => 'byte', NDims => 1, Dims=>$envihdr->{header_offset} } } # see if we need to swap my $byteorder = ($Config{byteorder} =~ /4321$/) ? 1 : 0; print STDERR "readenvi: Config{byteorder} is $Config{byteorder}\n" if $verbose>1; if ($byteorder != $envihdr->{byte_order}) { print STDERR "readenvi: got byteorder of $byteorder, ENVI file has $envihdr->{byte_order}\n" if $verbose; print STDERR "readenvi: adding { Type => 'swap' } to \$flexhdr\n" if $verbose; push @$flexhdr, { Type => 'swap' } if $byteorder != $envihdr->{byte_order}; } # determine data type for readflex from interleave header value my $imagespec = { }; my $imagetype = $envi_data_types->[$envihdr->{data_type}]; print STDERR "readenvi: setting image { Type => $imagetype }\n" if $verbose; $imagespec->{Type} = $imagetype; # construct Dims for readflex my @imagedims = (); @imagedims = @{$interleave->{lc($envihdr->{interleave})}}; print STDERR "readenvi: Need Dims => @imagedims\n" if $verbose; my $imagedims = [ map { $envihdr->{$_} } @imagedims ]; print STDERR "readenvi: computed Dims => [", join( ', ', @{$imagedims} ), "]\n" if $verbose; $imagespec->{Dims} = $imagedims; $imagespec->{Ndims} = scalar(@$imagedims); push @$flexhdr, $imagespec; # read file using readflex my (@envidata) = readflex( $enviname, $flexhdr ); if (2==@envidata) { ($filehdr,$envi) = @envidata; $envihdr->{imbedded_header} = $filehdr; } else { ($envi) = @envidata; } # attach ENVI hdr to piddle $envi->sethdr($envihdr); # handle ignore values by mapping to BAD if ( exists $envihdr->{data_ignore_value} ) { $envi->inplace->badflag; # set badflag for image $envi->inplace->setvaltobad($envihdr->{data_ignore_value}); } # return data and optionally header if requested return wantarray ? ($envi, $envihdr) : $envi; } if ($run_envi_main) { my ($data,$hdr) = readenvi('envi-data'); print "Got " . $data->dims . " of data\n"; } 1; PDL-2.018/IO/FastRaw/0000755060175006010010000000000013110402044012237 5ustar chmNonePDL-2.018/IO/FastRaw/FastRaw.pm0000644060175006010010000003034612562522364014174 0ustar chmNone=head1 NAME PDL::IO::FastRaw -- A simple, fast and convenient io format for PerlDL. =head1 VERSION This documentation refers to PDL::IO::FastRaw version 0.0.2, I guess. =head1 SYNOPSIS use PDL; use PDL::IO::FastRaw; writefraw($pdl,"fname"); # write a raw file $pdl2 = readfraw("fname"); # read a raw file $pdl2 = PDL->readfraw("fname"); $pdl3 = mapfraw("fname2",{ReadOnly => 1}); # mmap a file, don't read yet $pdl4 = maptextfraw("fname3",{...}); # map a text file into a 1-D pdl. =head1 DESCRIPTION This is a very simple and fast io format for PerlDL. The disk data consists of two files, a header metadata file in ASCII and a binary file consisting simply of consecutive bytes, shorts or whatever. It is hoped that this will not only make for a simple PerlDL module for saving and retrieving these files but also make it easy for other programs to use these files. The format of the ASCII header is simply ... You should probably stick with the default header name. You may want to specify your own header, however, such as when you have a large collection of data files with identical dimensions and data types. Under these circumstances, simply specify the C

option in the options hash. The binary files are in general NOT interchangeable between different architectures since the binary file is simply dumped from the memory region of the piddle. This is what makes the approach efficient. It is also possible to mmap the file which can give a large speedup in certain situations as well as save a lot of memory by using a disk file as virtual memory. When a file is mapped, parts of it are read only as they are accessed in the memory (or as the kernel decides: if you are reading the pages in order, it may well preread some for you). Note that memory savings and copy-on-write are operating-system dependent - see Core.xs and your operating system documentation for exact semantics of whatever. Basically, if you write to a mmapped file without C, the change will be reflected in the file immediately. C doesn't really make it impossible to write to the piddle but maps the memory privately so the file will not be changed when you change the piddle. Be aware though that mmapping a 40Mb file without C spends no virtual memory but with C it does reserve 40Mb. =head2 Example: Converting ASCII to raw You have a whole slew of data files in ASCII from an experiment that you ran in your lab. You're still tweaking the analysis and plots, so you'd like if your data could load as fast as possible. Eventually you'll read the data into your scripts using C, but the first thing you might do is create a script that converts all the data files to raw files: #!/usr/bin/perl # Assumes that the data files end with a .asc or .dat extension # and saves the raw file output with a .bdat extension. # call with # >./convert_to_raw.pl file1.dat file2.dat ... # or # >./convert_to_raw.pl *.dat use PDL; use PDL::IO::FastRaw; # for saving raw files use PDL::IO::Misc; # for reading ASCII files with rcols while(shift) { # run through the entire supplied list of file names ($newName = $_) =~ s/\.(asc|dat)/.bdat/; print "Saving contents of $_ to $newName\n"; $data = rcols($_); writefraw($data, $newName); } =head2 Example: readfraw Now that you've gotten your data into a raw file format, you can start working on your analysis scripts. If you scripts used C in the past, the reading portion of the script should go much, much faster now: #!/usr/bin/perl # My plotting script. # Assume I've specified the files to plot on the command line like # >./plot_script.pl file1.bdat file2.bdat ... # or # >./plot_script.pl *.bdat use PDL; use PDL::IO::FastRaw; while(shift) { # run through the entire supplied list of file names $data = readfraw($_); my_plot_func($data); } =head2 Example: Custom headers In the first example, I allow C to use the standard header file name, which would be C. However, I often measure time series that have identical length, so all of those header files are redundant. To fix that, I simply pass the Header option to the C command. A modified script would look like this: #!/usr/bin/perl # Assumes that the data files end with a .asc or .dat extension # and saves the raw file output with a .bdat extension. # call with # >./convert_to_raw.pl [-hHeaderFile] [-hHeaderFile] ... use PDL; use PDL::IO::FastRaw; # for saving raw files use PDL::IO::Misc; # for reading ASCII files with rcols my $header_file = undef; CL_OPTION: while($_ = shift @ARGV) { # run through the entire list of command-line options if(/-h(.*)/) { $header_file = $1; next CL_OPTION; } ($newName = $_) =~ s/\.(asc|dat)/.bdat/; print "Saving contents of $_ to $newName\n"; $data = rcols($_); writefraw($data, $newName, {Header => $header_file}); } Modifying the read script is left as an exercise for the reader. :] =head2 Example: Using mapfraw Sometimes you'll want to use C rather than the read/write functions. In fact, the original author of the module doesn't use the read/write functions anymore, prefering to always use C. How would you go about doing this? Assuming you've already saved your data into the raw format, the only change you would have to make to the script in example 2 would be to change the call to C to C. That's it. You will probably see differences in performance, though I (David Mertens) couldn't tell you about them because I haven't played around with C much myself. What if you eschew the use of C and prefer to only use C? How would you save your data to a raw format? In that case, you would have to create a C piddle with the correct dimensions first using $piddle_on_hd = mapfraw('fname', {Creat => 1, Dims => [dim1, dim2, ...]}); Note that you must specify the dimensions and you must tell C to create the new piddle for you by setting the C option to a true value, not C (note the missing final 'e'). =head1 FUNCTIONS =head2 readfraw =for ref Read a raw format binary file =for usage $pdl2 = readfraw("fname"); $pdl2 = PDL->readfraw("fname"); $pdl2 = readfraw("fname", {Header => 'headerfname'}); =for options The C command supports the following option: =over 8 =item Header Specify the header file name. =back =head2 writefraw =for ref Write a raw format binary file =for usage writefraw($pdl,"fname"); writefraw($pdl,"fname", {Header => 'headerfname'}); =for options The C command supports the following option: =over 8 =item Header Specify the header file name. =back =head2 mapfraw =for ref Memory map a raw format binary file (see the module docs also) =for usage $pdl3 = mapfraw("fname2",{ReadOnly => 1}); =for options The C command supports the following options (not all combinations make sense): =over 8 =item Dims, Datatype If creating a new file or if you want to specify your own header data for the file, you can give an array reference and a scalar, respectively. =item Creat Create the file. Also writes out a header for the file. =item Trunc Set the file size. Automatically enabled with C. NOTE: This also clears the file to all zeroes. =item ReadOnly Disallow writing to the file. =item Header Specify the header file name. =back =head2 maptextfraw =for ref Memory map a text file (see the module docs also). Note that this function maps the raw format so if you are using an operating system which does strange things to e.g. line delimiters upon reading a text file, you get the raw (binary) representation. The file doesn't really need to be text but it is just mapped as one large binary chunk. This function is just a convenience wrapper which firsts Cs the file and sets the dimensions and datatype. =for usage $pdl4 = maptextfraw("fname", {options} =for options The options other than Dims, Datatype of C are supported. =head1 BUGS Should be documented better. C and C should also have options (the author nowadays only uses C ;) =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::IO::FastRaw; ## use version; our $VERSION = qv('0.0.3'); our $VERSION = '0.000003'; $VERSION = eval $VERSION; BEGIN { our $have_file_map = 0; eval "use File::Map 0.57 qw(:all)"; $have_file_map = 1 unless $@; } require Exporter; use PDL::Core ''; use PDL::Exporter; use FileHandle; @PDL::IO::FastRaw::ISA = qw/PDL::Exporter/; @EXPORT_OK = qw/writefraw readfraw mapfraw maptextfraw/; %EXPORT_TAGS = (Func=>[@EXPORT_OK]); # Exported functions *writefraw = \&PDL::writefraw; sub readfraw {PDL->readfraw(@_)} sub mapfraw {PDL->mapfraw(@_)} sub maptextfraw {PDL->maptextfraw(@_)} sub _read_frawhdr { my($name,$opts) = @_; my $hname = $opts->{Header} || "$name.hdr"; my $h = new FileHandle "$hname" or barf "Couldn't open '$hname' for reading"; chomp(my $tid = <$h>); chomp(my $ndims = <$h>); chomp(my $str = <$h>); if(!defined $str) {barf("Format error in '$hname'");} my @dims = split ' ',$str; if($#dims != $ndims-1) { barf("Format error reading fraw header file '$hname'"); } return { Type => $tid, Dims => \@dims, NDims => $ndims }; } sub _writefrawhdr { my($pdl,$name,$opts) = @_; my $hname = $opts->{Header} || "$name.hdr"; my $h = new FileHandle ">$hname" or barf "Couldn't open '$hname' for writing"; print $h map {"$_\n"} ($pdl->get_datatype, $pdl->getndims, (join ' ',$pdl->dims)); } sub PDL::writefraw { my($pdl,$name,$opts) = @_; _writefrawhdr($pdl,$name,$opts); my $d = new FileHandle ">$name" or barf "Couldn't open '$name' for writing"; binmode $d; print $d ${$pdl->get_dataref}; } sub PDL::readfraw { my $class = shift; my($name,$opts) = @_; my $d = new FileHandle "$name" or barf "Couldn't open '$name' for reading"; binmode $d; my $hdr = _read_frawhdr($name,$opts); my $pdl = $class->zeroes ((new PDL::Type($hdr->{Type})), @{$hdr->{Dims}}); my $len = length ${$pdl->get_dataref}; # wrong. # $d->sysread(${$pdl->get_dataref},$len) == $len # or barf "Couldn't read enough data from '$name'"; my $index = 0; my $data; my $retlen; while (($retlen = $d->sysread($data, $len)) != 0) { substr(${$pdl->get_dataref},$index,$len) = $data; $index += $retlen; $len -= $retlen; } $pdl->upd_data(); return $pdl; } sub PDL::mapfraw { my $class = shift; my($name,$opts) = @_; my $hdr; if($opts->{Dims}) { my $datatype = $opts->{Datatype}; if(!defined $datatype) {$datatype = $PDL_D;} $hdr->{Type} = $datatype; $hdr->{Dims} = $opts->{Dims}; $hdr->{NDims} = scalar(@{$opts->{Dims}}); } else { $hdr = _read_frawhdr($name,$opts); } $s = PDL::Core::howbig($hdr->{Type}); for(@{$hdr->{Dims}}) { $s *= $_; } my $pdl = $class->zeroes(new PDL::Type($hdr->{Type})); $pdl->setdims($hdr->{Dims}); if ($have_file_map and not defined($PDL::force_use_mmap_code) ) { $pdl->set_data_by_file_map( $name, $s, 1, ($opts->{ReadOnly}?0:1), ($opts->{Creat}?1:0), (0644), ($opts->{Creat} || $opts->{Trunc} ? 1:0) ); } else { warn "mapfraw: direct mmap support will be deprecated, please install File::Map\n"; $pdl->set_data_by_mmap( $name, $s, 1, ($opts->{ReadOnly}?0:1), ($opts->{Creat}?1:0), (0644), ($opts->{Creat} || $opts->{Trunc} ? 1:0) ); } if($opts->{Creat}) { _writefrawhdr($pdl,$name,$opts); } return $pdl; } sub PDL::maptextfraw { my($class, $name, $opts) = @_; $opts = {%$opts}; # Copy just in case my @s = stat $name; $opts->{Dims} = [$s[7]]; $opts->{Datatype} = &PDL::byte; return PDL::mapfraw($class, $name, $opts); } 1; PDL-2.018/IO/FastRaw/Makefile.PL0000644060175006010010000000035212562522364014233 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => "PDL::IO::FastRaw", 'VERSION_FROM' => '../../Basic/Core/Version.pm', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/FITS/0000755060175006010010000000000013110402046011437 5ustar chmNonePDL-2.018/IO/FITS/FITS.pm0000644060175006010010000027143513036512175012572 0ustar chmNone=head1 NAME PDL::IO::FITS -- Simple FITS support for PDL =head1 SYNOPSIS use PDL; use PDL::IO::FITS; $a = rfits('foo.fits'); # read a FITS file $a->wfits('bar.fits'); # write a FITS file =head1 DESCRIPTION This module provides basic FITS support for PDL, in the sense of reading and writing whole FITS files. (For more complex operations, such as prefiltering rows out of tables or performing operations on the FITS file in-place on disk), you can use the Astro::FITS::CFITSIO module that is available on CPAN. Basic FITS image files are supported, along with BINTABLE and IMAGE extensions. ASCII Table support is planned, as are the HEASARC bintable extensions that are recommended in the 1999 FITS standard. Table support is based on hashes and named columns, rather than the less convenient (but slightly more congruent) technique of perl lists of numbered columns. The principle interface routines are C and C, for reading and writing respectively. FITS headers are returned as perl hashes or (if the module is present) Astro::FITS::Header objects that are tied to perl hashes. Astro::FITS::Header objects provide convenient access through the tied hash interface, but also allow you to control the card structure in more detail using a separate method interface; see the L documentation for details. =head1 AUTHOR Copyright (C) Karl Glazebrook, Craig DeForest, and Doug Burke, 1997-2010. There is no warranty. You are allowed to redistribute and/or modify this software under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be pasted into in this file. =head1 FUNCTIONS =cut use strict; BEGIN { package PDL::IO::FITS; $PDL::IO::FITS::VERSION = 0.92; # Will be 1.0 when ascii table read/write works. our @EXPORT_OK = qw( rfits rfitshdr wfits ); our %EXPORT_TAGS = (Func=>[@EXPORT_OK]); our @ISA = ('PDL::Exporter'); use PDL::Core; use PDL::Config; use PDL::IO::Misc; use PDL::Exporter; use PDL::Primitive; use PDL::Types; use PDL::Options; use PDL::Bad; # use PDL::NiceSlice; use Carp; use strict; ############################## # # Check if there's Astro::FITS::Header support, and set flag. # Kludgy but it only has to run once, on first load. --CED # eval "use Astro::FITS::Header;"; $PDL::Astro_FITS_Header = (defined $Astro::FITS::Header::VERSION); if($PDL::Astro_FITS_Header) { my($a) = $Astro::FITS::Header::VERSION; $a =~ s/[^0-9\.].*//; $PDL::Astro_FITS_Header = 0 if($a < 1.12); } unless($PDL::Astro_FITS_Header) { unless($ENV{"PDL_FITS_LEGACY"} || $PDL::Config{FITS_LEGACY}) { print(STDERR "\n\nWARNING: Can't find the Astro::FITS::Header module, limiting FITS support.\n\n PDL will use the deprecated legacy perl hash handling code but will not\n properly support tables, FITS extensions, or COMMENT cards. You really\n ought to install the Astro::FITS::Header module, available from\n 'http://www.cpan.org'. (You can also get rid of this message by setting\n the environment variable 'PDL_FITS_LEGACY' or the global PDL config value (in perldl.conf)\n \$PDL::Config{FITS_LEGACY} to 1.\n\n"); } } } package PDL::IO::FITS; ## declare subroutines sub _wfits_nullhdu ($); sub _wfits_table ($$$); =head2 rfits() =for ref Simple piddle FITS reader. =for example $pdl = rfits('file.fits'); # Read a simple FITS image Suffix magic: $pdl = rfits('file.fits.gz'); # Read a file with gunzip(1) $pdl = rfits('file.fits.Z'); # Read a file with uncompress(1) $pdl = rfits('file.fits[2]'); # Read 2nd extension $pdl = rfits('file.fits.gz[3]'); # Read 3rd extension @pdls = rfits('file.fits'); # Read primary data and extensions $hdr = rfits('file.fits',{data=>0}); # Options hash changes behavior In list context, C reads the primary image and all possible extensions, returning them in the same order that they occurred in the file -- except that, by default, the primary HDU is skipped if it contains no data. In scalar context, the default is to read the first HDU that contains data. One can read other HDU's by using the [n] syntax. Using the [0] syntax forces a read of the first HDU, regardless of whether it contains data or no. Currently recognized extensions are IMAGE and BINTABLE. (See the addendum on EXTENSIONS for details). C accepts several options that may be passed in as a hash ref if desired: =over 3 =item bscale (default=1) Determines whether the data are linearly scaled using the BSCALE/BZERO keywords in the FITS header. To read in the exact data values in the file, set this to 0. =item data (default=1) Determines whether to read the data, or just the header. If you set this to 0, you will get back the FITS header rather than the data themselves. (Note that the header is normally returned as the C field of the returned PDL; this causes it to be returned as a hash ref directly.) =item hdrcpy (default=0) Determines whether the L flag is set in the returned PDL. Setting the flag will cause an explicit deep copy of the header whenever you use the returned PDL in an arithmetic or slicing operation. That is useful in many circumstances but also causes a hit in speed. When two or more PDLs with hdrcpy set are used in an expression, the result gets the header of the first PDL in the expression. See L for an example. =item expand (default=1) Determines whether auto-expansion of tile-compressed images should happen. Tile-compressed images are transmitted as binary tables with particular fields ("ZIMAGE") set. Leaving this alone does what you want most of the time, unpacking such images transparently and returning the data and header as if they were part of a normal IMAGE extension. Setting "expand" to 0 delivers the binary table, rather than unpacking it into an image. =item afh (default=1) By default rfits uses Astro::FITS::Header tied-hash objects to contain the FITS header information. This permits explicit control over FITS card information, and conforms well with the FITS specification. But Astro::FITS::Header objects are about 40-60x more memory intensive than comparable perl hashes, and also use ~10x more CPU to manage. For jobs where header processing performance is important (e.g. reading just the headers of 1,000 FITS files), set afh to 0 to use the legacy parser and get a large boost in speed. =back FITS image headers are stored in the output PDL and can be retrieved with L or L. The L flag of the PDL is set so that the header is copied to derived piddles by default. (This is inefficient if you are planning to do lots of small operations on the data; clear the flag with "->hcpy(0)" or via the options hash if that's the case.) The header is a hash whose keys are the keywords in the FITS header. If you have the "Astro::FITS::Header" module installed, the header is actually a tied hash to a FITS header object, which can give you more control over card order, comment fields, and variable types. (see L for details). The header keywords are converted to I per the FITS standard. Access is case-insensitive on the perl side, provided that Astro::FITS::Header is installed. If Astro::FITS::Header is not installed, then a built-in legacy parser is used to generate the header hash. Keyword-associated comments in the headers are stored under the hash key C<< _COMMENT> >>. All HISTORY cards in the header are collected into a single multiline string stored in the C key. All COMMENT cards are similarly collected under the C key. =head3 BSCALE/BZERO If the BSCALE and/or BZERO keywords are set, they are applied to the image before it is returned. The returned PDL is promoted as necessary to contain the multiplied values, and the BSCALE and BZERO keywords are deleted from the header for clarity. If you don't want this type of processing, set 'bscale=>0' in the options hash. =head3 EXTENSIONS Sometimes a FITS file contains only extensions and a stub header in the first header/data unit ("primary HDU"). In scalar context, you normally only get back the primary HDU -- but in this special case, you get back the first extension HDU. You can force a read of the primary HDU by adding a '[0]' suffix to the file name. =head3 BINTABLE EXTENSIONS Binary tables are handled. Currently only the following PDL datatypes are supported: byte, short, ushort, long, float, and double. At present ushort() data is written as a long rather than as a short with TSCAL/ZERO; this may change. The return value for a binary table is a hash ref containing the names of the columns in the table (in UPPER CASE as per the FITS standard). Each element of the hash contains a PDL (for numerical values) or a perl list (for string values). The PDL's 0th dimension runs across rows; the 1st dimension runs across the repeat index within the row (for rows with more than one value). (Note that this is different from standard threading order - but it allows Least Surprise to work when adding more complicated objects such as collections of numbers (via the repeat count) or variable length arrays.) Thus, if your table contains a column named C with type C<5D>, the expression $a->{FOO}->((2)) returns a 5-element double-precision PDL containing the values of FOO from the third row of the table. The header of the table itself is parsed as with a normal FITS HDU, and is returned in the element 'hdr' of the returned hash. You can use that to preserve the original column order or access the table at a low level, if you like. Scaling and zero-point adjustment are performed as with BSCALE/BZERO: the appropriate keywords are deleted from the as-returned header. To avoid this behavior, set 'bscale=>0' in the options hash. As appropriate, TSCAL/ZERO and TUNIT are copied into each column-PDL's header as BSCALE/BZERO and BUNIT. The main hash also contains the element 'tbl', which is set to 'binary' to distinguish it from an ASCII table. Because different columns in the table might have identical names in a FITS file, the binary table reader practices collision avoidance. If you have multiple columns named "FOO", then the first one encountered (numerically) gets the name "FOO", the next one gets "FOO_1", and the next "FOO_2", etc. The appropriate TTYPEn fields in the header are changed to match the renamed column fields. Columns with no name are assigned the name "COL_", where starts at 1 and increments for each no-name column found. Variable-length arrays are supported for reading. They are unpacked into PDLs that appear exactly the same as the output for fixed-length rows, except that each row is padded to the maximum length given in the extra characters -- e.g. a row with TFORM of 1PB(300) will yield an NAXIS2x300 output field in the final hash. The padding uses the TNULL keyword for the column, or 0 if TNULL is not present. The output hash also gets an additional field, "len_", that contains the number of elements in each table row. =head3 TILE-COMPRESSED IMAGES CFITSIO and several large projects (including NASA's Solar Dynamics Observatory) now support an unofficial extension to FITS that stores images as a collection of individually compressed tiles within a BINTABLE extension. These images are automagically uncompressed by default, and delivered as if they were normal image files. You can override this behavior by supplying the "expand" key in the options hash. Currently, only Rice compression is supported, though there is a framework in place for adding other compression schemes. =for bad =head3 BAD VALUE HANDLING If a FITS file contains the C keyword (and has C 0>), the piddle will have its bad flag set, and those elements which equal the C value will be set bad. For C 0>, any NaN's are converted to bad (if necessary). =head2 rfitshdr() =for ref Read only the header of a FITS file or an extension within it. This is syntactic sugar for the C0> option to L. See L for details on header handling. rfitshdr() runs the same code to read the header, but returns it rather than reading in a data structure as well. =cut our $rfits_options = new PDL::Options( { bscale=>1, data=>1, hdrcpy=>0, expand=>1, afh=>1 } ); sub PDL::rfitshdr { my $class = shift; my $file = shift; my $u_opt = ifhref(shift); $u_opt->{data} = 0; PDL::rfits($class,$file,$u_opt); } sub PDL::rfits { my $class = shift; barf 'Usage: $a = rfits($file) -or- $a = PDL->rfits($file)' if (@_ < 1 || @_ > 2); my $file = shift; my $u_opt = ifhref(shift); my $opt = $rfits_options->options($u_opt); my($nbytes, $line, $name, $rest, $size, $i, $bscale, $bzero, $extnum); $nbytes = 0; # Modification 02/04/2005 - JB. Earlier version stripped the extension # indicator which cancelled the check for empty primary data array at the end. my $explicit_extension = ($file =~ m/\[\d+\]$/ ? 1 : 0); $extnum = ( ($file =~ s/\[(\d+)\]$//) ? $1 : 0 ); $file = "gunzip -c $file |" if $file =~ /\.gz$/; # Handle compression $file = "uncompress -c $file |" if $file =~ /\.Z$/; my $fh = IO::File->new( $file ) or barf "FITS file $file not found"; binmode $fh; my @extensions; # This accumulates the list in list context... my $currentext=0; my $pdl; hdu:{do { # Runs over extensions, in list context my $ext_type = 'IMAGE'; # Gets the type of XTENSION if one is detected. my $foo={}; # To go in pdl my @history=(); my @cards = (); $pdl = $class->new; # If $opt->{data} is false, then the reading routines leave the # file alone, so the file pointer is left at the end of the last # header. Skip over the unread data to the next extension... if( wantarray and !$opt->{data} and @extensions) { while( $fh->read($line,80) && ($line !~ /^XTENSION=/) && !$fh->eof() ) { $fh->read($line,2880-80); }; return @extensions if($fh->eof()); } else { my $ct = $fh->read($line,80); barf "file $file is not in FITS-format:\n$line\n" if( $nbytes==0 && ($line !~ /^SIMPLE = +T/)); last hdu if($fh->eof() || !$ct); } $nbytes = 80; # Number of bytes read from this extension (1 line so far) if($line =~ /^XTENSION= \'(\w+)\s*\'/) { $ext_type = $1; } elsif( @extensions ) { print "Warning: expected XTENSION, found '$line'. Exiting.\n" if($PDL::verbose); last hdu; } push(@cards,$line) if($PDL::Astro_FITS_Header); # # If we are in scalar context, skip to the desired extension # number. [This implementation is really slow since we have # to read the whole file. Someone Really Ought To rework it to # read individual headers and skip forward an extension at a # a time with seek() calls. ] # --CD # if(!wantarray and $currentext != $extnum) { skipper: while(1) { # Move to next record $nbytes += $fh->read($line,2880-80); barf "Unexpected end of FITS file\n" if $fh->eof(); # Read start of next record $nbytes += $fh->read($line,80); barf "Unexpected end of FITS file\n" if $fh->eof(); # Check if we have found the new extension # if not move on $currentext++ if $line =~ /^XTENSION\= \'(\w+)\s*\'/; if ($currentext == $extnum) { $ext_type = $1; last skipper; } } } # End of skipping to desired extension # # Snarf up the found header, and parse it if Astro::FITS::Header # does not exist. # if($PDL::Astro_FITS_Header and $opt->{afh}) { ## Astro::FITS::Header parsing. Snarf lines to the END card, ## and pass them to Astro::FITS::Header. do { $nbytes += $fh->read($line, 80); push(@cards,$line); } while(!$fh->eof() && $line !~ m/^END(\s|\000)/); $nbytes += $fh->read(my $dummy, 2879 - ($nbytes-1)%2880); my($hdr) = Astro::FITS::Header->new(Cards => \@cards); my(%hdrhash); tie %hdrhash,"Astro::FITS::Header",$hdr; $foo = \%hdrhash; } else { ## Legacy (straight header-to-hash-ref) parsing. ## Cheesy but fast. hdr_legacy: { do { no strict 'refs'; # skip if the first eight characters are ' ' # - as seen in headers from the DSS at STScI if (substr($line,0,8) ne " " x 8) { # If non-blank $name = (split(' ',substr($line,0,8)))[0]; $rest = substr($line,8); if ($name =~ m/^HISTORY/) { push @history, $rest; } else { $$foo{$name} = ""; $$foo{$name}=$1 if $rest =~ m|^= +([^\/\' ][^\/ ]*) *( +/(.*))?$| ; $$foo{$name}=$1 if $rest =~ m|^= \'(.*)\' *( +/(.*))?$| ; $$foo{COMMENT}{$name} = $3 if defined($3); } } # non-blank last hdr_legacy if ((defined $name) && $name eq "END"); $nbytes += $fh->read($line, 80); } while(!$fh->eof()); } # Clean up HISTORY card $$foo{"HISTORY"} = \@history if $#history >= 0; # Step to end of header block in file my $skip = 2879 - ($nbytes-1)%2880; $fh->read(my $dummy, $skip) if $skip; $nbytes += $skip; } # End of legacy header parsing ############################## # Special case: if the file only contains # extensions then read the first extension in scalar context, # instead of the null zeroth extension. # if( !(defined $foo->{XTENSION}) # Primary header and $foo->{NAXIS} == 0 # No data and !wantarray # Scalar context and !$explicit_extension # No HDU specifier ) { print "rfits: Skipping null primary HDU (use [0] to force read of primary)...\n" if($PDL::verbose); return PDL::rfits($class,$file.'[1]',$opt); } ########## # If we don't want data, return the header from the HDU. Likewise, # if NAXIS is 0 then there are no data, so return the header instead. if( ! $opt->{data} || $foo->{NAXIS}==0 ) { # If we're NOT reading data, then return the header instead of the # image. $pdl = $foo; } else { ########## # Switch based on extension type to do the dirty work of reading # the data. Handlers are listed in the _Extension patch-panel. if (ref $PDL::IO::FITS::_Extension->{$ext_type} ) { # Pass $pdl into the extension reader for easier use -- but # it just gets overwritten (and disappears) if ignored. $pdl = &{$PDL::IO::FITS::_Extension->{$ext_type}}($fh,$foo,$opt,$pdl); } else { print STDERR "rfits: Ignoring unknown extension '$ext_type'...\n" if($PDL::verbose || $PDL::debug); $pdl = undef; } } # # Note -- $pdl isn't necessarily a PDL. It's only a $pdl if # the extension was an IMAGE. # push(@extensions,$pdl) if(wantarray); $currentext++; } while( wantarray && !$fh->eof() );} # Repeat if we are in list context $fh->close; if(wantarray) { ## By default, ditch primary HDU placeholder if( ref($extensions[0]) eq 'HASH' and $extensions[0]->{SIMPLE} and exists($extensions[0]->{NAXIS}) and $extensions[0]->{NAXIS} == 0 ) { shift @extensions; } # Return all the extensions return @extensions; } return $pdl; } sub rfits { PDL->rfits(@_); } sub rfitshdr { my($file,$opt) = shift; $opt->{data} =0; PDL->rfitshdr($file,$opt); } ############################## # # FITS extensions patch-table links extension name to the supported reader. # IMAGE extensions are a special case that gets read just like a normal # FITS file. # $PDL::IO::FITS::_Extension = { IMAGE => \&_rfits_image , BINTABLE => \&_rfits_bintable }; ############################## # # IMAGE extension -- this is also the default reader. our $type_table = { 8=>$PDL_B, 16=>$PDL_S, 32=>$PDL_L, 64=>$PDL_LL, -32=>$PDL_F, -64=>$PDL_D }; our $type_table_2 = { 8=>byte, 16=>short, 32=>long, 64=>longlong, -32=>float, -64=>double }; sub _rfits_image($$$$) { print "Reading IMAGE data...\n" if($PDL::verbose); my $fh = shift; # file handle to read from my $foo = shift; # $foo contains the pre-read header my $opt = shift; # $opt contains the option hash my $pdl = shift; # $pdl contains a pre-blessed virgin PDL # Setup piddle structure if( defined($type_table->{0 + $foo->{"BITPIX"}}) ) { $pdl->set_datatype( $type_table->{$foo->{"BITPIX"}} ); } else { die("rfits: strange BITPIX value ".$foo->{"BITPIX"}." in header - I give up!\n"); } my @dims; # Store the dimenions 1..N, compute total number of pixels my $i = 1; my $size = 1; ##second part of the conditional guards against a poorly-written hdr. while(defined( $$foo{"NAXIS$i"} ) && $i <= $$foo{"NAXIS"}) { $size *= $$foo{"NAXIS$i"}; push @dims, $$foo{"NAXIS$i"} ; $i++; } $pdl->setdims([@dims]); my $dref = $pdl->get_dataref(); print "BITPIX = ",$$foo{"BITPIX"}," size = $size pixels \n" if $PDL::verbose; # Slurp the FITS binary data print "Reading ",$size*PDL::Core::howbig($pdl->get_datatype) , " bytes\n" if $PDL::verbose; # Read the data and pad to the next HDU my $rdct = $size * PDL::Core::howbig($pdl->get_datatype); $fh->read( $$dref, $rdct ); $fh->read( my $dummy, 2880 - (($rdct-1) % 2880) - 1 ); $pdl->upd_data(); if (!isbigendian() ) { # Need to byte swap on little endian machines bswap2($pdl) if $pdl->get_datatype == $PDL_S; bswap4($pdl) if $pdl->get_datatype == $PDL_L || $pdl->get_datatype == $PDL_F; bswap8($pdl) if $pdl->get_datatype == $PDL_D || $pdl->get_datatype==$PDL_LL; } if(exists $opt->{bscale}) { $pdl = treat_bscale($pdl, $foo); } # Header $pdl->sethdr($foo); $pdl->hdrcpy($opt->{hdrcpy}); return $pdl; } sub treat_bscale($$){ my $pdl = shift; my $foo = shift; print "treating bscale...\n" if($PDL::debug); if ( $PDL::Bad::Status ) { # do we have bad values? - needs to be done before BSCALE/BZERO # (at least for integers) # if ( $$foo{BITPIX} > 0 and exists $$foo{BLANK} ) { # integer, so bad value == BLANK keyword my $blank = $foo->{BLANK}; # do we have to do any conversion? if ( $blank == $pdl->badvalue() ) { $pdl->badflag(1); } else { # we change all BLANK values to the current bad value # (would not be needed with a per-piddle bad value) $pdl->inplace->setvaltobad( $blank ); } } elsif ( $foo->{BITPIX} < 0 ) { # bad values are stored as NaN's in FITS # let setnanbad decide if we need to change anything $pdl->inplace->setnantobad(); } print "FITS file may contain bad values.\n" if $pdl->badflag() and $PDL::verbose; } # if: PDL::Bad::Status my ($bscale, $bzero); $bscale = $$foo{"BSCALE"}; $bzero = $$foo{"BZERO"}; print "BSCALE = $bscale && BZERO = $bzero\n" if $PDL::verbose; $bscale = 1 if (!defined($bscale) || $bscale eq ""); $bzero = 0 if (!defined($bzero) || $bzero eq ""); # Be clever and work out the final datatype before eating # memory # # ensure we pick an element that is not equal to the bad value # (is this OTT?) my $tmp; if ( $pdl->badflag() == 0 ) { $tmp = $pdl->flat()->slice("0:0"); } elsif ( $pdl->ngood > 0 ) { my $index = which( $pdl->flat()->isbad() == 0 )->at(0); $tmp = $pdl->flat()->slice("${index}:${index}"); } else { # all bad, so ignore the type conversion and return # -- too lazy to include this check in the code below, # so just copy the header clean up stuff print "All elements are bad.\n" if $PDL::verbose; delete $$foo{"BSCALE"}; delete $$foo{"BZERO"}; $tmp = $pdl; } #end of BSCALE section (whew!) $tmp = $tmp*$bscale if $bscale != 1; # Dummy run on one element $tmp = $tmp+$bzero if $bzero != 0; $pdl = $pdl->convert($tmp->type) if $tmp->get_datatype != $pdl->get_datatype; $pdl *= $bscale if $bscale != 1; $pdl += $bzero if $bzero != 0; delete $$foo{"BSCALE"}; delete $$foo{"BZERO"}; return $pdl; } ########## # # bintable_handlers -- helper table for bintable_row, below. # # Each element of the table is named by the appropriate type letter # from the FITS specification. The value is a list containing the # reading and writing methods. # # This probably ought to be a separate class, but instead it's a tawdry # imitation. Too bad -- except that the ersatz really does run faster than # genuine. # # 0: either a data type or a constructor. # 1: either a length per element or a read method. # 2: either a length per element or a write method. # 3: 'finish' contains finishing-up code or a byte-count to swap. # # Main bintable type handler table. # Elements: (constructor or type, reader or nbytes, writer or nbytes, # finisher or nbytes). The finisher should convert the internal reading # format into the final output format, e.g. by swapping (which is done # automatically in the basic case). Output has row in the 0th dim. # # If present, the constructor should # accept ($rowlen $extra, $nrows, $$size), where $rowlen is the repeat # specifier in the TFORM field, $extra is the extra characters if any # (for added flavor later, if desired), and $nrows is the number of rows in # the table. $$size points to a scalar value that should be incremented by the # size (in bytes) of a single row of the data, for accounting purposes. # # If a read method is specified, it should accept: # ($thing, $rownum, $strptr, $rpt, $extra) # where $rpt is the repeat count and $extra is the extra characters in the # specifier; and it should cut the used characters off the front of the string. # # If a writer is specified it should accept: # ($thing, $row, $rpt, $extra) # and return the generated binary string. # # The finisher just takes the data itself. It should: # * Byteswap # * Condition the data to final dimensional form (if necessary) # * Apply TSCAL/TZERO keywords (as necessary) # # The magic numbers in the table (1,2,4,8, etc.) are kludgey -- they break # the isolation of PDL size and local code -- but they are a part of the FITS # standard. The code will break anyway (damn) on machines that have other # sizes for these datatypes. # $PDL::IO::FITS_bintable_handlers = { 'X' => [ byte # Packed bit field , sub { my( $pdl, $row, $strptr ) = @_; # (ignore repeat and extra) my $n = $pdl->dim(0); my $s = unpack( "B".$n, substr(${$strptr}, 0, int(($n+7)/8),'')); $s =~ tr/[01]/[\000\001]/; substr( ${$pdl->get_dataref}, $n * $row, length($s)) = $s; } , sub { my( $pdl, $row ) = @_; # Ignore extra and rpt my $n = $pdl->dim(0); my $p2 = byte(($pdl->slice("($row)") != 0)); my $s = ${$p2->get_dataref}; $s =~ tr/[\000\001]/[01]/; pack( "B".$pdl->dim(0), $s ); } , 1 ] ,'A' => [ sub { # constructor # String - handle as perl list my($rowlen, $extra, $nrows, $szptr) = @_; my($i,@a); $$szptr += $rowlen; for $i(1..$nrows) { push(@a,' 'x$rowlen); } \@a; } , sub { # reader my( $list, $row, $strptr, $rpt ) = @_; $list->[$row] = substr(${$strptr},0,$rpt,''); } , sub { # writer my($strs, $row, $rpt ) = @_; my $s = substr($strs->[$row],0,$rpt); $s . ' 'x($rpt - length $s); } , undef # no finisher needed ] ,'B' => [ byte, 1, 1, 1 ] # byte ,'L' => [ byte, 1, 1, 1 ] # logical - treat as byte ,'I' => [ short, 2, 2, 2 ] # short (no unsigned shorts?) ,'J' => [ long, 4, 4, 4 ] # long ,'K' => [ longlong,8, 8, 8 ] # longlong ,'E' => [ float, 4, 4, 4 ] # single-precision ,'D' => [ double, 8, 8, 8 ] # double-precision ,'C' => [ sub { _nucomplx(float, eval '@_') }, sub { _rdcomplx(float, eval '@_') }, sub { _wrcomplx(float, eval '@_') }, sub { _fncomplx(float, eval '@_') } ] ,'M' => [ sub { _nucomplx(double, eval '@_') }, sub { _rdcomplx(double, eval '@_') }, sub { _wrcomplx(double, eval '@_') }, sub { _fncomplx(double, eval '@_') } ] ,'PB' => [ sub { _nuP(byte, eval '@_') }, sub { _rdP(byte, eval '@_') }, sub { _wrP(byte, eval '@_') }, sub { _fnP(byte, eval '@_') } ] ,'PL' => [ sub { _nuP(byte, eval '@_') }, sub { _rdP(byte, eval '@_') }, sub { _wrP(byte, eval '@_') }, sub { _fnP(byte, eval '@_') } ] ,'PI' => [ sub { _nuP(short, eval '@_') }, sub { _rdP(short, eval '@_') }, sub { _wrP(short, eval '@_') }, sub { _fnP(short, eval '@_') } ] ,'PJ' => [ sub { _nuP(long, eval '@_') }, sub { _rdP(long, eval '@_') }, sub { _wrP(long, eval '@_') }, sub { _fnP(long, eval '@_') } ] ,'PE' => [ sub { _nuP(float, eval '@_') }, sub { _rdP(float, eval '@_') }, sub { _wrP(float, eval '@_') }, sub { _fnP(float, eval '@_') } ] ,'PD' => [ sub { _nuP(double, eval '@_') }, sub { _rdP(double, eval '@_') }, sub { _wrP(double, eval '@_') }, sub { _fnP(double, eval '@_') } ] }; ############################## # Helpers for complex numbers (construct/read/write/finish) sub _nucomplx { # complex-number constructor my($type, $rowlen, $extra, $nrows, $szptr) = @_; $szptr += PDL::Core::howbig($type) * $nrows * 2; return PDL->new_from_specification($type,2,$rowlen,$nrows); } sub _rdcomplx { # complex-number reader my( $type, $pdl, $row, $strptr, $rpt ) = @_; # ignore extra my $s = $pdl->get_dataref; my $rlen = 2 * PDL::Core::howbig($type) * $rpt; substr($$s, $row*$rlen, $rlen) = substr($strptr, 0, $rlen, ''); } sub _wrcomplx { # complex-number writer my( $type, $pdl, $row, $rpt ) = @_; # ignore extra my $rlen = 2 * PDL::Core::howbig($type) * $rpt; substr( ${$pdl->get_dataref}, $rlen * $row, $rlen ); } sub _fncomplx { # complex-number finisher-upper my( $type, $pdl, $n, $hdr, $opt) = shift; eval 'bswap'.(PDL::Core::howbig($type)).'($pdl)'; print STDERR "Ignoring poorly-defined TSCAL/TZERO for complex data in col. $n (".$hdr->{"TTYPE$n"}.").\n" if( length($hdr->{"TSCAL$n"}) or length($hdr->{"TZERO$n"}) ); return $pdl->reorder(2,1,0); } ############################## # Helpers for variable-length array types (construct/read/write/finish) # These look just like the complex-number case, except that they use $extra to determine the # size of the 0 dimension. sub _nuP { my( $type, $rowlen, $extra, $nrows, $szptr, $hdr, $i, $tbl ) = @_; $extra =~ s/\((.*)\)/$1/; # strip parens from $extra in-place $$szptr += 8; if($rowlen != 1) { die("rfits: variable-length record has a repeat count that isn't unity! (got $rowlen); I give up."); } # declare the PDL. Fill it with the blank value or (failing that) 0. # Since P repeat count is required to be 0 or 1, we don't need an additional dimension for the # repeat count -- the variable-length rows take that role. my $pdl = PDL->new_from_specification($type, $extra, $nrows); $pdl .= ($hdr->{"TNULL$i"} || 0); my $lenpdl = zeroes(long, $nrows); $tbl->{"len_".$hdr->{"TTYPE$i"}} = $lenpdl; return $pdl; } sub _rdP { my( $type, $pdl, $row, $strptr, $rpt, $extra, $heap_ptr, $tbl, $i ) = @_; $extra =~ s/\((.*)\)/$1/; my $s = $pdl->get_dataref; # Read current offset and length my $oflen = pdl(long,0,0); my $ofs = $oflen->get_dataref; substr($$ofs,0,8) = substr($$strptr, 0, 8, ''); $oflen->upd_data; bswap4($oflen); # Now get 'em my $rlen = $extra * PDL::Core::howbig($type); # rpt should be unity, otherwise we'd have to multiply it in. my $readlen = $oflen->at(0) * PDL::Core::howbig($type); # Store the length of this row in the header field. $tbl->{"len_".$tbl->{hdr}->{"TTYPE$i"}}->dice_axis(0,$row) .= $oflen->at(0); print "_rdP: pdl is ",join("x",$pdl->dims),"; reading row $row - readlen is $readlen\n" if($PDL::debug); # Copy the data into the output PDL. my $of = $oflen->at(1); substr($$s, $row*$rlen, $readlen) = substr($$heap_ptr, $of, $readlen); $pdl->upd_data; } sub _wrP { die "This code path should never execute - you are trying to write a variable-length array via direct handler, which is wrong. Check the code path in PDL::wfits.\n"; } sub _fnP { my( $type, $pdl, $n, $hdr, $opt ) = @_; my $post = PDL::Core::howbig($type); unless( isbigendian() ) { if( $post == 2 ) { bswap2($pdl); } elsif( $post == 4 ) { bswap4($pdl); } elsif( $post == 8 ) { bswap8($pdl); } elsif( $post != 1 ) { print STDERR "Unknown swapsize $post! This is a bug. You (may) lose..\n"; } } my $tzero = defined($hdr->{"TZERO$n"}) ? $hdr->{"TZERO$n"} : 0.0; my $tscal = defined($hdr->{"TSCAL$n"}) ? $hdr->{"TSCAL$n"} : 1.0; my $valid_tzero = ($tzero != 0.0); my $valid_tscal = ($tscal != 1.0); if( length($hdr->{"TZERO$n"}) or length($hdr->{"TSCAL$n"})) { print STDERR "Ignoring TSCAL/TZERO keywords for binary table array column - sorry, my mind is blown!\n"; } return $pdl->mv(-1,0); } ############################## # # _rfits_bintable -- snarf up a binary table, returning the named columns # in a hash ref, each element of which is a PDL or list ref according to the # header. # sub _rfits_bintable ($$$$) { my $fh = shift; my $hdr = shift; my $opt = shift; ##shift; ### (ignore $pdl argument) print STDERR "Warning: BINTABLE extension should have BITPIX=8, found ".$hdr->{BITPIX}.". Winging it...\n" unless($hdr->{BITPIX} == 8); ### Allocate the main table hash my $tbl = {}; # Table is indexed by name $tbl->{hdr} = $hdr; $tbl->{tbl} = 'binary'; my $tmp = []; # Temporary space is indexed by col. no. ### Allocate all the columns of the table, checking for consistency ### and name duplication. barf "Binary extension has no fields (TFIELDS=0)" unless($hdr->{TFIELDS}); my $rowlen = 0; for my $i(1..$hdr->{TFIELDS}) { my $iter; my $name = $tmp->[$i]->{name} = $hdr->{"TTYPE$i"} || "COL"; ### Allocate some temp space for dealing with this column my $tmpcol = $tmp->[$i] = {}; ### Check for duplicate name and change accordingly... while( defined( $tbl->{ $name } ) || ($name eq "COL") ) { $iter++; $name = ($hdr->{"TTYPE$i"} )."_$iter"; } # (Check avoids scrozzling comment fields unnecessarily) $hdr->{"TTYPE$i"} = $name unless($hdr->{"TTYPE$i"} eq $name); $tmpcol->{name} = $name; if( ($hdr->{"TFORM$i"}) =~ m/(\d*)(P?.)(.*)/ ) { ($tmpcol->{rpt}, $tmpcol->{type}, $tmpcol->{extra}) = ($1,$2,$3); # added by DJB 03.18/04 - works for my data file but is it correct? $tmpcol->{rpt} ||= 1; } else { barf "Couldn't parse BINTABLE form '" . $hdr->{"TFORM$i"} . "' for column $i (" . $hdr->{"TTYPE$i"} . ")\n" if($hdr->{"TFORM$i"}); barf "BINTABLE header is missing a crucial field, TFORM$i. I give up.\n"; } # "A bit array consists of an integral number of bytes with trailing bits zero" $tmpcol->{rpt} = PDL::ceil($tmpcol->{rpt}/8) if ($tmpcol->{type} eq 'X'); $tmpcol->{handler} = # sic - assignment $PDL::IO::FITS_bintable_handlers->{ $tmpcol->{type} } or barf "Unknown type ".$hdr->{"TFORM$i"}." in BINTABLE column $i "."(" . $hdr->{"TTYPE$i"} . ")\n That invalidates the byte count, so I give up.\n" ; ### Allocate the actual data space and increment the row length my $foo = $tmpcol->{handler}->[0]; if( ref ($foo) eq 'CODE' ) { $tmpcol->{data} = $tbl->{$name} = &{$foo}( $tmpcol->{rpt} , $tmpcol->{extra} , $hdr->{NAXIS2} , \$rowlen , $hdr # hdr and column number are passed in, in case extra info needs to be gleaned. , $i , $tbl ); } else { $tmpcol->{data} = $tbl->{$name} = PDL->new_from_specification( $foo , $tmpcol->{rpt}, , $hdr->{NAXIS2} || 1 ); $rowlen += PDL::Core::howbig($foo) * $tmpcol->{rpt}; } print "Prefrobnicated col. $i "."(".$hdr->{"TTYPE$i"}.")\ttype is ".$hdr->{"TFORM$i"}."\t length is now $rowlen\n" if($PDL::debug); } ### End of prefrobnication loop... barf "Calculated row length is $rowlen, hdr claims ".$hdr->{NAXIS1} . ". Giving up. (Set \$PDL::debug for more detailed info)\n" if($rowlen != $hdr->{NAXIS1}); ### Snarf up the whole extension, and pad to 2880 bytes... my ($rawtable, $heap, $n1, $n2); # n1 gets number of bytes in table plus gap $n1 = $hdr->{NAXIS1} * $hdr->{NAXIS2}; if($hdr->{THEAP}) { if($hdr->{THEAP} < $n1) { die("Inconsistent THEAP keyword in binary table\n"); } else { $n1 = $hdr->{THEAP}; } } # n2 gets number of bytes in heap (PCOUNT - gap). $n2 = $hdr->{PCOUNT} + ($hdr->{THEAP} ? ($hdr->{NAXIS1}*$hdr->{NAXIS2} - $hdr->{THEAP}) : 0); $n2 = ($n1+$n2-1)+2880 - (($n1+$n2-1) % 2880) - $n1; print "Reading $n1 bytes of table data and $n2 bytes of heap data....\n" if($PDL::verbose); $fh->read($rawtable, $n1); if($n2) { $fh->read($heap, $n2) } else { $heap = which(pdl(0)); # empty PDL } ### Frobnicate the rows, one at a time. for my $row(0..$hdr->{NAXIS2}-1) { my $prelen = length($rawtable); for my $i(1..$hdr->{TFIELDS}) { my $tmpcol = $tmp->[$i]; my $reader = $tmpcol->{handler}->[1]; if(ref $reader eq 'CODE') { &{$reader}( $tmpcol->{data} , $row , \$rawtable , $tmpcol->{rpt} , $tmpcol->{extra} , \$heap , $tbl , $i ); } elsif(ref $tmpcol->{data} eq 'PDL') { my $rlen = $reader * $tmpcol->{rpt}; substr( ${$tmpcol->{data}->get_dataref()}, $rlen * $row, $rlen ) = substr( $rawtable, 0, $rlen, ''); $tmpcol->{data}->upd_data; } else { die ("rfits: Bug detected: inconsistent types in BINTABLE reader\n"); } } # End of TFIELDS loop if(length($rawtable) ne $prelen - $hdr->{NAXIS1}) { die "rfits BINTABLE: Something got screwed up -- expected a length of $prelen - $hdr->{NAXIS1}, got ".length($rawtable).". Giving up.\n"; } } # End of NAXIS2 loop # # Note: the above code tickles a bug in most versions of the emacs # prettyprinter. The following "for my $i..." should be indented # two spaces. # ### Postfrobnicate the columns. for my $i(1..$hdr->{TFIELDS}) { # Postfrobnication loop my $tmpcol = $tmp->[$i]; my $post = $tmpcol->{handler}->[3]; if(ref $post eq 'CODE') { # Do postprocessing on all special types $tbl->{$tmpcol->{name}} = &$post($tmpcol->{data}, $i, $hdr, $opt); } elsif( (ref ($tmpcol->{data})) eq 'PDL' ) { # Do standard PDL-type postprocessing ## Is this call to upd_data necessary? ## I think not. (reinstate if there are bugs) # $tmpcol->{data}->upd_data; # Do swapping as necessary unless( isbigendian() ) { if( $post == 2 ) { bswap2($tmpcol->{data}); } elsif( $post == 4 ) { bswap4($tmpcol->{data}); } elsif( $post == 8 ) { bswap8($tmpcol->{data}); } elsif( $post != 1 ) { print STDERR "Unknown swapsize $post for column $i (" . $tmpcol->{name} . ")! This is a bug. Winging it.\n"; } } # Apply scaling and badval keys, which are illegal for A, L, and X # types but legal for anyone else. (A shouldn't be here, L and X # might be) if($opt->{bscale}) { my $tzero = defined($hdr->{"TZERO$i"}) ? $hdr->{"TZERO$i"} : 0.0; my $tscal = defined($hdr->{"TSCAL$i"}) ? $hdr->{"TSCAL$i"} : 1.0; # The $valid_ flags let us avoid unnecessary arithmetic. my $valid_tzero = ($tzero != 0.0); my $valid_tscal = ($tscal != 1.0); if ( $valid_tzero or $valid_tscal ) { if ( $tmpcol->{type} =~ m/[ALX]/i ) { print STDERR "Ignoring illegal TSCAL/TZERO keywords for col $i (" . $tmpcol->{name} . "); type is $tmpcol->{type})\n"; } else { # Not an illegal type -- do the scaling # (Normal execution path) # Use PDL's cleverness to work out the final datatype... my $tmp; my $pdl = $tmpcol->{data}; if($pdl->badflag() == 0) { $tmp = $pdl->flat()->slice("0:0"); } elsif($pdl->ngood > 0) { my $index = which( $pdl->flat()->isbad()==0 )->at(0); $tmp = $pdl->flat()->slice("${index}:${index}"); } else { # Do nothing if it's all bad.... $tmp = $pdl; } # Figure out the type by scaling the single element. $tmp = ($tmp - $tzero) * $tscal; # Convert the whole PDL as necessary for the scaling. $tmpcol->{data} = $pdl->convert($tmp->type) if($tmp->get_datatype != $pdl->get_datatype); # Do the scaling. $tmpcol->{data} -= $tzero; $tmpcol->{data} *= $tscal; } # End of legal-type conditional } # End of valid_ conditional delete $hdr->{"TZERO$i"}; delete $hdr->{"TSCAL$i"}; } else { # $opt->{bscale} is zero; don't scale. # Instead, copy factors into individual column headers. my %foo = ("TZERO$i"=>"BZERO", "TSCAL$i"=>"BSCALE", "TUNIT$i"=>"BUNIT"); for my $a(keys %foo) { $tmpcol->{data}->hdr->{$foo{$a}} = $hdr->{$a} if( defined($hdr->{$a}) ); } } # End of bscale checking... # Try to grab a TDIM dimension list... my @tdims = (); $tmpcol->{data}->hdrcpy(1); if(exists($hdr->{"TDIM$i"})) { if($hdr->{"TDIM$i"} =~ m/\((\s*\d+(\s*\,\s*\d+)*\s*)\)/) { my $a = $1; @tdims = map { $_+0 } split(/\,/,$a); my $tdims = pdl(@tdims); my $tds = $tdims->prodover; if($tds > $tmpcol->{data}->dim(0)) { die("rfits: TDIM$i is too big in binary table. I give up.\n"); } elsif($tds < $tmpcol->{data}->dim(0)) { print STDERR "rfits: WARNING: TDIM$i is too small in binary table. Carrying on...\n"; } $tmpcol->{data}->hdrcpy(1); my $td = $tmpcol->{data}->xchg(0,1); $tbl->{$tmpcol->{name}} = $td->reshape($td->dim(0),@tdims); } else { print STDERR "rfits: WARNING: invalid TDIM$i field in binary table. Ignoring.\n"; } } else { # Copy the PDL out to the table itself. if($hdr->{NAXIS2} > 0 && $tmpcol->{rpt}>0) { $tbl->{$tmpcol->{name}} = ( ( $tmpcol->{data}->dim(0) == 1 ) ? $tmpcol->{data}->slice("(0)") : $tmpcol->{data}->xchg(0,1) ); } } # End of PDL postfrobnication case } elsif(defined $post) { print STDERR "Postfrobnication bug detected in column $i (" . $tmpcol->{name}. "). Winging it.\n"; } } # End of postfrobnication loop over columns ### Check whether this is actually a compressed image, in which case we hand it off to the image decompressor if($hdr->{ZIMAGE} && $hdr->{ZCMPTYPE} && $opt->{expand}) { eval 'use PDL::Compression;'; if($@) { die "rfits: error while loading PDL::Compression to unpack tile-compressed image.\n\t$@\n\tUse option expand=>0 to get the binary table.\n"; } return _rfits_unpack_zimage($tbl,$opt); } ### Done! return $tbl; } ############################## ############################## # # _rfits_unpack_zimage - unpack a binary table that actually contains a compressed image # # This is implemented to support the partial spec by White, Greenfield, Pence, & Tody dated Oct 21, 1999, # with reverse-engineered bits from the CFITSIO3240 library where the spec comes up short. # ## keyword is a compression algorithm name; value is an array ref containing tile compressor/uncompressor. ## The compressor/uncompressor takes (nx, ny, data) and returns the compressed/uncompressed data. ## The four currently (2010) supported-by-CFITSIO compressors are listed. Not all have been ported, hence ## the "undef"s in the table. --CED. ## Master jump table for compressors/uncompressors. ## 0 element of each array ref is the compressor; 1 element is the uncompressor. ## Uncompressed tiles are reshaped to rows of a tile table handed in (to the compressor) ## or out (of the uncompressor); actual tile shape is fed in as $params->{tiledims}, so ## higher-than-1D compression algorithms can be used. our $tile_compressors = { 'GZIP_1' => undef , 'RICE_1' => [ ### RICE_1 compressor sub { my ($tiles, $tbl, $params) = @_; my ($compressed,$len) = $tiles->rice_compress($params->{BLOCKSIZE} || 32); $tbl->{ZNAME1} = "BLOCKSIZE"; $tbl->{ZVAL1} = $params->{BLOCKSIZE}; $tbl->{ZNAME2} = "BYTEPIX"; $tbl->{ZVAL2} = PDL::howbig($tiles->get_datatype); # Convert the compressed data to a byte array... if($tbl->{ZVAL2} != 1) { my @dims = $compressed->dims; $dims[0] *= $tbl->{ZVAL2}; my $cd2 = zeroes( byte, @dims ); my $cdr = $compressed->get_dataref; my $cd2r = $cd2->get_dataref; $$cd2r = $$cdr; $cd2->upd_data; $compressed = $cd2; } $tbl->{COMPRESSED_DATA} = $compressed->mv(0,-1); $tbl->{len_COMPRESSED_DATA} = $len; }, ### RICE_1 expander sub { my ($tilesize, $tbl, $params) = @_; my $compressed = $tbl->{COMPRESSED_DATA} -> mv(-1,0); my $bytepix = $params->{BYTEPIX} || 4; # Put the compressed tile bitstream into a variable of appropriate type. # This works by direct copying of the PDL data, which sidesteps local # byteswap issues in the usual case that the compressed stream is type # byte. But it does add the extra complication that we have to pad the # compressed array out to a factor-of-n elements in certain cases. if( PDL::howbig($compressed->get_datatype) != $bytepix ) { my @dims = $compressed->dims; my $newdim0; my $scaledim0; $scaledim0 = $dims[0] * PDL::howbig($compressed->get_datatype) / $bytepix; $newdim0 = pdl($scaledim0)->ceil; if($scaledim0 != $newdim0) { my $padding = zeroes($compressed->type, ($newdim0-$scaledim0) * $bytepix / PDL::howbig($compressed->get_datatype), @dims[1..$#dims] ); $compressed = $compressed->append($padding); } my $c2 = zeroes( $type_table_2->{$bytepix * 8}, $newdim0, @dims[1..$#dims] ); my $c2dr = $c2->get_dataref; my $cdr = $compressed->get_dataref; substr($$c2dr,0,length($$cdr)) = $$cdr; $c2->upd_data; $compressed = $c2; } return $compressed->rice_expand( $tilesize, $params->{BLOCKSIZE} || 32); } ] , 'PLIO_1' => undef , 'HCOMPRESS_1' => undef }; ## List of the eight mandatory keywords and their ZIMAGE preservation pigeonholes, for copying after we ## expand an image. our $hdrconv = { "ZSIMPLE" => "SIMPLE", "ZTENSION" => "XTENSION", "ZEXTEND" => "EXTEND", "ZBLOCKED" => "BLOCKED", "ZPCOUNT" => "PCOUNT", "ZGCOUNT" => "GCOUNT", "ZHECKSUM" => "CHECKSUM", "ZDATASUM" => "DATASUM" }; sub _rfits_unpack_zimage($$$) { my $tbl = shift; my $opt = shift; my $hdr = $tbl->{hdr}; my $tc = $tile_compressors->{$hdr->{ZCMPTYPE}}; unless(defined $tc) { print STDERR "WARNING: rfits: Compressed image has unsupported comp. type ('$hdr->{ZCMPTYPE}').\n"; return $tbl; } ############# # Declare the output image my $type; unless($type_table->{$hdr->{ZBITPIX}}) { print STDERR "WARNING: rfits: unrecognized ZBITPIX value $hdr->{ZBITPIX} in compressed image. Assuming -64.\n"; $type = $type_table_2->{-64}; } else { $type = $type_table_2->{$hdr->{ZBITPIX}}; } my @dims; for my $i(1..$hdr->{ZNAXIS}) { push(@dims,$hdr->{"ZNAXIS$i"}); } my $pdl = PDL->new_from_specification( $type, @dims ); ############ # Calculate tile size and allocate a working tile. my @tiledims; for my $i(1..$hdr->{ZNAXIS}) { if($hdr->{"ZTILE$i"}) { push(@tiledims, $hdr->{"ZTILE$i"}); } else { push(@tiledims, (($i==1) ? $hdr->{ZNAXIS1} : 1) ); } } # my $tile = PDL->new_from_specification( $type, @tiledims ); my $tiledims = pdl(@tiledims); my $tilesize = $tiledims->prodover; ########### # Calculate tile counts and compare to the number of stored tiles my $ntiles = ( pdl(@dims) / pdl(@tiledims) )->ceil; my $tilecount = $ntiles->prodover; if($tilecount != $tbl->{COMPRESSED_DATA}->dim(0)) { printf STDERR "WARNING: rfits: compressed data has $hdr->{NAXIS2} rows; we expected $tilecount (",join("x",list $ntiles),"). Winging it...\n"; } ########## # Quantization - ignore for now if($hdr->{ZQUANTIZ}) { printf STDERR "WARNING: rfits: ignoring quantization/dithering (ZQUANTIZ=$hdr->{ZQUANTIZ})\n"; } ########## # Snarf up compression parameters my $params = {}; my $i = 1; while( $hdr->{"ZNAME$i"} ) { $params->{ $hdr->{"ZNAME$i"} } = $hdr->{"ZVAL$i"}; $i++; } ########## # Enumerate tile coordinates for looping, and the corresponding row number my ($step, @steps, $steps); $step = 1; for my $i(0..$ntiles->nelem-1) { push(@steps, $step); $step *= $ntiles->at($i); } $step = pdl(@steps); # $tiledex is 2-D (coordinate-index, list-index) and enumerates all tiles by image # location; $tilerow is 1-D (list-index) and enumerates all tiles by row in the bintable my $tiledex = PDL::ndcoords($ntiles->list)->mv(0,-1)->clump($ntiles->dim(0))->mv(-1,0); $TMP::tiledex = $tiledex; my $tilerow = ($tiledex * $step)->sumover; ########## # Restore all the tiles at once my $tiles = &{$tc->[1]}( $tilesize, $tbl, $params ); # gets a (tilesize x ntiles) output my $patchup = which($tbl->{len_COMPRESSED_DATA} <= 0); if($patchup->nelem) { unless(defined $tbl->{UNCOMPRESSED_DATA}) { die "rfits: need some uncompressed data for missing compressed rows, but none were found!\n"; } if($tbl->{UNCOMPRESSED_DATA}->dim(1) != $tilesize) { die "rfits: tile size is $tilesize, but uncompressed data rows have size ".$tbl->{UNCOMPRESSED_DATA}->dim(1)."\n"; } $tiles->dice_axis(1,$patchup) .= $tbl->{UNCOMPRESSED_DATA}->dice_axis(0,$patchup)->xchg(0,1); } ########## # Slice up the output image plane into tiles, and use the threading engine # to assign everything to them. my $cutup = $pdl->range( $tiledex, [@tiledims], 't') # < ntiles, tilesize0..tilesizen > ->mv(0,-1) # < tilesize0..tilesizen, ntiles > ->clump($tiledims->nelem); # < tilesize, ntiles > $cutup .= $tiles; # dump all the tiles at once into the image - they flow back to $pdl. undef $cutup; # sever connection to prevent expensive future dataflow. ########## # Perform scaling if necessary ( Just the ZIMAGE quantization step ) # bscaling is handled farther down with treat_bscale. $pdl *= $hdr->{ZSCALE} if defined($hdr->{ZSCALE}); $pdl += $hdr->{ZZERO} if defined($hdr->{ZZERO}); ########## # Put the FITS header into the newly reconstructed image. delete $hdr->{PCOUNT}; delete $hdr->{GCOUNT}; # Copy the mandated name-conversions for my $k(keys %$hdrconv) { if($hdr->{$k}) { $hdr->{$hdrconv->{$k}} = $hdr->{$k}; delete $hdr->{$k}; } } # Copy the ZNAXIS* keywords to NAXIS* foreach (grep /^NAXIS/,keys %$hdr){ if (exists($hdr->{'Z'.$_}) && defined($hdr->{'Z'.$_})){ $hdr->{$_} = $hdr->{'Z'.$_}; } } # Clean up the ZFOO extensions and table cruft for my $k(keys %{$hdr}) { delete $hdr->{$k} if( $k=~ m/^Z/ || $k eq "TFIELDS" || $k =~ m/^TTYPE/ || $k =~ m/^TFORM/ ); } if(exists $hdr->{BSCALE}) { $pdl = treat_bscale($pdl, $hdr); } $pdl->sethdr($hdr); $pdl->hdrcpy($opt->{hdrcpy}); return $pdl; } =head2 wfits() =for ref Simple PDL FITS writer =for example wfits $pdl, 'filename.fits', [$BITPIX], [$COMPRESSION_OPTIONS]; wfits $hash, 'filename.fits', [$OPTIONS]; $pdl->wfits('foo.fits',-32); Suffix magic: # Automatically compress through pipe to gzip wfits $pdl, 'filename.fits.gz'; # Automatically compress through pipe to compress wfits $pdl, 'filename.fits.Z'; =over 3 =item * Ordinary (PDL) data handling: If the first argument is a PDL, then the PDL is written out as an ordinary FITS file with a single Header/Data Unit of data. $BITPIX is then optional and coerces the output data type according to the standard FITS convention for the BITPIX field (with positive values representing integer types and negative values representing floating-point types). If C<$pdl> has a FITS header attached to it (actually, any hash that contains a C<< SIMPLE=>T >> keyword), then that FITS header is written out to the file. The image dimension tags are adjusted to the actual dataset. If there's a mismatch between the dimensions of the data and the dimensions in the FITS header, then the header gets corrected and a warning is printed. If C<$pdl> is a slice of another PDL with a FITS header already present (and header copying enabled), then you must be careful. C will remove any extraneous C keywords (per the FITS standard), and also remove the other keywords associated with that axis: C, C, C, C, and C. This may cause confusion if the slice is NOT out of the last dimension: C and you would be best off adjusting the header yourself before calling C. You can tile-compress images according to the CFITSIO extension to the FITS standard, by adding an option hash to the arguments: =over 3 =item compress This can be either unity, in which case Rice compression is used, or a (case-insensitive) string matching the CFITSIO compression type names. Currently supported compression algorithms are: =over 3 =item * RICE_1 - linear Rice compression This uses limited-symbol-length Rice compression, which works well on low entropy image data (where most pixels differ from their neighbors by much less than the dynamic range of the image). =back =item tilesize (default C<[-1,1]>) This specifies the dimension of the compression tiles, in pixels. You can hand in a PDL, a scalar, or an array ref. If you specify fewer dimensions than exist in the image, the last dim is repeated - so "32" yields 32x32 pixel tiles in a 2-D image. A dim of -1 in any dimension duplicates the image size, so the default C<[-1,1]> causes compression along individual rows. =item tilesize (RICE_1 only; default C<32>) For RICE_1, BLOCKSIZE indicates the number of pixel samples to use for each compression block within the compression algorithm. The blocksize is independent of the tile dimensions. For RICE compression the pixels from each tile are arranged in normal pixel order (early dims fastest) and compressed as a linear stream. =back =item * Table handling: If you feed in a hash ref instead of a PDL, then the hash ref is written out as a binary table extension. The hash ref keys are treated as column names, and their values are treated as the data to be put in each column. For numeric information, the hash values should contain PDLs. The 0th dim of the PDL runs across rows, and higher dims are written as multi-value entries in the table (e.g. a 7x5 PDL will yield a single named column with 7 rows and 5 numerical entries per row, in a binary table). Note that this is slightly different from the usual concept of threading, in which dimension 1 runs across rows. ASCII tables only allow one entry per column in each row, so if you plan to write an ASCII table then all of the values of C<$hash> should have at most one dim. All of the columns' 0 dims must agree in the threading sense. That is to say, the 0th dimension of all of the values of C<$hash> should be the same (indicating that all columns have the same number of rows). As an exception, if the 0th dim of any of the values is 1, or if that value is a PDL scalar (with 0 dims), then that value is "threaded" over -- copied into all rows. Data dimensions higher than 2 are preserved in binary tables, via the TDIMn field (e.g. a 7x5x3 PDL is stored internally as seven rows with 15 numerical entries per row, and reconstituted as a 7x5x3 PDL on read). Non-PDL Perl scalars are treated as strings, even if they contain numerical values. For example, a list ref containing 7 values is treated as 7 rows containing one string each. There is no such thing as a multi-string column in FITS tables, so any nonscalar values in the list are stringified before being written. For example, if you pass in a perl list of 7 PDLs, each PDL will be stringified before being written, just as if you printed it to the screen. This is probably not what you want -- you should use L to connect the separate PDLs into a single one. (e.g. C<$a-Eglue(1,$b,$c)-Emv(1,0)>) The column names are case-insensitive, but by convention the keys of C<$hash> should normally be ALL CAPS, containing only digits, capital letters, hyphens, and underscores. If you include other characters, then case is smashed to ALL CAPS, whitespace is converted to underscores, and unrecognized characters are ignored -- so if you include the key "Au Purity (%)", it will be written to the file as a column that is named "AU_PURITY". Since this is not guaranteed to produce unique column names, subsequent columns by the same name are disambiguated by the addition of numbers. You can specify the use of variable-length rows in the output, saving space in the file. To specify variable length rows for a column named "FOO", you can include a separate key "len_FOO" in the hash to be written. The key's value should be a PDL containing the number of actual samples in each row. The result is a FITS P-type variable length column that, upon read with C, will restore to a field named FOO and a corresponding field named "len_FOO". Invalid data in the final PDL consist of a padding value (which defaults to 0 but which you may set by including a TNULL field in the hdr specificaion). Variable length arrays must be 2-D PDLs, with the variable length in the 1 dimension. Two further special keys, 'hdr' and 'tbl', can contain meta-information about the type of table you want to write. You may override them by including an C<$OPTIONS> hash with a 'hdr' and/or 'tbl' key. The 'tbl' key, if it exists, must contain either 'ASCII' or 'binary' (case-insensitive), indicating whether to write an ascii or binary table. The default is binary. [ASCII table writing is planned but does not yet exist]. You can specify the format of the table quite specifically with the 'hdr' key or option field. If it exists, then the 'hdr' key should contain fields appropriate to the table extension being used. Any field information that you don't specify will be filled in automatically, so (for example) you can specify that a particular column name goes in a particular position, but allow C to arrange the other columns in the usual alphabetical order into any unused slots that you leave behind. The C, C, C, C, C, and C keywords are ignored: their values are calculated based on the hash that you supply. Any other fields are passed into the final FITS header verbatim. As an example, the following $a = long(1,2,4); $b = double(1,2,4); wfits { 'COLA'=>$a, 'COLB'=>$b }, "table1.fits"; will create a binary FITS table called F which contains two columns called C and C. The order of the columns is controlled by setting the C keywords in the header array, so $h = { 'TTYPE1'=>'Y', 'TTYPE2'=>'X' }; wfits { 'X'=>$a, 'Y'=>$b, hdr=>$h }, "table2.fits"; creates F where the first column is called C and the second column is C. =item * multi-value handling If you feed in a perl list rather than a PDL or a hash, then each element is written out as a separate HDU in the FITS file. Each element of the list must be a PDL or a hash. [This is not implemented yet but should be soon!] =item * DEVEL NOTES ASCII tables are not yet handled but should be. Binary tables currently only handle one vector (up to 1-D array) per table entry; the standard allows more, and should be fully implemented. This means that PDL::Complex piddles currently can not be written to disk. Handling multidim arrays implies that perl multidim lists should also be handled. =back =for bad For integer types (ie C 0>), the C keyword is set to the bad value. For floating-point types, the bad value is converted to NaN (if necessary) before writing. =cut *wfits = \&PDL::wfits; BEGIN { @PDL::IO::FITS::wfits_keyword_order = ('SIMPLE','BITPIX','NAXIS','NAXIS1','BUNIT','BSCALE','BZERO'); @PDL::IO::FITS::wfits_numbered_keywords = ('CTYPE','CRPIX','CRVAL','CDELT','CROTA'); } # Until we do a rewrite these have to be file global since they # are used by the wheader routine my (%hdr, $nbytes); # Local utility routine of wfits() sub wheader ($$) { my $fh = shift; my $k = shift; if ($k =~ m/(HISTORY|COMMENT)/) { my $hc = $1; return unless ref($hdr{$k}) eq 'ARRAY'; foreach my $line (@{$hdr{$k}}) { $fh->printf( "$hc %-72s", substr($line,0,72) ); $nbytes += 80; } delete $hdr{$k}; } else { # Check that we are dealing with a scalar value in the header # Need to make sure that the header does not include PDLs or # other structures. Return unless $hdr{$k} is a scalar. my($hdrk) = $hdr{$k}; if(ref $hdrk eq 'ARRAY') { $hdrk = join("\n",@$hdrk); } return unless not ref($hdrk); if ($hdrk eq "") { $fh->printf( "%-80s", substr($k,0,8) ); } else { $fh->printf( "%-8s= ", substr($k,0,8) ); my $com = ( ref $hdr{COMMENT} eq 'HASH' ) ? $hdr{COMMENT}{$k} : undef; if ($hdrk =~ /^ *([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))? *$/) { # Number? my $cl=60-($com ? 2 : 0); my $end=' ' x $cl; $end =' /'. $com if($com); $fh->printf( "%20s%-50s", substr($hdrk,0,20), substr($end, 0, 50) ); } elsif ($hdrk eq 'F' or $hdrk eq 'T') { # Logical flags ? $fh->printf( "%20s", $hdrk ); my $end=' ' x 50; $end =' /'.$com if($com); $fh->printf( "%-50s", $end ); } else { # Handle strings, truncating as necessary # (doesn't do multicard strings like Astro::FITS::Header does) # Convert single quotes to doubled single quotes # (per FITS standard) my($st) = $hdrk; $st =~ s/\'/\'\'/g; my $sl=length($st)+2; my $cl=70-$sl-($com ? 2 : 0); $fh->print( "'$st'" ); if (defined $com) { $fh->printf( " /%-$ {cl}s", substr($com, 0, $cl) ); } else { $fh->printf( "%-$ {cl}s", ' ' x $cl ); } } } $nbytes += 80; delete $hdr{$k}; } delete $hdr{COMMENT}{$k} if ref $hdr{COMMENT} eq 'HASH'; 1; } # Write a PDL to a FITS format file # sub PDL::wfits { barf 'Usage: wfits($pdl,$file,[$BITPIX],[{options}])' if $#_<1 || $#_>3; my ($pdl,$file,$a,$b) = @_; my ($opt, $BITPIX); local $\ = undef; # fix sf.net bug #3394327 if(ref $a eq 'HASH') { $a = $opt; $BITPIX = $b; } elsif(ref $b eq 'HASH') { $BITPIX = $a; $opt = $b; } my ($k, $buff, $off, $ndims, $sz); local $SIG{PIPE}; if ($file =~ /\.gz$/) { # Handle suffix-style compression $SIG{PIPE}= sub {}; # Prevent crashing if gzip dies $file = "|gzip -9 > $file"; } elsif ($file =~ /\.Z$/) { $SIG{PIPE}= sub {}; # Prevent crashing if compress dies $file = "|compress > $file"; } else{ $file = ">$file"; } #### Figure output type my @outputs = (); my $issue_nullhdu; if( UNIVERSAL::isa($pdl,'PDL') ) { $issue_nullhdu = 0; push(@outputs, $pdl); } elsif( ref($pdl) eq 'HASH' ) { $issue_nullhdu = 1; push(@outputs, $pdl); } elsif( ref($pdl) eq 'ARRAY' ) { $issue_nullhdu = 1; @outputs = @$pdl; } elsif( length(ref($pdl))==0 ) { barf "wfits: needs a HASH or PDL argument to write out\n"; } else { barf "wfits: unknown ref type ".ref($pdl)."\n"; } ## Open file & prepare to write binary info my $fh = IO::File->new( $file ) or barf "Unable to create FITS file $file\n"; binmode $fh; if($issue_nullhdu) { _wfits_nullhdu($fh); } for $pdl(@outputs) { if(ref($pdl) eq 'HASH') { my $table_type = ( exists($pdl->{tbl}) ? ($pdl->{tbl} =~ m/^a/i ? 'ascii' : 'binary') : "binary" ); _wfits_table($fh,$pdl,$table_type); } elsif( UNIVERSAL::isa($pdl,'PDL') ) { ### Regular image writing. $BITPIX = "" unless defined $BITPIX; if ($BITPIX eq "") { $BITPIX = 8 if $pdl->get_datatype == $PDL_B; $BITPIX = 16 if $pdl->get_datatype == $PDL_S || $pdl->get_datatype == $PDL_US; $BITPIX = 32 if $pdl->get_datatype == $PDL_L; $BITPIX = 64 if $pdl->get_datatype == $PDL_LL; $BITPIX = -32 if $pdl->get_datatype == $PDL_F; $BITPIX = -64 if $pdl->get_datatype == $PDL_D; $BITPIX = 8 * PDL::Core::howbig($PDL_IND) if($pdl->get_datatype==$PDL_IND); } if ($BITPIX eq "") { $BITPIX = -64; warn "wfits: PDL has an unsupported datatype -- defaulting to 64-bit float.\n"; } my $convert = sub { return $_[0] }; # Default - do nothing $convert = sub {byte($_[0])} if $BITPIX == 8; $convert = sub {short($_[0])} if $BITPIX == 16; $convert = sub {long($_[0])} if $BITPIX == 32; $convert = sub {longlong($_[0])} if $BITPIX == 64; $convert = sub {float($_[0])} if $BITPIX == -32; $convert = sub {double($_[0])} if $BITPIX == -64; # Automatically figure output scaling my $bzero = 0; my $bscale = 1; if ($BITPIX>0) { my $min = $pdl->min; my $max = $pdl->max; my ($dmin,$dmax) = (0, 2**8-1) if $BITPIX == 8; ($dmin,$dmax) = (-2**15, 2**15-1) if $BITPIX == 16; ($dmin,$dmax) = (-2**31, 2**31-1) if $BITPIX == 32; ($dmin,$dmax) = (-(pdl(longlong,1)<<63), (pdl(longlong,1)<<63)-1) if $BITPIX==64; if ($min<$dmin || $max>$dmax) { $bzero = $min - $dmin; $max -= $bzero; $bscale = $max/$dmax if $max>$dmax; } print "BSCALE = $bscale && BZERO = $bzero\n" if $PDL::verbose; } # Check for tile-compression format for the image, and handle it. # We add the image-compression format tags and reprocess the whole # shebang as a binary table. if($opt->{compress}) { croak "Placeholder -- tile compression not yet supported\n"; } ############################## ## Check header and prepare to write it out my($h) = $pdl->gethdr(); # Extra logic: if we got handed a vanilla hash that that is *not* an Astro::FITS::Header, but # looks like it's a FITS header encoded in a hash, then attempt to process it with # Astro::FITS::Header before writing it out -- this helps with cleanup of tags. if($PDL::Astro_FITS_Header and defined($h) and ref($h) eq 'HASH' and !defined( tied %$h ) ) { my $all_valid_fits = 1; for my $k(keys %$h) { if(length($k) > 8 or $k !~ m/^[A-Z_][A-Z\d\_]*$/i ) { $all_valid_fits = 0; last; } } if($all_valid_fits) { # All the keys look like valid FITS header keywords -- so # create a tied FITS header object and use that instead. my $afh = new Astro::FITS::Header( ); my %hh; tie %hh, "Astro::FITS::Header", $afh; for (keys %$h) { $hh{$_} = $h->{$_}; } $h = \%hh; } } # Now decide whether to emit a hash or an AFH object if(defined($h) && ( (defined (tied %$h)) && (UNIVERSAL::isa(tied %$h,"Astro::FITS::Header"))) ){ my $k; ##n############################ ## Tied-hash code -- I'm too lazy to incorporate this into KGB's ## direct hash handler below, so I've more or less just copied and ## pasted with some translation. --CED ## my $hdr = tied %$h; # # Put advertising comment in the SIMPLE field #n if($issue_nullhdu) { $h->{XTENSION} = "IMAGE"; } else { $h->{SIMPLE} = 'T'; my(@a) = $hdr->itembyname('SIMPLE'); $a[0]->comment('Created with PDL (http://pdl.perl.org)'); # and register it as a LOGICAL rather than a string $a[0]->type('LOGICAL'); } # # Use tied interface to set all the keywords. Note that this # preserves existing per-line comments, only changing the values. # $h->{BITPIX} = $BITPIX; $h->{NAXIS} = $pdl->getndims; my $correction = 0; for $k(1..$h->{NAXIS}) { $correction |= (exists $h->{"NAXIS$k"} and $h->{"NAXIS$k"} != $pdl->dim($k-1) ); $h->{"NAXIS$k"} = $pdl->getdim($k-1); } carp("Warning: wfits corrected dimensions of FITS header") if($correction); $h->{BUNIT} = "Data Value" unless exists $h->{BUNIT}; $h->{BSCALE} = $bscale if($bscale != 1); $h->{BZERO} = $bzero if($bzero != 0); if ( $pdl->badflag() ) { if ( $BITPIX > 0 ) { my $a = &$convert(pdl(0.0)); $h->{BLANK} = $a->badvalue(); } else { delete $h->{BLANK}; } } # Use object interface to sort the lines. This is complicated by # the need for an arbitrary number of NAXIS lines in the middle # of the sorting. Keywords with a trailing '1' in the sorted-order # list get looped over. my($kk) = 0; my(@removed_naxis) = (); for $k(0..$#PDL::IO::FITS::wfits_keyword_order) { my($kn) = 0; my @index; do { # Loop over numericised keywords (e.g. NAXIS1) my $kw = $PDL::IO::FITS::wfits_keyword_order[$k]; # $kw get keyword $kw .= (++$kn) if( $kw =~ s/\d$//); # NAXIS1 -> NAXIS @index = $hdr->index($kw); if(defined $index[0]) { if($kn <= $pdl->getndims){ $hdr->insert($kk, $hdr->remove($index[0])) unless ($index[0] == $kk) ; $kk++; } else{ #remove e.g. NAXIS3 from hdr if NAXIS==2 $hdr->removebyname($kw); push(@removed_naxis,$kw); } } } while((defined $index[0]) && $kn); } foreach my $naxis(@removed_naxis){ $naxis =~ m/(\d)$/; my $n = $1; foreach my $kw(@PDL::IO::FITS::wfits_numbered_keywords){ $hdr->removebyname($kw . $n); } } # # Delete the END card if necessary (for later addition at the end) # $hdr->removebyname('END'); # # Make sure that the HISTORY lines all come at the end # my @hindex = $hdr->index('HISTORY'); for $k(0..$#hindex) { $hdr->insert(-1-$k, $hdr->remove($hindex[-1-$k])); } # # Make sure the last card is an END # $hdr->insert(scalar($hdr->cards), Astro::FITS::Header::Item->new(Keyword=>'END')); # # Write out all the cards, and note how many bytes for later padding. # my $s = join("",$hdr->cards); $fh->print( $s ); $nbytes = length $s; } else { ## ## Legacy emitter (note different advertisement in the SIMPLE ## comment, for debugging!) ## if($issue_nullhdu) { $fh->printf( "%-80s", "XTENSION= 'IMAGE'" ); } else { $fh->printf( "%-80s", "SIMPLE = T / PDL::IO::FITS::wfits (http://pdl.perl.org)" ); } $nbytes = 80; # Number of bytes written so far # Write FITS header %hdr = (); if (defined($h)) { for (keys %$h) { $hdr{uc $_} = $$h{$_} } # Copy (ensuring keynames are uppercase) } delete $hdr{SIMPLE}; delete $hdr{'END'}; $hdr{BITPIX} = $BITPIX; $hdr{BUNIT} = "Data Value" unless exists $hdr{BUNIT}; wheader($fh, 'BITPIX'); $ndims = $pdl->getndims; # Dimensions of data array $hdr{NAXIS} = $ndims; wheader($fh, 'NAXIS'); for $k (1..$ndims) { $hdr{"NAXIS$k"} = $pdl->getdim($k-1) } for $k (1..$ndims) { wheader($fh,"NAXIS$k") } if ($bscale != 1 || $bzero != 0) { $hdr{BSCALE} = $bscale; $hdr{BZERO} = $bzero; wheader($fh,'BSCALE'); wheader($fh,'BZERO'); } wheader($fh,'BUNIT'); # IF badflag is set # and BITPIX > 0 - ensure the header contains the BLANK keyword # (make sure it's for the correct type) # otherwise - make sure the BLANK keyword is removed if ( $pdl->badflag() ) { if ( $BITPIX > 0 ) { my $a = &$convert(pdl(0.0)); $hdr{BLANK} = $a->badvalue(); } else { delete $hdr{BLANK}; } } for $k (sort fits_field_cmp keys %hdr) { wheader($fh,$k) unless $k =~ m/HISTORY/; } wheader($fh, 'HISTORY'); # Make sure that HISTORY entries come last. $fh->printf( "%-80s", "END" ); $nbytes += 80; } # # Pad the header to a legal value and write the rest of the FITS file. # $nbytes %= 2880; $fh->print( " "x(2880-$nbytes) ) if $nbytes != 0; # Fill up HDU # Decide how to byte swap - note does not quite work yet. Needs hack # to IO.xs my $bswap = sub {}; # Null routine if ( !isbigendian() ) { # Need to set a byte swap routine $bswap = \&bswap2 if $BITPIX==16; $bswap = \&bswap4 if $BITPIX==32 || $BITPIX==-32; $bswap = \&bswap8 if $BITPIX==-64 || $BITPIX==64; } # Write FITS data my $p1d = $pdl->copy->reshape($pdl->nelem); # Data as 1D stream; $off = 0; $sz = PDL::Core::howbig(&$convert($p1d->slice('0:0'))->get_datatype); $nbytes = $p1d->getdim(0) * $sz; # Transfer data in blocks (because might need to byte swap) # Buffer is also type converted on the fly my $BUFFSZ = 360*2880; # = ~1Mb - must be multiple of 2880 my $tmp; if ( $pdl->badflag() and $BITPIX < 0 and $PDL::Bad::UseNaN == 0 ) { # just print up a message - conversion is actually done in the loop print "Converting PDL bad value to NaN\n" if $PDL::verbose; } while ($nbytes - $off > $BUFFSZ) { # Data to be transferred $buff = &$convert( ($p1d->slice( ($off/$sz).":". (($off+$BUFFSZ)/$sz-1)) -$bzero)/$bscale ); # if there are bad values present, and output type is floating-point, # convert the bad values to NaN's. We can ignore integer types, since # we have set the BLANK keyword # if ( $pdl->badflag() and $BITPIX < 0 and $PDL::Bad::UseNaN == 0 ) { $buff->inplace->setbadtonan(); } &$bswap($buff); $fh->print( ${$buff->get_dataref} ); $off += $BUFFSZ; } $buff = &$convert( ($p1d->slice($off/$sz.":-1") - $bzero)/$bscale ); if ( $pdl->badflag() and $BITPIX < 0 and $PDL::Bad::UseNaN == 0 ) { $buff->inplace->setbadtonan(); } &$bswap($buff); $fh->print( ${$buff->get_dataref} ); # Fill HDU and close # note that for the data space the fill character is \0 not " " # $fh->print( "\0"x(($BUFFSZ - $buff->getdim(0) * $sz)%2880) ); } # end of image writing block else { # Not a PDL and not a hash ref barf("wfits: unknown data type - quitting"); } } # end of output loop $fh->close(); 1; } ###################################################################### ###################################################################### # Compare FITS headers in a sensible manner. =head2 fits_field_cmp =for ref fits_field_cmp Sorting comparison routine that makes proper sense of the digits at the end of some FITS header fields. Sort your hash keys using "fits_field_cmp" and you will get (e.g.) your "TTYPE" fields in the correct order even if there are 140 of them. This is a standard kludgey perl comparison sub -- it uses the magical $a and $b variables, rather than normal argument passing. =cut sub fits_field_cmp { if( $a=~m/^(.*[^\d])(\d+)$/ ) { my ($an,$ad) = ($1,$2); if( $b=~m/^(.*[^\d])(\d+)$/ ) { my($bn,$bd) = ($1,$2); if($an eq $bn) { return $ad<=>$bd; } } } $a cmp $b; } =head2 _rows() =for ref Return the number of rows in a variable for table entry You feed in a PDL or a list ref, and you get back the 0th dimension. =cut sub _rows { my $var = shift; return $var->dim(0) if( UNIVERSAL::isa($var,'PDL') ); return 1+$#$var if(ref $var eq 'ARRAY'); return 1 unless(ref $var); print STDERR "Warning: _rows found an unacceptable ref. ".ref $var.". Ignoring...\n" if($PDL::verbose); return undef; } =head2 _prep_table() =for ref Accept a hash ref containing a table, and return a header describing the table and a string to be written out as the table, or barf. You can indicate whether the table should be binary or ascii. The default is binary; it can be overridden by the "tbl" field of the hash (if present) or by parameter. =cut our %bintable_types = ( 'byte'=>['B',1], 'short'=>['I',2], 'ushort'=>['J',4, sub {return long shift;}], 'long'=>['J',4], 'longlong'=>['D', 8, sub {return double shift;}], 'float'=>['E',4], 'double'=>['D',8], # 'complex'=>['M',8] # Complex doubles are supported (actually, they aren't at the moment) ); sub _prep_table { my ($hash,$tbl,$nosquish) = @_; my $ohash; my $hdr = $hash->{hdr}; my $heap = ""; # Make a local copy of the header. my $h = {}; if(defined $hdr) { local $_; for (keys %$hdr) {$h->{$_} = $hdr->{$_}}; } $hdr = $h; $tbl = $hash->{tbl} unless defined($tbl); barf "_prep_table called without a HASH reference as the first argument" unless ref $hash eq 'HASH'; ##### # Figure out how many columns are in the table my @colkeys = grep( ( !m/^(hdr|tbl)$/ and !m/^len_/ and defined $hash->{$_}), sort fits_field_cmp keys %$hash ); my $cols = @colkeys; print "Table seems to have $cols columns...\n" if($PDL::verbose); ##### # Figure out how many rows are in the table, and store counts... # my $rows; my $rkey; for my $key(@colkeys) { my $r = _rows($hash->{$key}); ($rows,$rkey) = ($r,$key) unless(defined($rows) && $rows != 1); if($r != $rows && $r != 1) { barf "_prep_table: inconsistent number of rows ($rkey: $rows vs. $key: $r)\n"; } } print "Table seems to have $rows rows...\n" if($PDL::verbose); ##### # Squish and disambiguate column names # my %keysbyname; my %namesbykey; print "Renaming hash keys...\n" if($PDL::debug); for my $key(@colkeys) { my $name = $key; $name =~ tr/[a-z]/[A-Z]/; # Uppercaseify (required by FITS standard) $name =~ s/\s+/_/g; # Remove whitespace (required by FITS standard) unless($nosquish) { $name =~ s/[^A-Z0-9_-]//g; # Squish (recommended by FITS standard) } ### Disambiguate... if(defined $ohash->{$name}) { my $iter = 1; my $name2; do { $name2 = $name."_".($iter++); } while(defined $ohash->{$name2}); $name = $name2; } $ohash->{$name} = $hash->{$key}; $keysbyname{$name} = $key; $namesbykey{$key} = $name; print "\tkey '$key'\t-->\tname '$name'\n" if($PDL::debug || (($name ne $key) and $PDL::verbose)); } # The first element of colnames is ignored (since FITS starts the # count at 1) # my @colnames; # Names by number my %colnums; # Numbers by name ### Allocate any table columns that are already in the header... local $_; map { for my $a(1) { # [Shenanigans to make next work right] next unless m/^TTYPE(\d*)$/; my $num = $1; if($num > $cols || $num < 1) { print "Ignoring illegal column number $num ( should be in range 1..$cols )\n" if($PDL::verbose); delete $hdr->{$_}; next; } my $key = $hdr->{$_}; my $name; unless( $name = $namesbykey{$key}) { # assignment $name = $key; unless( $key = $keysbyname{$key}) { print "Ignoring column $num in existing header (unknown name '$key')\n" if($PDL::verbose); next; } } $colnames[$num] = $name; $colnums{$name} = $num; } } sort fits_field_cmp keys %$hdr; ### Allocate all other table columns in alphabetical order... my $i = 0; for my $k (@colkeys) { my $name = $namesbykey{$k}; unless($colnums{$name}) { while($colnames[++$i]) { } $colnames[$i] = $name; $colnums{$name} = $i; } else { $i++; } } print "Assertion failed: i ($i) != colnums ($cols)\n" if($PDL::debug && $i != $cols); print "colnames: " . join(",", map { $colnames[$_]; } (1..$cols) ) ."\n" if($PDL::debug); ######## # OK, now the columns are allocated -- spew out a header. my @converters = (); # Will fill up with conversion routines for each column my @field_len = (); # Will fill up with field lengths for each column my @internaltype = (); # Gets flag for PDLhood my @fieldvars = (); # Gets refs to all the fields of the hash. if($tbl eq 'binary') { $hdr->{XTENSION} = 'BINTABLE'; $hdr->{BITPIX} = 8; $hdr->{NAXIS} = 2; #$hdr->{NAXIS1} = undef; # Calculated below; inserted here as placeholder. $hdr->{NAXIS2} = $rows; $hdr->{PCOUNT} = 0; # Change this is variable-arrays are adopted $hdr->{GCOUNT} = 1; $hdr->{TFIELDS} = $cols; # Figure out data types, and accumulate a row length at the same time. my $rowlen = 0; # NOTE: # the conversion from ushort to long below is a hack to work # around the issue that otherwise perl treats it as a 2-byte # NOT 4-byte string on writing out, which leads to data corruption # Really ushort arrays should be written out using SCALE/ZERO # so that it can be written as an Int2 rather than Int4 # for my $i(1..$cols) { $fieldvars[$i] = $hash->{$keysbyname{$colnames[$i]}}; my $var = $fieldvars[$i]; $hdr->{"TTYPE$i"} = $colnames[$i]; my $tform; my $tstr; my $rpt; my $bytes; if( UNIVERSAL::isa($var,'PDL') ) { $internaltype[$i] = 'P'; my $t; my $dims = pdl($var->dims); ($t = $dims->slice("(0)")) .= 1; $rpt = $dims->prod; =pod =begin WHENCOMPLEXVALUESWORK if( UNIVERSAL::isa($var,'PDL::Complex') ) { $rpt = $var->dim(1); $t = 'complex' } else { $t = type $var; } =end WHENCOMPLEXVALUESWORK =cut barf "Error: wfits() currently can not handle PDL::Complex arrays (column $colnames[$i])\n" if UNIVERSAL::isa($var,'PDL::Complex'); $t = $var->type; $t = $bintable_types{$t}; unless(defined($t)) { print "Warning: converting unknown type $t (column $colnames[$i]) to double...\n" if($PDL::verbose); $t = $bintable_types{'double'}; } ($tstr, $bytes, $converters[$i]) = @$t; } elsif( ref $var eq 'ARRAY' ) { $internaltype[$i] = 'A'; $bytes = 1; # Got an array (of strings) -- find the longest element $rpt = 0; for(@$var) { my $l = length($_); $rpt = $l if($l>$rpt); } ($tstr, $bytes, $converters[$i]) = ('A',1,undef); } elsif( ref $var ) { barf "You seem to be writing out a ".(ref $var)." as a table column. I\ndon't know how to do that (yet).\n"; } else { # Scalar $internaltype[$i] = 'A'; ($tstr, $bytes, $converters[$i]) = ('A',1,undef); $rpt = length($var); } # Now check if it's a variable-length array and, if so, insert an # extra converter my $lname = "len_".$keysbyname{$colnames[$i]}; if(exists $hash->{$lname}) { my $lengths = $hash->{$lname}; # Variable length array - add extra handling logic. # First, check we're legit if( !UNIVERSAL::isa($var, 'PDL') || $var->ndims != 2 || !UNIVERSAL::isa($lengths,'PDL') || $lengths->ndims != 1 || $lengths->dim(0) != $var->dim(0) ) { die <<'FOO'; wfits(): you specified a 'len_$keysbyname{$colnames[$i]}' field in your binary table output hash, indicating a variable-length array for each row of the output table, but I'm having trouble interpreting it. Either your source column isn't a 2-D PDL, or your length column isn't a 1-D PDL, or the two lengths don't match. I give up. FOO } # The definition below wraps around the existing converter, # dumping the variable to the heap and returning the length # and index of the data for the current row as a PDL LONG. # This does the Right Thing below in the write loop, with # the side effect of putting the data into the heap. # # The main downside here is that the heap gets copied # multiple times as we accumulate it, since we are using # string concatenation to add onto it. It might be better # to preallocate a large heap, but I'm too lazy to figure # out how to do that. my $csub = $converters[$i]; $converters[$i] = sub { my $var = shift; my $row = shift; my $col = shift; my $len = $hash->{"len_".$keysbyname{$colnames[$i]}}; my $l; if(ref $len eq 'ARRAY') { $l = $len->[$row]; } elsif( UNIVERSAL::isa($len,'PDL') ) { $l = $len->dice_axis(0,$row); } elsif( ref $len ) { die "wfits: Couldn't understand length spec 'len_".$keysbyname{$colnames[$i]}."' in bintable output (length spec must be a PDL or array ref).\n"; } else { $l = $len; } # The standard says we should give a zero-offset # pointer if the current row is zero-length; hence # the ternary operator. my $ret = pdl( $l, $l ? length($heap) : 0)->long; if($l) { # This echoes the normal-table swap and accumulation # stuff below, except we're accumulating into the heap. my $tmp = $csub ? &$csub($var, $row, $col) : $var; $tmp = $tmp->slice("0:".($l-1))->sever; if(!isbigendian()) { bswap2($tmp) if($tmp->get_datatype == $PDL_S); bswap4($tmp) if($tmp->get_datatype == $PDL_L || $tmp->get_datatype == $PDL_F); bswap8($tmp) if($tmp->get_datatype == $PDL_D); } my $t = $tmp->get_dataref; $heap .= $$t; } return $ret; }; # Having defined the conversion routine, now modify tstr to make this a heap-array # reference. $tstr = sprintf("P%s(%d)",$tstr, $hash->{"len_".$keysbyname{$colnames[$i]}}->max ); $rpt = 1; $bytes = 8; # two longints per row in the main table. } $hdr->{"TFORM$i"} = "$rpt$tstr"; if(UNIVERSAL::isa($var, 'PDL') and $var->ndims > 1) { $hdr->{"TDIM$i"} = "(".join(",",$var->slice("(0)")->dims).")"; } $rowlen += ($field_len[$i] = $rpt * $bytes); } $hdr->{NAXIS1} = $rowlen; ## Now accumulate the binary table my $table = ""; for my $r(0..$rows-1) { my $row = ""; for my $c(1..$cols) { my $tmp; my $a = $fieldvars[$c]; if($internaltype[$c] eq 'P') { # PDL handling $tmp = $converters[$c] ? &{$converters[$c]}($a->slice("$r")->flat->sever, $r, $c) : $a->slice("$r")->flat->sever ; ## This would go faster if moved outside the loop but I'm too ## lazy to do it Right just now. Perhaps after it actually works. ## if(!isbigendian()) { bswap2($tmp) if($tmp->get_datatype == $PDL_S); bswap4($tmp) if($tmp->get_datatype == $PDL_L || $tmp->get_datatype == $PDL_F); bswap8($tmp) if($tmp->get_datatype == $PDL_D); } my $t = $tmp->get_dataref; $tmp = $$t; } else { # Only other case is ASCII just now... $tmp = ( ref $a eq 'ARRAY' ) ? # Switch on array or string ( $#$a == 0 ? $a->[0] : $a->[$r] ) # Thread arrays as needed : $a; $tmp .= " " x ($field_len[$c] - length($tmp)); } # Now $tmp contains the bytes to be written out... # $row .= substr($tmp,0,$field_len[$c]); } # for: $c $table .= $row; } # for: $r my $table_size = $rowlen * $rows; if( (length $table) != $table_size ) { print "Warning: Table length is ".(length $table)."; expected $table_size\n"; } return ($hdr,$table, $heap); } elsif($tbl eq 'ascii') { barf "ASCII tables not yet supported...\n"; } else { barf "unknown table type '$tbl' -- giving up."; } } # the header fill value can be blanks, but the data fill value must # be zeroes in non-ASCII tables # sub _print_to_fits ($$$) { my $fh = shift; my $data = shift; my $blank = shift; my $len = ((length $data) - 1) % 2880 + 1; $fh->print( $data . ($blank x (2880-$len)) ); } { my $ctr = 0; sub reset_hdr_ctr() { $ctr = 0; } sub add_hdr_item ($$$$;$) { my ( $hdr, $key, $value, $type, $comment ) = @_; $type = uc($type) if defined $type; my $item = Astro::FITS::Header::Item->new( Keyword=>$key, Value=>$value, Type=>$type ); $item->comment( $comment ) if defined $comment; $hdr->replace( $ctr++, $item ); }; } ############################## # # _wfits_table -- given a hash ref, try to write it out as a # table extension. The file FITS should be open when you call it. # Most of the work of creating the extension header, and all of # the work of creating the table, is handled by _prep_table(). # # NOTE: # can not think of a sensible name for the extension so calling # it TABLE for now # sub _wfits_table ($$$) { my $fh = shift; my $hash = shift; my $tbl = shift; barf "FITS BINTABLES are not supported without the Astro::FITS::Header module.\nGet it from www.cpan.org.\n" unless($PDL::Astro_FITS_Header); my ($hdr,$table, $heap) = _prep_table($hash,$tbl,0); $heap="" unless defined($heap); # Copy the prepared fields into the extension header. tie my %newhdr,'Astro::FITS::Header',my $h = Astro::FITS::Header->new; reset_hdr_ctr(); add_hdr_item $h, "XTENSION", ($tbl eq 'ascii'?"TABLE":"BINTABLE"), 'string', "from perl hash"; add_hdr_item $h, "BITPIX", $hdr->{BITPIX}, 'int'; add_hdr_item $h, "NAXIS", 2, 'int'; add_hdr_item $h, "NAXIS1", $hdr->{NAXIS1}, 'int', 'Bytes per row'; add_hdr_item $h, "NAXIS2", $hdr->{NAXIS2}, 'int', 'Number of rows'; add_hdr_item $h, "PCOUNT", length($heap), 'int', ($tbl eq 'ascii' ? undef : "No heap") ; add_hdr_item $h, "THEAP", "0", "(No gap before heap)" if(length($heap)); add_hdr_item $h, "GCOUNT", 1, 'int'; add_hdr_item $h, "TFIELDS", $hdr->{TFIELDS},'int'; add_hdr_item $h, "HDUNAME", "TABLE", 'string'; for my $field( sort fits_field_cmp keys %$hdr ) { next if( defined $newhdr{$field} or $field =~ m/^end|simple|xtension$/i); my $type = (UNIVERSAL::isa($hdr->{field},'PDL') ? $hdr->{$field}->type : ((($hdr->{$field})=~ m/^[tf]$/i) ? 'logical' : undef ## 'string' seems to have a bug - 'undef' works OK )); add_hdr_item $h, $field, $hdr->{$field}, $type, $hdr->{"${field}_COMMENT"}; } add_hdr_item $h, "END", undef, 'undef'; $hdr = join("",$h->cards); _print_to_fits( $fh, $hdr, " " ); _print_to_fits( $fh, $table.$heap, "\0" ); # use " " if it is an ASCII table # Add heap dump } sub _wfits_nullhdu ($) { my $fh = shift; if($Astro::FITS::Header) { my $h = Astro::FITS::Header->new(); reset_hdr_ctr(); add_hdr_item $h, "SIMPLE", "T", 'logical', "Null HDU (no data, only extensions)"; add_hdr_item $h, "BITPIX", -32, 'int', "Needed to make fverify happy"; add_hdr_item $h, "NAXIS", 0, 'int'; add_hdr_item $h, "EXTEND", "T", 'logical', "File contains extensions"; add_hdr_item $h, "COMMENT", "", "comment", " File written by perl (PDL::IO::FITS::wfits)"; # # The following seems to cause a problem so removing for now (I don't # believe it is required, but may be useful for people who aren't # FITS connoisseurs). It could also be down to a version issue in # Astro::FITS::Header since it worked on linux with a newer version # than on Solaris with an older version of the header module) # ## add_hdr_item $h, "COMMENT", "", "comment", ## " FITS (Flexible Image Transport System) format is defined in 'Astronomy"; ## add_hdr_item $h, "COMMENT", "", "comment", ## " and Astrophysics', volume 376, page 359; bibcode: 2001A&A...376..359H"; add_hdr_item $h, "HDUNAME", "PRIMARY", 'string'; add_hdr_item $h, "END", undef, 'undef'; my $hdr = join("",$h->cards); _print_to_fits( $fh, $hdr, " " ); } else { _print_to_fits( $fh, q+SIMPLE = T / Null HDU (no data, only extensions) BITPIX = -32 / Needed to make fverify happy NAXIS = 0 EXTEND = T / File contains extensions COMMENT Written by perl (PDL::IO::FITS::wfits) legacy code. COMMENT For best results, install Astro::FITS::Header. HDUNAME = 'PRIMARY ' END +, " "); } } 1; PDL-2.018/IO/FITS/Makefile.PL0000644060175006010010000000272112562522364013433 0ustar chmNoneuse ExtUtils::MakeMaker; use strict; use warnings; WriteMakefile( NAME => "PDL::IO::FITS", 'VERSION_FROM' => '../../Basic/Core/Version.pm', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); # Check whether FITS modules are available (external to PDL) BEGIN { $PDL::IO::FITS::wstr = ''; # no warnings; # pre 5.6 does not like this eval "use Astro::FITS::Header"; if((defined $Astro::FITS::Header::VERSION)){ # $Astro::FITS::Header::VERSION =~ m/^(\d*)/; # dist v2.1 has CVS derived VERSION 1.12 in Header.pm if($Astro::FITS::Header::VERSION < 1.12) { $PDL::IO::FITS::wstr = << "EOW"; Hmmm. You appear to have the Astro::FITS::Header module installed, which is good, but it's version $Astro::FITS::Header::VERSION -- which doesn't help PDL (need >= 1.12, i.e. distribution >= v2.1). Using internal fallback code. EOW } } else { $PDL::IO::FITS::wstr = << 'EOW'; Hmmm. You don't appear to have the Astro::FITS::Header module installed. You'll be able to read and write simple FITS files anyway, but FITS support is greatly improved if you install it. EOW } } # BEGIN # collate all warning messages at the end # where the user has a chance to see them END { if($PDL::IO::FITS::wstr) { warn << "EOF"; * Gentle warning from PDL::IO::FITS: * $PDL::IO::FITS::wstr You can get the latest Astro::FITS::Header module from CPAN -- point your browser at http://www.cpan.org. EOF } } # END PDL-2.018/IO/FlexRaw/0000755060175006010010000000000013110402046012242 5ustar chmNonePDL-2.018/IO/FlexRaw/FlexRaw.pm0000644060175006010010000006621013036512175014171 0ustar chmNone=head1 NAME PDL::IO::FlexRaw -- A flexible binary I/O format for PerlDL =head1 SYNOPSIS use PDL; use PDL::IO::FlexRaw; # To obtain the header for reading (if multiple files use the # same header, for example): # $hdr = PDL::IO::FlexRaw::_read_flexhdr("filename.hdr") ($x,$y,...) = readflex("filename" [, $hdr]) ($x,$y,...) = mapflex("filename" [, $hdr] [, $opts]) $hdr = writeflex($file, $pdl1, $pdl2,...) writeflexhdr($file, $hdr) # if $PDL::IO::FlexRaw::writeflexhdr is true and # $file is a filename, writeflexhdr() is called automatically # $hdr = writeflex($file, $pdl1, $pdl2,...) # need $hdr for something writeflex($file, $pdl1, $pdl2,...) # ..if $hdr not needed =head1 DESCRIPTION FlexRaw is a generic method for the input and output of `raw' data arrays. In particular, it is designed to read output from FORTRAN 77 UNFORMATTED files and the low-level C write function, even if the files are compressed or gzipped. As in FastRaw, the data file is supplemented by a header file (although this can be replaced by the optional C<$hdr> argument). More information can be included in the header file than for FastRaw -- the description can be extended to several data objects within a single input file. For example, to read the output of a FORTRAN program real*4 a(4,600,600) open (8,file='banana',status='new',form='unformatted') write (8) a close (8) the header file (`banana.hdr') could look like # FlexRaw file header # Header word for F77 form=unformatted Byte 1 4 # Data Float 3 # this is ignored 4 600 600 Byte 1 4 As is this, as we've got all dims The data can then be input using $a = (readflex('banana'))[1]; The format of the hdr file is an extension of that used by FastRaw. Comment lines (starting with #) are allowed, as are descriptive names (as elsewhere: byte, short, ushort, long, float, double) for the data types -- note that case is ignored by FlexRaw. After the type, one integer specifies the number of dimensions of the data `chunk', and subsequent integers the size of each dimension. So the specifier above (`Float 3 4 600 600') describes our FORTRAN array. A scalar can be described as `float 0' (or `float 1 1', or `float 2 1 1', etc.). When all the dimensions are read -- or a # appears after whitespace -- the rest of the current input line is ignored, I badvalues are being read or written. In that case, the next token will be the string C followed by the bad value used, if needed. What about the extra 4 bytes at the head and tail, which we just threw away? These are added by FORTRAN (at least on Suns, Alphas and Linux), and specify the number of bytes written by each WRITE -- the same number is put at the start and the end of each chunk of data. You I need to know all this in some cases. In general, FlexRaw tries to handle it itself, if you simply add a line saying `f77' to the header file, I any data specifiers: # FlexRaw file header for F77 form=unformatted F77 # Data Float 3 4 600 600 -- the redundancy in FORTRAN data files even allows FlexRaw to automatically deal with files written on other machines which use back-to-front byte ordering. This won't always work -- it's a 1 in 4 billion chance it won't, even if you regularly read 4Gb files! Also, it currently doesn't work for compressed files, so you can say `swap' (again before any data specifiers) to make certain the byte order is swapped. The optional C<$hdr> argument allows the use of an anonymous array to give header information, rather than using a .hdr file. For example, $header = [ {Type => 'f77'}, {Type => 'float', NDims => 3, Dims => [ 4,600,600 ] } ]; @a = readflex('banana',$header); reads our example file again. As a special case, when NDims is 1, Dims may be given as a scalar. Within PDL, readflex and writeflex can be used to write several pdls to a single file -- e.g. use PDL; use PDL::IO::FlexRaw; @pdls = ($pdl1, $pdl2, ...); $hdr = writeflex("fname",@pdls); @pdl2 = readflex("fname",$hdr); writeflexhdr("fname",$hdr); # not needed if $PDL::IO::FlexRaw::writeflexhdr is set @pdl3 = readflex("fname"); -- C produces the data file and returns the file header as an anonymous hash, which can be written to a .hdr file using C. If the package variable C<$PDL::IO::FlexRaw::writeflexhdr> is true, and the C call was with a I and not a handle, C will be called automatically (as done by C. The reading of compressed data is switched on automatically if the filename requested ends in .gz or .Z, or if the originally specified filename does not exist, but one of these compressed forms does. If C and C are given a reference to a file handle as a first parameter instead of a filename, then the data is read or written to the open filehandle. This gives an easy way to read an arbitrary slice in a big data volume, as in the following example: use PDL; use PDL::IO::FastRaw; open(DATA, "raw3d.dat"); binmode(DATA); # assume we know the data size from an external source ($width, $height, $data_size) = (256,256, 4); my $slice_num = 64; # slice to look at # Seek to slice seek(DATA, $width*$height*$data_size * $slice_num, 0); $pdl = readflex \*DATA, [{Dims=>[$width, $height], Type=>'long'}]; WARNING: In later versions of perl (5.8 and up) you must be sure that your file is in "raw" mode (see the perlfunc man page entry for "binmode", for details). Both readflex and writeflex automagically switch the file to raw mode for you -- but in code like the snipped above, you could end up seeking the wrong byte if you forget to make the binmode() call. C memory maps, rather than reads, the data files. Its interface is similar to C. Extra options specify if the data is to be loaded `ReadOnly', if the data file is to be `Creat'-ed anew on the basis of the header information or `Trunc'-ated to the length of the data read. The extra speed of access brings with it some limitations: C won't read compressed data, auto-detect f77 files, or read f77 files written by more than a single unformatted write statement. More seriously, data alignment constraints mean that C cannot read some files, depending on the requirements of the host OS (it may also vary depending on the setting of the `uac' flag on any given machine). You may have run into similar problems with common blocks in FORTRAN. For instance, floating point numbers may have to align on 4 byte boundaries -- if the data file consists of 3 bytes then a float, it cannot be read. C will warn about this problem when it occurs, and return the PDLs mapped before the problem arose. This can be dealt with either by reorganizing the data file (large types first helps, as a rule-of-thumb), or more simply by using C. =head1 BUGS The test on two dimensional byte arrays fail using g77 2.7.2, but not Sun f77. I hope this isn't my problem! Assumes gzip is on the PATH. Can't auto-swap compressed files, because it can't seek on them. The header format may not agree with that used elsewhere. Should it handle handles? Mapflex should warn and fallback to reading on SEGV? Would have to make sure that the data was written back after it was `destroyed'. =head1 FUNCTIONS =head2 readflex =for ref Read a binary file with flexible format specification =for usage Usage: ($x,$y,...) = readflex("filename" [, $hdr]) ($x,$y,...) = readflex(FILEHANDLE [, $hdr]) =head2 writeflex =for ref Write a binary file with flexible format specification =for usage Usage: $hdr = writeflex($file, $pdl1, $pdl2,...) # or $hdr = writeflex(FILEHANDLE, $pdl1, $pdl2,...) # now you must call writeflexhdr() writeflexhdr($file, $hdr) or $PDL::IO::FlexRaw::writeflexhdr = 1; # set so we don't have to call writeflexhdr $hdr = writeflex($file, $pdl1, $pdl2,...) # remember, $file must be filename writeflex($file, $pdl1, $pdl2,...) # remember, $file must be filename =head2 writeflexhdr =for ref Write the header file corresponding to a previous writeflex call =for usage Usage: writeflexhdr($file, $hdr) $file or "filename" is the filename used in a previous writeflex If $file is actually a "filename" then writeflexhdr() will be called automatically if $PDL::IO::FlexRaw::writeflexhdr is true. If writeflex() was to a FILEHANDLE, you will need to call writeflexhdr() yourself since the filename cannot be determined (at least easily). =head2 mapflex =for ref Memory map a binary file with flexible format specification =for usage Usage: ($x,$y,...) = mapflex("filename" [, $hdr] [, $opts]) =for options All of these options default to false unless set true: ReadOnly - Data should be readonly Creat - Create file if it doesn't exist Trunc - File should be truncated to a length that conforms with the header =head2 _read_flexhdr Read a FlexRaw header file and return a header structure. =for usage Usage: $hdr = PDL::IO::FlexRaw::_read_flexhdr($file) Note that C<_read_flexhdr> is supposed to be an internal function. It was not originally documented and it is not tested. However, there appeared to be no other method for obtaining a header structure from a file, so I figured I would write a small bit of documentation on it. =head1 Bad Value Support As of PDL-2.4.8, L has support for reading and writing pdls with L values in them. On C, a piddle argument with C<< $pdl->badflag == 1 >> will have the keyword/token "badvalue" added to the header file after the dimension list and an additional token with the bad value for that pdl if C<< $pdl->badvalue != $pdl->orig_badvalue >>. On C, a pdl with the "badvalue" token in the header will automatically have its L set and its L as well if it is not the standard default for that type. =for example The new badvalue support required some additions to the header structure. However, the interface is still being finalized. For reference the current C<$hdr> looks like this: $hdr = { Type => 'byte', # data type NDims => 2, # number of dimensions Dims => [640,480], # dims BadFlag => 1, # is set/set badflag BadValue => undef, # undef==default }; $badpdl = readflex('badpdl', [$hdr]); If you use bad values and try the new L bad value support, please let us know via the perldl mailing list. Suggestions and feedback are also welcome. =head1 AUTHOR Copyright (C) Robin Williams 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. Documentation contributions copyright (C) David Mertens, 2010. =cut package PDL::IO::FlexRaw; BEGIN { our $have_file_map = 0; eval "use File::Map 0.57 qw(map_file)"; $have_file_map = 1 unless $@; } use PDL; use Exporter; use FileHandle; use PDL::Types ':All'; use PDL::IO::Misc qw(bswap2 bswap4 bswap8); @PDL::IO::FlexRaw::ISA = qw/Exporter/; @EXPORT = qw/writeflex writeflexhdr readflex mapflex/; # Cast type numbers in concrete, for external file's sake... %flexnames = ( map {(typefld($_,'numval') => typefld($_,'ioname'))} typesrtkeys()); %flextypes = ( map {(typefld($_,'ioname') => typefld($_,'numval'), typefld($_,'numval') => typefld($_,'numval'), lc typefld($_,'ppsym') => typefld($_,'numval'), )} typesrtkeys()); %flexswap = ( map {my $val = typefld($_,'numval'); my $nb = PDL::Core::howbig($val); ($val => $nb > 1 ? "bswap$nb" : undef)} typesrtkeys()); # use Data::Dumper; # print Dumper \%flexnames; # print Dumper \%flextypes; # print Dumper \%flexswap; # %flexnames = ( # $PDL_B => 'byte', $PDL_S => 'short', # $PDL_US => 'ushort', $PDL_L => 'long', # $PDL_F => 'float', $PDL_D => 'double'); # %flextypes = ( # 'byte' => $PDL_B, '0' => $PDL_B, 'b' => $PDL_B, 'c' => $PDL_B, # 'short' => $PDL_S, '1' => $PDL_S, 's' => $PDL_S, # 'ushort' => $PDL_US,'2' => $PDL_US,'u' => $PDL_US, # 'long' => $PDL_L, '3' => $PDL_L, 'l' => $PDL_L, # 'float' => $PDL_F, '4' => $PDL_F, 'f' => $PDL_F, # 'double' => $PDL_D, '5' => $PDL_D, 'd' => $PDL_D # ); $PDL::IO::FlexRaw::verbose = 0; $PDL::IO::FlexRaw::writeflexhdr = defined($PDL::FlexRaw::IO::writeflexhdr) ? $PDL::FlexRaw::IO::writeflexhdr : 0; sub _read_flexhdr { my ($hname) = @_; my $hfile = new FileHandle "$hname" or barf "Couldn't open '$hname' for reading"; binmode $hfile; my ($newfile) = 1; my ($tid, @str); my (@ret); # check for ENVI files and bail (for now) my $line1 = scalar <$hfile>; barf "This is an ENVI format file, please use readenvi()\n" if $line1 =~ /^ENVI\r?$/; seek $hfile, 0, 0; # reset file pointer to beginning ITEM: while (!eof($hfile)) { my (@dims) = (); my ($ndims) = -1, ($mode) = -2; my ($have_badvalue) = undef; my ($badvalue) = undef; LINE: while (<$hfile>) { ### print STDERR "processing line '$_'\n"; next LINE if /^#/ or /^\s*$/; chop; tr/A-Z/a-z/; @str = split; TOKEN: ### print STDERR "Got tokens: " . join(',',@str) . "\n"; my $numtokens = scalar @str; foreach my $token (@str) { next LINE if $token =~ /^#/; if ($mode == -2) { # type ### print STDERR " \$mode == -2: #tokens=$numtokens, '$token'\n"; if ($newfile) { if ($token eq 'f77' || $token eq 'swap') { push @ret, { Type => $token }; $numtokens--; next ITEM; } } barf("Bad typename '$token' in readflex") if (!exists($flextypes{$token})); $tid = $flextypes{$token}; $numtokens--; $newfile = 0; $mode++; } elsif ($mode == -1) { #ndims ### print STDERR " \$mode == -1: #tokens=$numtokens, '$token'\n"; barf("Not number for ndims in readflex") if $token !~ /^\d*$/; $ndims = $token; barf("Bad ndims in readflex") if ($ndims < 0); $numtokens--; $mode++; if ($mode == $ndims and $numtokens == 0) { last LINE; } } elsif ($mode < $ndims) { # get dims ### print STDERR " # get dims: #tokens=$numtokens, '$token'\n"; barf("Not number for dimension in readflex") if $token !~ /^\d*$/; push(@dims,$token); $numtokens--; $mode++; if ($mode == $ndims and $numtokens == 0) { last LINE; } } elsif ($mode == $ndims and ! $have_badvalue) { # check for badvalue info ### print STDERR " # ! \$have_badvalue: #tokens=$numtokens, '$token'\n"; if ($token =~ /^badvalue$/ ) { $have_badvalue = 1; $numtokens--; last LINE if $numtokens==0; # using default bad value } else { last LINE; } } elsif ($mode == $ndims and $have_badvalue and $numtokens > 0) { ### print STDERR " # \$have_badvalue: #tokens = $numtokens, '$token'\n"; $badvalue = $token; last LINE; } } } last ITEM if $mode == -2; barf("Bad format in readflex header file ($ndims, $mode)") if ($ndims < 0 || $mode != $ndims); push @ret, { Type => $tid, Dims => \@dims, NDims => $ndims, BadFlag => (($have_badvalue) ? 1 : 0), BadValue => $badvalue, }; } return \@ret; } sub readchunk { my ($d, $pdl, $len, $name) = @_; my ($nread); print "Reading $len at $offset from $name\n" if $PDL::IO::FlexRaw::verbose; ($nread = read($d, ${$pdl->get_dataref}, $len)) == $len or barf "Couldn't read $len bytes at offset $offset from '$name', got $nread"; $pdl->upd_data(); $offset += $len; return 1; } sub myhandler { $flexmapok = 0; barf "Data out of alignment, can't map further\n"; die; } sub mapchunk { my ($orig, $pdl, $len, $name) = @_; # link $len at $offset from $orig to $pdl. # print "linking $len bytes from $offset\n"; $pdl->set_data_by_offset($orig,$offset); local ($flexmapok)=1; local $SIG{BUS} = \&myhandler unless $^O =~ /MSWin32/i; local $SIG{FPE} = \&myhandler; eval {$pdl->clump(-1)->at(0)}; $offset += $len; $flexmapok; } sub readflex { barf 'Usage ($x,$y,...) = readflex("filename"|FILEHANDLE [, \@hdr])' if $#_ > 1; my ($name,$h) = @_; my ($hdr, $pdl, $len, @out, $chunk, $chunkread, $data); local ($offset) = 0; my ($newfile, $swapbyte, $f77mode, $zipt) = (1,0,0,0); my $d; # print("readflex: name is $name\n"); # Test if $name is a file handle if (defined fileno($name)) { $d = $name; binmode($d); } else { $name =~ s/\.(gz|Z)$//; # strip any trailing compression suffix $data = $name; if(! -e $name ) { # If it's still not found, then... suffix: for my $suffix('gz','Z') { if( -e "$name.$suffix" ) { ## This little fillip detects gzip if we need it, and caches ## the version in a package-global variable. The return string ## is undefined if there is no gzip in the path. our $gzip_version; unless(defined($gzip_version)) { # Try running gzip -V to get the version. Redirect STDERR to STDOUT since # Apple'z gzip writes its version to STDERR. $gzip_version = `gzip -V 2>&1`; unless(defined($gzip_version)) { # That may or may not work on Microsoft Windows, so if it doesn't, # try running gzip again without the redirect. $gzip_version = `gzip -V`; } barf "FlexRaw: couldn't find the external gzip utility (to parse $name.$suffix)!" unless(defined($gzip_version)); } if($gzip_version =~ m/^Apple/) { # Apple gzip requires a suffix $data = "gzip -dcq $name.$suffix |"; } else { # Other gzips apparently don't require a suffix - they find it automagically. $data = "gzip -dcq $name |"; } $zipt = 1; last suffix; } } } my ($size) = (stat $name)[7]; $d = new FileHandle $data or barf "Couldn't open '$data' for reading"; binmode $d; $h = _read_flexhdr("$name.hdr") unless $h; } # Go through headers which reconfigure foreach $hdr (@$h) { my ($type) = $hdr->{Type}; if ($type eq 'swap') { $swapbyte = 1; } elsif ($type ne 'f77') { last; } } READ: foreach $hdr (@$h) { my ($type) = $hdr->{Type}; # Case convert when we have user data $type =~ tr/A-Z/a-z/ if $#_ == 1; if ($newfile) { if ($type eq 'f77') { $hdr = { Type => $PDL_L, Dims => [ ], NDims => 0 }; $type = $PDL_L; $f77mode = 1; } elsif ($type eq 'swap') { next READ; } else { $newfile = 0; } } if ($#_ == 1) { barf("Bad typename '$type' in readflex") if (!defined($flextypes{$type})); $type = $flextypes{$type}; } $pdl = PDL->zeroes ((new PDL::Type($type)), ref $hdr->{Dims} ? @{$hdr->{Dims}} : $hdr->{Dims}); $len = length $ {$pdl->get_dataref}; &readchunk($d,$pdl,$len,$name) or last READ; $chunkread += $len; if ($swapbyte) { my $method = $flexswap{$type}; $pdl->$method if $method; # bswap2($pdl) if $pdl->get_datatype == $PDL_S; # bswap4($pdl) if $pdl->get_datatype == $PDL_L # || $pdl->get_datatype == $PDL_F; # bswap8($pdl) if $pdl->get_datatype == $PDL_D; } if ($newfile && $f77mode) { if ($zipt || $swapbyte) { $chunk = $pdl->copy; $chunkread = 0; next READ; } else { SWAP: foreach (0,1) { seek($d,4,0); $swapbyte = $_; bswap4($pdl) if $swapbyte; $chunk = $pdl->copy; next SWAP if ! seek($d,$pdl->at,1); next SWAP if read($d,$ {$chunk->get_dataref},$len) != $len; $chunk->upd_data; bswap4($chunk) if $swapbyte; next SWAP if ($pdl->at != $chunk->at); $chunkread = 0; barf "Error can't rewind" if !seek($d,4,0); # print "OK".($swapbyte?", swapped":""),"\n"; next READ; } barf "Error: Doesn't look like f77 file (even swapped)"; } } if ($hdr->{BadFlag}) { # set badflag and badvalue if needed $pdl->badflag($hdr->{BadFlag}); $pdl->badvalue($hdr->{BadValue}) if defined $hdr->{BadValue}; } push (@out,$pdl); if ($f77mode && $chunk->at == $chunkread) { $chunkread = 0; my ($check) = $chunk->copy; &readchunk($d,$check,4,$name) or last READ; bswap4($check) if $swapbyte; if ($check->at ne $chunk->at) { barf "F77 file format error for $check cf $chunk"; last READ; } if (!eof($d)) { &readchunk($d,$chunk,4,$name) or last READ; bswap4($chunk) if $swapbyte; } else { last READ; } } } wantarray ? @out : $out[0]; } sub mapflex { my ($usage) = 'Usage ($x,$y,...) = mapflex("filename" [, \@hdr] [,\%opts])'; my $name = shift; # reference to header array my ($h, $size); # reference to options array, with defaults my (%opts) = ( 'ReadOnly' => 0, 'Creat' => 0, 'Trunc' => 0 ); my ($hdr, $d, $pdl, $len, @out, $chunk, $chunkread); local ($offset) = 0; my ($newfile, $swapbyte, $f77mode, $zipt) = (1,0,0,0); foreach (@_) { if (ref($_) eq "ARRAY") { $h = $_; } elsif (ref($_) eq "HASH") { %opts = (%opts,%$_); } else { warn $usage; } } if ($name =~ s/\.gz$// || $name =~ s/\.Z$// || (! -e $name && (-e $name.'.gz' || -e $name.'.Z'))) { barf "Can't map compressed file"; } if (!defined $h) { $h = _read_flexhdr("$name.hdr"); } # Go through headers which reconfigure foreach $hdr (@$h) { my ($type) = $hdr->{Type}; if ($type eq 'swap') { barf "Can't map byte swapped file"; } elsif ($type eq 'f77') { $f77mode = 1; } else { my($si) = 1; foreach (ref $hdr->{Dims} ? @{$hdr->{Dims}} : $hdr->{Dims}) { $si *= $_; } barf("Bad typename '$type' in mapflex") unless defined $flextypes{$type}; $type = $flextypes{$type}; $size += $si * PDL::Core::howbig ($type); } } # $s now contains estimated size of data in header -- # setting $f77mode means that it will be 8 x n bigger in reality $size += 8 if ($f77mode); if (!($opts{Creat})) { my ($s) = $size; $size = (stat $name)[7]; barf "File looks too small ($size cf header $s)" if $size < $s; } # print "Size $size f77mode $f77mode\n"; $d = PDL->zeroes(byte()); # print "Mapping total size $size\n"; # use Data::Dumper; # print "Options: ", Dumper(\%opts), "\n"; if ($have_file_map and not defined($PDL::force_use_mmap_code) ) { $d->set_data_by_file_map($name, $size, 1, ($opts{ReadOnly}?0:1), ($opts{Creat}?1:0), (0644), ($opts{Creat} || $opts{Trunc} ? 1:0) ); } else { warn "mapflex: direct mmap support being deprecated, please install File::Map\n"; $d->set_data_by_mmap($name, $size, 1, ($opts{ReadOnly}?0:1), ($opts{Creat}?1:0), (0644), ($opts{Creat} || $opts{Trunc} ? 1:0) ); } READ: foreach $hdr (@$h) { my ($type) = $hdr->{Type}; # Case convert when we have user data $type =~ tr/A-Z/a-z/ if $#_ == 1; if ($newfile) { if ($type eq 'f77') { $hdr = { Type => $PDL_L, Dims => [ ], NDims => 0 }; $type = $PDL_L; } else { $newfile = 0; } } if ($#_ == 1) { barf("Bad typename '$type' in mapflex") unless defined $flextypes{$type}; $type = $flextypes{$type}; } my $pdl = PDL->zeroes ((new PDL::Type($type)), ref $hdr->{Dims} ? @{$hdr->{Dims}} : $hdr->{Dims}); $len = length $ {$pdl->get_dataref}; &mapchunk($d,$pdl,$len,$name) or last READ; $chunkread += $len; if ($newfile && $f77mode) { if ($opts{Creat}) { $pdl->set(0,$size - 8); } else { $chunk = $pdl->copy; } $chunkread = 0; next READ; } if ($hdr->{BadFlag}) { # set badflag and badvalue if needed $pdl->badflag($hdr->{BadFlag}); $pdl->badvalue($hdr->{BadValue}) if defined $hdr->{BadValue}; } push (@out,$pdl); if ($f77mode && $chunk->at == $chunkread) { $chunkread = 0; my ($check) = $chunk->copy; &mapchunk($d,$check,4,$name) or last READ; if ($opts{Creat}) { $check->set(0,$size-8); } else { if ($check->at ne $chunk->at) { barf "F77 file format error for $check cf $chunk"; last READ; } } barf "Will only map first f77 data statement" if ($offset < $size); last READ; } } wantarray ? @out : $out[0]; } sub writeflex { my $usage = 'Usage $hdr = writeflex("filename"|FILEHANDLE,$pdl,...)'; barf $usage if $#_<0; my($name) = shift; my $isname = 0; my $hdr; my $d; # Test if $name is a file handle if (defined fileno($name)) { $d = $name; binmode $d; } else { barf $usage if ref $name; $isname = 1; my $modename = ($name =~ /^[+]?[><|]/) ? $name : ">$name"; $d = new FileHandle $modename or barf "Couldn't open '$name' for writing"; binmode $d; } foreach $pdl (@_) { barf $usage if ! ref $pdl; # print join(' ',$pdl->getndims,$pdl->dims),"\n"; push @{$hdr}, { Type => $flexnames{$pdl->get_datatype}, Dims => [ $pdl->dims ], NDims => $pdl->getndims, BadFlag => $pdl->badflag, BadValue => (($pdl->badvalue == $pdl->orig_badvalue) ? undef : $pdl->badvalue), }; print $d $ {$pdl->get_dataref}; } if (defined wantarray) { # list or scalar context writeflexhdr($name, $hdr) if $isname and $PDL::IO::FlexRaw::writeflexhdr; return $hdr; } else { # void context so write header file writeflexhdr($name, $hdr) if $isname; return; } } sub writeflexhdr { barf 'Usage writeflex("filename", $hdr)' if $#_!=1 || !ref $_[1]; my($name) = shift; my ($hdr) = shift; my $hname = "$name.hdr"; my $h = new FileHandle ">$hname" or barf "Couldn't open '$hname' for writing"; binmode $h; print $h "# Output from PDL::IO::writeflex, data in $name\n"; foreach (@$hdr) { my ($type) = $_->{Type}; if (! exists $flextypes{$type}) { barf "Writeflexhdr: will only print data elements, not $type"; next; } print $h join("\n",$_->{Type}, $_->{NDims}, (join ' ',ref $_->{Dims} ? @{$_->{Dims}} : $_->{Dims}) . (($_->{BadFlag}) ? " badvalue $_->{BadValue}" : '')), "\n\n"; } } 1; PDL-2.018/IO/FlexRaw/Makefile.PL0000644060175006010010000000035312562522364014235 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => "PDL::IO::FlexRaw", 'VERSION_FROM' => '../../Basic/Core/Version.pm', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/GD/0000755060175006010010000000000013110402046011164 5ustar chmNonePDL-2.018/IO/GD/Changes0000644060175006010010000000110512562522364012474 0ustar chmNone PDL::IO::GD Changes: 1.3: 19 Feb 2004 (Judd Taylor) - Added support to write only chunks of PNG images. - Started changelog! 1.6: 12 Oct 2005 (Judd Taylor) - Added functions to set level of compression on PNG images (write_png_ex, write_true_png_ex, write_png_best, write_true_png_best) - Added function recompress_png_best, to open a PNG file, and write it out using the best PNG compression available. 2.0: 30 Mar 2006 (Judd Taylor) - Transferred to new name PDL::IO::GD, and modified for inclusion to the PDL CVS tree. PDL-2.018/IO/GD/GD.pd0000644060175006010010000017415513101130663012023 0ustar chmNone# # GD.pd # # PDL interface to the GD c library # ('cos looping over a piddle in perl and using the perl GD lib is too slow...) # # Judd Taylor, USF IMaRS # 13 March 2003 # use strict; #use PDL; use vars qw( $VERSION ); $VERSION = "2.1"; ##################################### # Start the General Interface Docs: # ##################################### pp_addpm({ At => 'Top' }, <<'ENDPM'); =head1 NAME PDL::IO::GD - Interface to the GD image library. =head1 SYNOPSIS my $pdl = sequence(byte, 30, 30); write_png($pdl, load_lut($lutfile), "test.png"); write_true_png(sequence(100, 100, 3), "test_true.png"); my $image = read_png("test.png"); my $image = read_true_png("test_true_read.png"); write_true_png($image, "test_true_read.out.png"); my $lut = read_png_lut("test.png"); $pdl = sequence(byte, 30, 30); write_png_ex($pdl, load_lut($lutfile), "test_nocomp.png", 0); write_png_ex($pdl, load_lut($lutfile), "test_bestcomp1.png", 9); write_png_best($pdl, load_lut($lutfile), "test_bestcomp2.png"); $pdl = sequence(100, 100, 3); write_true_png_ex($pdl, "test_true_nocomp.png", 0); write_true_png_ex($pdl, "test_true_bestcomp1.png", 9); write_true_png_best($pdl, "test_true_bestcomp2.png"); recompress_png_best("test_recomp_best.png"); =head1 DESCRIPTION This is the "General Interface" for the PDL::IO::GD library, and is actually several years old at this point (read: stable). If you're feeling frisky, try the new OO interface described below. The general version just provides several image IO utility functions you can use with piddle variables. It's deceptively useful, however. =cut ENDPM ########################### # General Interface Code: # ########################### # needed header files: pp_addhdr(<<'EOH'); #include "gd.h" #include "gdfontl.h" #include "gdfonts.h" #include "gdfontmb.h" #include "gdfontg.h" #include "gdfontt.h" #include #define PKG "PDL::IO::GD" EOH # Function to write a PNG image from a piddle variable: pp_def( 'write_png', Pars => 'byte img(x,y); byte lut(i,j);', OtherPars => 'char* filename', Doc => <<'ENDDOC', Writes a 2-d PDL variable out to a PNG file, using the supplied color look-up-table piddle (hereafter referred to as a LUT). The LUT contains a line for each value 0-255 with a corresponding R, G, and B value. ENDDOC Code => <<'EOC' ); gdImagePtr im; int xsize, ysize, tmp, ind, x2, y2; char str[255]; FILE *out; if ($SIZE(i) != 3 || $SIZE(j) > 256) { croak("Wrong LUT dimensions (%"IND_FLAG", %"IND_FLAG")! (should be (3, X), where X <= 256)\n", $SIZE(i), $SIZE(j) ); } xsize = $SIZE(x); ysize = $SIZE(y); im = gdImageCreate(xsize, ysize); /* Set up the color palette */ for(ind = 0; ind < $SIZE(j); ind++) { tmp = gdImageColorAllocate(im, $lut(i=>0,j=>ind), $lut(i=>1,j=>ind), $lut(i=>2,j=>ind)); if (tmp != ind) { croak("palette mismatch on index %d (mapped to %d)!\n", ind, tmp); } } /* render the data */ for( y2 = 0; y2 < $SIZE(y); y2++ ) { for( x2 = 0; x2 < $SIZE(x); x2++ ) { gdImageSetPixel(im, x2, y2, $img(x=>x2,y=>y2)); } } /* write the image to the file */ out = fopen($COMP(filename), "wb"); gdImagePng(im, out); fclose(out); gdImageDestroy(im); EOC # Function to write a PNG image from a piddle variable, accepting a compression # level argument: pp_def( 'write_png_ex', Pars => 'img(x,y); lut(i,j);', OtherPars => 'char* filename; int level', Doc => <<'ENDDOC', Same as write_png(), except you can specify the compression level (0-9) as the last argument. ENDDOC Code => <<'EOC' ); gdImagePtr im; int xsize, ysize, tmp, ind, x2, y2; char str[255]; FILE *out; if( $COMP(level) < -1 || $COMP(level) > 9 ) { croak("Invalid compression level %d, should be [-1,9]!\n", $COMP(level) ); } if ($SIZE(i) != 3 || $SIZE(j) > 256) { croak("Wrong LUT dimensions (%"IND_FLAG", %"IND_FLAG")! (should be (3, X), where X <= 256)\n", $SIZE(i), $SIZE(j) ); } xsize = $SIZE(x); ysize = $SIZE(y); im = gdImageCreate(xsize, ysize); /* Set up the color palette */ for(ind = 0; ind < $SIZE(j); ind++) { tmp = gdImageColorAllocate(im, $lut(i=>0,j=>ind), $lut(i=>1,j=>ind), $lut(i=>2,j=>ind)); if (tmp != ind) { croak("palette mismatch on index %d (mapped to %d)!\n", ind, tmp); } } /* render the data */ for( y2 = 0; y2 < $SIZE(y); y2++ ) { for( x2 = 0; x2 < $SIZE(x); x2++ ) { gdImageSetPixel(im, x2, y2, $img(x=>x2,y=>y2)); } } /* write the image to the file */ out = fopen($COMP(filename), "wb"); gdImagePngEx(im, out, $COMP(level)); fclose(out); gdImageDestroy(im); EOC # Function to write a TRUE COLOR PNG image from a piddle variable: pp_def( 'write_true_png', Pars => 'img(x,y,z);', OtherPars => 'char* filename', Doc => <<'ENDDOC', Writes an (x, y, z(3)) PDL variable out to a PNG file, using a true color format. This means a larger file on disk, but can contain more than 256 colors. ENDDOC Code => <<'EOC' ); gdImagePtr im; int xsize, ysize, x2, y2; char str[255]; FILE *out; if ($SIZE(z) != 3) { croak("Wrong dimensions (%"IND_FLAG", %"IND_FLAG", %"IND_FLAG")! (should be (X,Y,3))\n", $SIZE(x), $SIZE(y), $SIZE(z) ); } xsize = $SIZE(x); ysize = $SIZE(y); im = gdImageCreateTrueColor(xsize, ysize); /* render the data */ for( y2 = 0; y2 < ysize; y2++ ) { for( x2 = 0; x2 < xsize; x2++ ) { gdImageSetPixel(im, x2, y2, gdImageColorResolve(im, $img(x=>x2,y=>y2,z=>0), $img(x=>x2,y=>y2,z=>1), $img(x=>x2,y=>y2,z=>2) ) ); } } /* write the image to the file */ out = fopen($COMP(filename), "wb"); gdImagePng(im, out); fclose(out); gdImageDestroy(im); EOC # Function to write a TRUE COLOR PNG image from a piddle variable, # with the specified compression level: pp_def( 'write_true_png_ex', Pars => 'img(x,y,z);', OtherPars => 'char* filename; int level', Doc => <<'ENDDOC', Same as write_true_png(), except you can specify the compression level (0-9) as the last argument. ENDDOC Code => <<'EOC' ); gdImagePtr im; int xsize, ysize, x2, y2; char str[255]; FILE *out; if( $COMP(level) < -1 || $COMP(level) > 9 ) { croak("Invalid compression level %d, should be [-1,9]!\n", $COMP(level) ); } if ($SIZE(z) != 3) { croak("Wrong dimensions (%"IND_FLAG", %"IND_FLAG", %"IND_FLAG")! (should be (X,Y,3))\n", $SIZE(x), $SIZE(y), $SIZE(z) ); } xsize = $SIZE(x); ysize = $SIZE(y); im = gdImageCreateTrueColor(xsize, ysize); /* render the data */ for( y2 = 0; y2 < ysize; y2++ ) { for( x2 = 0; x2 < xsize; x2++ ) { gdImageSetPixel(im, x2, y2, gdImageColorResolve(im, $img(x=>x2,y=>y2,z=>0), $img(x=>x2,y=>y2,z=>1), $img(x=>x2,y=>y2,z=>2) ) ); } } /* write the image to the file */ out = fopen($COMP(filename), "wb"); gdImagePngEx( im, out, $COMP(level) ); fclose(out); gdImageDestroy(im); EOC # # Add some perl level alias functions to automatically use the best compression # pp_addpm(<<'ENDPM'); =head2 write_png_best( $img(piddle), $lut(piddle), $filename ) Like write_png(), but it assumes the best PNG compression (9). =cut sub write_png_best { my $img = shift; my $lut = shift; my $filename = shift; return write_png_ex( $img, $lut, $filename, 9 ); } # End of write_png_best()... =head2 write_true_png_best( $img(piddle), $filename ) Like write_true_png(), but it assumes the best PNG compression (9). =cut sub write_true_png_best { my $img = shift; my $filename = shift; return write_true_png_ex( $img, $filename, 9 ); } # End of write_true_png_best()... ENDPM # End of best copression aliases pp_add_exported( '', 'write_png_best write_true_png_best' ); # # Function to recompress PNG files with the best compression available: # NOTE: libgd doesn't return anything, so there's nothing to check! pp_addpm( '', <<'ENDPM' ); =head2 recompress_png_best( $filename ) Recompresses the given PNG file using the best compression (9). =cut ENDPM pp_addxs( '', <<'ENDXS' ); void recompress_png_best(char* filename) CODE: gdImagePtr im; FILE* file; file = fopen(filename, "rb"); im = gdImageCreateFromPng(file); fclose(file); file = fopen(filename, "wb"); gdImagePngEx( im, file, 9 ); fclose(file); gdImageDestroy(im); ENDXS pp_add_exported( '', 'recompress_png_best' ); # End of recompress_png_best() XS code... pp_addpm(<<'EOPM'); =head2 load_lut( $filename ) Loads a color look up table from an ASCII file. returns a piddle =cut sub load_lut { return xchg(byte(cat(rcols(shift))), 0, 1); } # end of load_lut()... =head2 read_png( $filename ) Reads a (palette) PNG image into a (new) PDL variable. =cut sub read_png { my $filename = shift; # Get the image dims... my $x = _get_png_xs($filename); my $y = _get_png_ys($filename); #print "\$x=$x\t\$y=$y\n"; my $temp = zeroes(long, $x, $y); _read_png($temp, $filename); return byte($temp); } # End of read_png()... =head2 read_png_true( $filename ) Reads a true color PNG image into a (new) PDL variable. =cut sub read_true_png { my $filename = shift; # Get the image dims... my $x = _get_png_xs($filename); my $y = _get_png_ys($filename); #print "\$x=$x\t\$y=$y\n"; my $temp = zeroes(long, $x, $y, 3); _read_true_png($temp, $filename); return byte($temp); } # End of read_png()... EOPM pp_add_exported('', 'load_lut read_png read_true_png'); pp_addxs('', <<'EOXS'); int _get_png_xs(char* filename) CODE: gdImagePtr im; FILE* in; in = fopen(filename, "rb"); im = gdImageCreateFromPng(in); fclose(in); RETVAL = gdImageSX(im); gdImageDestroy(im); OUTPUT: RETVAL int _get_png_ys(char* filename) CODE: gdImagePtr im; FILE* in; in = fopen(filename, "rb"); im = gdImageCreateFromPng(in); fclose(in); RETVAL = gdImageSY(im); gdImageDestroy(im); OUTPUT: RETVAL EOXS # Function to read a TRUE COLOR PNG image into a piddle variable: pp_def( '_read_true_png', Pars => 'int [o] img(x,y,z);', OtherPars => 'char* filename', Doc => undef, Code => <<'EOC' ); gdImagePtr im; int xsize, ysize, x2, y2, z2; char* func = "PDL::IO::GD::_read_png(): "; char str[255]; FILE *in = NULL; in = fopen($COMP(filename), "rb"); if ( in == NULL ) { croak("%sError opening %s!\n", func, $COMP(filename)); } im = gdImageCreateFromPng(in); if ( im == NULL ) { croak("%sError reading PNG data!\n", func); } fclose(in); xsize = gdImageSX(im); ysize = gdImageSY(im); /* Check the dims... */ if ( !( ($SIZE(x)==xsize) && ($SIZE(y)==ysize) ) ) { croak("%sDims of %s (%dx%d) and piddle (%"IND_FLAG"x%"IND_FLAG") do not match!\n", func, $COMP(filename), xsize, ysize, $SIZE(x), $SIZE(y)); } /* read the data */ for( y2 = 0; y2 < ysize; y2++ ) { for( x2 = 0; x2 < xsize; x2++ ) { int tpixel = gdImageTrueColorPixel(im, x2, y2); $img(x=>x2,y=>y2,z=>0) = gdTrueColorGetRed(tpixel); $img(x=>x2,y=>y2,z=>1) = gdTrueColorGetGreen(tpixel); $img(x=>x2,y=>y2,z=>2) = gdTrueColorGetBlue(tpixel); } } gdImageDestroy(im); EOC # Function to read PNG image into a piddle variable: pp_def( '_read_png', Pars => 'int [o] img(x,y);', OtherPars => 'char* filename', Doc => undef, Code => <<'EOC' ); gdImagePtr im; int xsize, ysize, x2, y2; char* func = "PDL::IO::GD::_read_png(): "; char str[255]; FILE *in = NULL; in = fopen($COMP(filename), "rb"); if ( in == NULL ) { croak("%sError opening %s!\n", func, $COMP(filename)); } im = gdImageCreateFromPng(in); if ( im == NULL ) { croak("%sError reading PNG data!\n", func); } fclose(in); xsize = gdImageSX(im); ysize = gdImageSY(im); /* Check the dims... */ if ( !( ($SIZE(x)==xsize) && ($SIZE(y)==ysize) ) ) { croak("%sDims of %s (%dx%d) and piddle (%"IND_FLAG"x%"IND_FLAG") do not match!\n", func, $COMP(filename), xsize, ysize, $SIZE(x), $SIZE(y)); } /* read the data */ for( y2 = 0; y2 < ysize; y2++ ) { for( x2 = 0; x2 < xsize; x2++ ) { $img(x=>x2,y=>y2) = gdImageGetPixel(im, x2, y2); } } /* write the image to the file */ gdImageDestroy(im); EOC pp_def( '_gd_image_to_pdl_true', Pars => 'byte [o] img(x,y,z);', OtherPars => 'IV img_ptr', Doc => undef, Code => <<'ENDCODE' ); int xsize, ysize, x2, y2, z2; gdImagePtr im = INT2PTR(gdImagePtr, $COMP(img_ptr)); char* func = "PDL::IO::GD::_gd_image_to_pdl_true(): "; char str[255]; xsize = gdImageSX(im); ysize = gdImageSY(im); /* Check the dims... */ if ( !( ($SIZE(x)==xsize) && ($SIZE(y)==ysize) ) ) { croak("%sDims of gdImage (%dx%d) and piddle (%"IND_FLAG"x%"IND_FLAG") do not match!\n", func, xsize, ysize, $SIZE(x), $SIZE(y)); } /* read the data */ for( y2 = 0; y2 < ysize; y2++ ) { for( x2 = 0; x2 < xsize; x2++ ) { int tpixel = gdImageTrueColorPixel(im, x2, y2); $img(x=>x2,y=>y2,z=>0) = gdTrueColorGetRed(tpixel); $img(x=>x2,y=>y2,z=>1) = gdTrueColorGetGreen(tpixel); $img(x=>x2,y=>y2,z=>2) = gdTrueColorGetBlue(tpixel); } } ENDCODE pp_def( '_gd_image_to_pdl', Pars => 'byte [o] img(x,y);', OtherPars => 'IV img_ptr', Doc => undef, Code => <<'ENDCODE' ); int xsize, ysize, x2, y2; char* func = "PDL::IO::GD::_gd_image_to_pdl(): "; gdImagePtr im = INT2PTR(gdImagePtr, $COMP(img_ptr)); char str[255]; xsize = gdImageSX(im); ysize = gdImageSY(im); /* Check the dims... */ if ( !( ($SIZE(x)==xsize) && ($SIZE(y)==ysize) ) ) { croak("%sDims of gdImage (%dx%d) and piddle (%"IND_FLAG"x%"IND_FLAG") do not match!\n", func, xsize, ysize, $SIZE(x), $SIZE(y)); } /* read the data */ for( y2 = 0; y2 < ysize; y2++ ) { for( x2 = 0; x2 < xsize; x2++ ) { $img(x=>x2,y=>y2) = gdImageGetPixel(im, x2, y2); } } ENDCODE pp_def( '_pdl_to_gd_image_true', Pars => 'byte img(x,y,z); longlong [o] img_ptr(i)', Doc => undef, Code => <<'ENDCODE' ); gdImagePtr im; int xsize, ysize, x2, y2; char str[255]; if ($SIZE(z) != 3) { croak("Wrong dimensions (%"IND_FLAG", %"IND_FLAG", %"IND_FLAG")! (should be (X,Y,3))\n", $SIZE(x), $SIZE(y), $SIZE(z) ); } xsize = $SIZE(x); ysize = $SIZE(y); im = gdImageCreateTrueColor(xsize, ysize); /* render the data */ for( y2 = 0; y2 < ysize; y2++ ) { for( x2 = 0; x2 < xsize; x2++ ) { gdImageSetPixel(im, x2, y2, gdImageColorResolve(im, $img(x=>x2,y=>y2,z=>0), $img(x=>x2,y=>y2,z=>1), $img(x=>x2,y=>y2,z=>2) ) ); } } $img_ptr(i=>0) = (PDL_LongLong) PTR2IV(im); ENDCODE pp_def( '_pdl_to_gd_image_lut', Pars => 'byte img(x,y); byte lut(i,j); longlong [o] img_ptr(q)', Doc => undef, Code => <<'ENDCODE' ); gdImagePtr im; int xsize, ysize, tmp, ind, x2, y2; char str[255]; if ($SIZE(i) != 3 || $SIZE(j) > 256) { croak("Wrong LUT dimensions (%"IND_FLAG", %"IND_FLAG")! (should be (3, X), where X <= 256)\n", $SIZE(i), $SIZE(j) ); } xsize = $SIZE(x); ysize = $SIZE(y); im = gdImageCreate(xsize, ysize); /* Set up the color palette */ for(ind = 0; ind < $SIZE(j); ind++) { tmp = gdImageColorAllocate(im, $lut(i=>0,j=>ind), $lut(i=>1,j=>ind), $lut(i=>2,j=>ind)); if (tmp != ind) { croak("palette mismatch on index %d (mapped to %d)!\n", ind, tmp); } } /* render the data */ for( y2 = 0; y2 < $SIZE(y); y2++ ) { for( x2 = 0; x2 < $SIZE(x); x2++ ) { gdImageSetPixel(im, x2, y2, $img(x=>x2,y=>y2)); } } $img_ptr(q=>0) = (PDL_LongLong) PTR2IV(im); ENDCODE # Function to write Read PNG LUT Table into a piddle variable: pp_addpm(<<'EOPM'); =head2 my $lut = read_png_lut( $filename ) Reads a color LUT from an already-existing palette PNG file. =cut sub read_png_lut { my $filename = shift; my $lut = zeroes(byte, 3, 256); _read_png_lut($lut, $filename); return $lut; } # End of read_png_lut()... EOPM pp_add_exported('', 'read_png_lut'); pp_def( '_read_png_lut', Pars => 'byte [o] lut(c,i);', OtherPars => 'char* filename', Doc => undef, Code => <<'EOC' ); gdImagePtr im; int ind; char* func = "PDL::IO::GD::_read_png_lut(): "; char str[255]; FILE *in = NULL; /* Check dims: */ if ( $SIZE(c) != 3 ) { croak("%sLUT dims should be 3,256!\n", func); } in = fopen($COMP(filename), "rb"); if ( in == NULL ) { croak("%sError opening %s!\n", func, $COMP(filename)); } im = gdImageCreateFromPng(in); if ( im == NULL ) { croak("%sError reading PNG data!\n", func); } fclose(in); /* read the data */ for( ind = 0; ind < 256; ind++ ) { $lut(c=>0,i=>ind) = gdImageRed(im, ind); $lut(c=>1,i=>ind) = gdImageGreen(im, ind); $lut(c=>2,i=>ind) = gdImageBlue(im, ind); } gdImageDestroy(im); EOC pp_addxs( <<'ENDXS' ); void _gdImageDestroy( im ) gdImagePtr im CODE: /* fprintf( stderr, "_gdImageDestroy(): gdImagePtr = %p (d=%d x=%x l=%ld ll=%lld)\n", im, im, im, im, im);*/ gdImageDestroy ( im ); OUTPUT: ENDXS #################### # NEW OO Interface # #################### ############################################## # Autogeneration of the low level interface: # ############################################## ################################################## # Process functions to create images from files: # ################################################## ######################################### # Start the PDL::IO::GD OO module code: # ######################################### pp_addpm( { At => 'Bot' }, <<'ENDPM' ); =head1 OO INTERFACE Object Oriented interface to the GD image library. =head1 SYNOPSIS # Open an existing file: # my $gd = PDL::IO::GD->new( { filename => "test.png" } ); # Query the x and y sizes: my $x = $gd->SX(); my $y = $gd->SY(); # Grab the PDL of the data: my $pdl = $gd->to_pdl(); # Kill this thing: $gd->DESTROY(); # Create a new object: # my $im = PDL::IO::GD->new( { x => 300, y => 300 } ); # Allocate some colors: # my $black = $im->ColorAllocate( 0, 0, 0 ); my $red = $im->ColorAllocate( 255, 0, 0 ); my $green = $im->ColorAllocate( 0, 255, 0 ); my $blue = $im->ColorAllocate( 0, 0, 255 ); # Draw a rectangle: $im->Rectangle( 10, 10, 290, 290, $red ); # Add some text: $im->String( gdFontGetLarge(), 20, 20, "Test Large Font!", $green ); # Write the output file: $im->write_Png( "test2.png" ); =head1 DESCRIPTION This is the Object-Oriented interface from PDL to the GD image library. See L for more information on the GD library and how it works. =head2 IMPLEMENTATION NOTES Surprisingly enough, this interface has nothing to do with the other Perl->GD interface module, aka 'GD' (as in 'use GD;'). This is done from scratch over the years. Requires at least version 2.0.22 of the GD library, but it's only been thoroughly tested with gd-2.0.33, so it would be best to use that. The 2.0.22 requirement has to do with a change in GD's font handling functions, so if you don't use those, then don't worry about it. I should also add, the statement about "thoroughly tested" above is mostly a joke. This OO interface is very young, and it has I been tested at all, so if something breaks, email me and I'll get it fixed ASAP (for me). Functions that manipulate and query the image objects generally have a 'gdImage' prefix on the function names (ex: gdImageString()). I've created aliases here for all of those member functions so you don't have to keep typing 'gdImage' in your code, but the long version are in there as well. =head1 METHODS =cut use PDL; use PDL::Slices; use PDL::IO::Misc; # # Some helper functions: # sub _pkg_name { return "PDL::IO::GD::" . (shift) . "()"; } # ID a file type from it's filename: sub _id_image_file { my $filename = shift; return 'png' if( $filename =~ /\.png$/ ); return 'jpg' if( $filename =~ /\.jpe?g$/ ); return 'wbmp' if( $filename =~ /\.w?bmp$/ ); return 'gd' if( $filename =~ /\.gd$/ ); return 'gd2' if( $filename =~ /\.gd2$/ ); return 'gif' if( $filename =~ /\.gif$/ ); return 'xbm' if( $filename =~ /\.xbm$/ ); return undef; } # End of _id_image_file()... # Load a new file up (don't read it yet): sub _img_ptr_from_file { my $filename = shift; my $type = shift; return _gdImageCreateFromPng( $filename ) if( $type eq 'png' ); return _gdImageCreateFromJpeg( $filename ) if( $type eq 'jpg' ); return _gdImageCreateFromWBMP( $filename ) if( $type eq 'wbmp' ); return _gdImageCreateFromGd( $filename ) if( $type eq 'gd' ); return _gdImageCreateFromGd2( $filename ) if( $type eq 'gd2' ); return _gdImageCreateFromGif( $filename ) if( $type eq 'gif' ); return _gdImageCreateFromXbm( $filename ) if( $type eq 'xbm' ); return undef; } # End of _img_ptr_from_file()... # ID a file type from it's "magic" header in the image data: sub _id_image_data { my $data = shift; my $magic = substr($data,0,4); return 'png' if( $magic eq "\x89PNG" ); return 'jpg' if( $magic eq "\377\330\377\340" ); return 'jpg' if( $magic eq "\377\330\377\341" ); return 'jpg' if( $magic eq "\377\330\377\356" ); return 'gif' if( $magic eq "GIF8" ); return 'gd2' if( $magic eq "gd2\000" ); # Still need filters for WBMP and .gd! return undef; } # End of _id_image_data()... # Load a new data scalar up: sub _img_ptr_from_data { my $data = shift; my $type = shift; return _gdImageCreateFromPngPtr( $data ) if( $type eq 'png' ); return _gdImageCreateFromJpegPtr( $data ) if( $type eq 'jpg' ); return _gdImageCreateFromWBMPPtr( $data ) if( $type eq 'wbmp' ); return _gdImageCreateFromGdPtr( $data ) if( $type eq 'gd' ); return _gdImageCreateFromGd2Ptr( $data ) if( $type eq 'gd2' ); return _gdImageCreateFromGifPtr( $data ) if( $type eq 'gif' ); return undef; } # End of _img_ptr_from_data()... =head2 new Creates a new PDL::IO::GD object. Accepts a hash describing how to create the object. Accepts a single hash ( with curly braces ), an inline hash (the same, but without the braces) or a single string interpreted as a filename. Thus the following are all equivalent: PDL::IO::GD->new( {filename => 'image.png'} ); PDL::IO::GD->new( filename => 'image.png' ); PDL::IO::GD->new( 'image.png' ); If the hash has: pdl => $pdl_var (lut => $lut_piddle) Then a new GD is created from that PDL variable. filename => $file Then a new GD is created from the image file. x => $num, y => $num Then a new GD is created as a palette image, with size x, y x => $num, y => $num, true_color => 1 Then a new GD is created as a true color image, with size x, y data => $scalar (type => $typename) Then a new GD is created from the file data stored in $scalar. If no type is given, then it will try to guess the type of the data, but this will not work for WBMP and gd image types. For those types, you _must_ specify the type of the data, or the operation will fail. Valid types are: 'jpg', 'png', 'gif', 'gd', 'gd2', 'wbmp'. Example: my $gd = PDL::IO::GD->new({ pdl => $pdl_var }); my $gd = PDL::IO::GD->new({ pdl => $pdl_var, lut => $lut_piddle }); my $gd = PDL::IO::GD->new({ filename => "image.png" }); my $gd = PDL::IO::GD->new({ x => 100, y => 100 }); my $gd = PDL::IO::GD->new({ x => 100, y => 100, true_color => 1 }); my $gd = PDL::IO::GD->new({ data => $imageData }); my $gd = PDL::IO::GD->new({ data => $imageData, type => 'wbmp' }); =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; #my $self = $class->SUPER::new( @_ ); my $self = {}; my $sub = _pkg_name( "new" ); # Figure out our options: # I want a single hash. I handle several cases here my $options; if( @_ == 1 && ref $_[0] eq 'HASH' ) { # single hash argument. Just take it $options = shift; } elsif( @_ == 1 && ! ref $_[0] ) { # single scalar argument. Treat it as a filename by default my $filename = shift; $options = { filename => $filename }; } else { # the only other acceptable option is an inline hash. This is valid if I # have an even number of arguments, and the even-indexed ones (the keys) # are scalars if( @_ % 2 == 0 ) { my @pairs = @_; my $Npairs = scalar(@pairs)/2; use List::MoreUtils 'none'; if( List::MoreUtils::none { ref $pairs[2*$_] } 0..$Npairs-1 ) { # treat the arguments as a hash $options = { @pairs } } } } if( !defined $options ) { die <{pdl} ) ) { # Create it from a PDL variable: my $pdl = $options->{pdl}; $pdl->make_physical(); my $num_dims = scalar( $pdl->dims() ); if( $num_dims == 2 ) { if( defined( $options->{lut} ) ) { my $ptr = zeroes( longlong, 1 ); my $lut = $options->{lut}; _pdl_to_gd_image_lut( $pdl, $lut, $ptr ); # print STDERR "in new (with lut), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_lut() failed!\n" if( $self->{IMG_PTR} == 0 ); } else { my $ptr = zeroes( longlong, 1 ); my $lut = sequence(byte, 255)->slice("*3,:"); _pdl_to_gd_image_lut( $pdl, $lut, $ptr ); # print STDERR "in new (no lut), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_lut() failed!\n" if( $self->{IMG_PTR} == 0 ); } } elsif( $num_dims == 3 ) { my $ptr = zeroes( longlong, 1 ); _pdl_to_gd_image_true( $pdl, $ptr ); # print STDERR "in new (ndims=3), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_true() failed!\n" if( $self->{IMG_PTR} == 0 ); } else { die "Can't create a PDL::IO::GD from a PDL with bad dims!\n"; } } elsif( exists( $options->{filename} ) ) { # Create it from a file: if( !defined $options->{filename} ) { die "PDL::IO::GD::new got an undefined filename. Giving up.\n"; } # Figure out what type of file it is: $self->{input_type} = _id_image_file( $options->{filename} ) or die "$sub: Can't determine image type of filename => \'$options->{filename}\'!\n"; # Read in the file: $self->{IMG_PTR} = _img_ptr_from_file( $options->{filename}, $self->{input_type} ) or die "$sub: Can't read in the input file!\n"; } elsif( defined( $options->{x} ) && defined( $options->{y} ) ) { # Create an empty image: my $done = 0; if( defined( $options->{true_color} ) ) { if( $options->{true_color} ) { # Create an empty true color image: $self->{IMG_PTR} = _gdImageCreateTrueColor( $options->{x}, $options->{y} ); die "$sub: _gdImageCreateTrueColor() failed!\n" if( $self->{IMG_PTR} == 0 ); $done = 1; } } unless( $done ) { # Create an empty palette image: $self->{IMG_PTR} = _gdImageCreatePalette( $options->{x}, $options->{y} ); die "$sub: _gdImageCreatePalette() failed!\n" if( $self->{IMG_PTR} == 0 ); } } elsif( defined( $options->{data} ) ) { # Create an image from the given image data: # Figure out what type of file it is: if( defined( $options->{type} ) && ( $options->{type} eq 'jpg' || $options->{type} eq 'png' || $options->{type} eq 'gif' || $options->{type} eq 'wbmp' || $options->{type} eq 'gd' || $options->{type} eq 'gd2' ) ) { $self->{input_type} = $options->{type}; } else { $self->{input_type} = _id_image_data( $options->{data} ) or die "$sub: Can't determine image type given data!\n"; } # Load the data: $self->{IMG_PTR} = _img_ptr_from_data( $options->{data}, $self->{input_type} ) or die "$sub: Can't load the input image data!\n"; } # Bless and return: # bless ($self, $class); return $self; } # End of new()... =head2 to_pdl When you're done playing with your GDImage and want a piddle back, use this function to return one. =cut sub to_pdl { my $self = shift; my $sub = _pkg_name( "to_pdl" ); my $x = $self->gdImageSX(); my $y = $self->gdImageSY(); if( $self->gdImageTrueColor() ) { my $pdl = zeroes(byte, $x, $y, 3); _gd_image_to_pdl_true( $pdl, $self->{IMG_PTR} ); return $pdl; } my $pdl = zeroes(byte, $x, $y); _gd_image_to_pdl( $pdl, $self->{IMG_PTR} ); return $pdl; } # End of to_pdl()... =head2 apply_lut( $lut(piddle) ) Does a $im->ColorAllocate() for and entire LUT piddle at once. The LUT piddle format is the same as for the general interface above. =cut sub apply_lut { my $self = shift; my $lut = shift; # Let the PDL threading engine sort this out: $self->ColorAllocates( $lut->slice("(0),:"), $lut->slice("(1),:"), $lut->slice("(2),:") ); } # End of apply_lut()... sub DESTROY { my $self = shift; my $sub = _pkg_name( "DESTROY" ); #print STDERR sprintf("$sub: destroying gdImagePtr: 0x%p (%d) (%ld) (%lld)!\n", $self->{IMG_PTR}, $self->{IMG_PTR},$self->{IMG_PTR},$self->{IMG_PTR}); if( defined( $self->{IMG_PTR} ) ) { _gdImageDestroy( $self->{IMG_PTR} ); delete( $self->{IMG_PTR} ); } } # End of DESTROY()... =head2 WARNING: All of the docs below this point are auto-generated (not to mention the actual code), so read with a grain of salt, and B check the main GD documentation about how that function works and what it does. =cut ENDPM generate_create_functions( <<'ENDCREATE' ); gdImagePtr gdImageCreateFromPng (FILE * fd); gdImagePtr gdImageCreateFromWBMP (FILE * inFile); gdImagePtr gdImageCreateFromJpeg (FILE * infile); gdImagePtr gdImageCreateFromGd (FILE * in); gdImagePtr gdImageCreateFromGd2 (FILE * in); gdImagePtr gdImageCreateFromXbm (FILE * in); gdImagePtr gdImageCreateFromGif (FILE * fd); gdImagePtr gdImageCreate (int sx, int sy); gdImagePtr gdImageCreatePalette (int sx, int sy); gdImagePtr gdImageCreateTrueColor (int sx, int sy); ENDCREATE generate_create_from_data_functions( <<'ENDCDATA' ); gdImagePtr gdImageCreateFromPngPtr (int size, void * data); gdImagePtr gdImageCreateFromWBMPPtr (int size, void * data); gdImagePtr gdImageCreateFromJpegPtr (int size, void * data); gdImagePtr gdImageCreateFromGdPtr (int size, void * data); gdImagePtr gdImageCreateFromGd2Ptr (int size, void * data); gdImagePtr gdImageCreateFromGifPtr (int size, void * data); ENDCDATA generate_write_functions( <<'ENDWRITE' ); void gdImagePng (gdImagePtr im, FILE * out); void gdImagePngEx (gdImagePtr im, FILE * out, int level); void gdImageWBMP (gdImagePtr image, int fg, FILE * out); void gdImageJpeg (gdImagePtr im, FILE * out, int quality); void gdImageGd (gdImagePtr im, FILE * out); void gdImageGd2 (gdImagePtr im, FILE * out, int cs, int fmt); void gdImageGif (gdImagePtr im, FILE * out); ENDWRITE generate_data_ptr_functions( <<'ENDDATAPTR' ); void *gdImagePngPtr (gdImagePtr im, int *size); void *gdImagePngPtrEx (gdImagePtr im, int *size, int level); void *gdImageWBMPPtr (gdImagePtr im, int *size, int fg); void *gdImageJpegPtr (gdImagePtr im, int *size, int quality); void *gdImageGdPtr (gdImagePtr im, int *size); void *gdImageGd2Ptr (gdImagePtr im, int cs, int fmt, int *size); ENDDATAPTR #void gdImageDestroy (gdImagePtr im); generate_member_functions( <<'ENDMEMBERS' ); void gdImageSetPixel (gdImagePtr im, int x, int y, int color); int gdImageGetPixel (gdImagePtr im, int x, int y); void gdImageAABlend (gdImagePtr im); void gdImageLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageDashedLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageFilledRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageSetClip(gdImagePtr im, int x1, int y1, int x2, int y2); void gdImageGetClip(gdImagePtr im, int *x1P, int *y1P, int *x2P, int *y2P); int gdImageBoundsSafe (gdImagePtr im, int x, int y); void gdImageChar (gdImagePtr im, gdFontPtr f, int x, int y, int c, int color); void gdImageCharUp (gdImagePtr im, gdFontPtr f, int x, int y, int c, int color); void gdImageString (gdImagePtr im, gdFontPtr f, int x, int y, unsigned char *s, int color); void gdImageStringUp (gdImagePtr im, gdFontPtr f, int x, int y, unsigned char *s, int color); void gdImageString16 (gdImagePtr im, gdFontPtr f, int x, int y, unsigned short *s, int color); void gdImageStringUp16 (gdImagePtr im, gdFontPtr f, int x, int y, unsigned short *s, int color); void gdImagePolygon (gdImagePtr im, gdPointPtr p, int n, int c); void gdImageFilledPolygon (gdImagePtr im, gdPointPtr p, int n, int c); int gdImageColorAllocate (gdImagePtr im, int r, int g, int b); int gdImageColorAllocateAlpha (gdImagePtr im, int r, int g, int b, int a); int gdImageColorClosest (gdImagePtr im, int r, int g, int b); int gdImageColorClosestAlpha (gdImagePtr im, int r, int g, int b, int a); int gdImageColorClosestHWB (gdImagePtr im, int r, int g, int b); int gdImageColorExact (gdImagePtr im, int r, int g, int b); int gdImageColorExactAlpha (gdImagePtr im, int r, int g, int b, int a); int gdImageColorResolve (gdImagePtr im, int r, int g, int b); int gdImageColorResolveAlpha (gdImagePtr im, int r, int g, int b, int a); void gdImageColorDeallocate (gdImagePtr im, int color); void gdImageTrueColorToPalette (gdImagePtr im, int ditherFlag, int colorsWanted); void gdImageColorTransparent (gdImagePtr im, int color); void gdImageFilledArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color, int style); void gdImageArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color); void gdImageFilledEllipse (gdImagePtr im, int cx, int cy, int w, int h, int color); void gdImageFillToBorder (gdImagePtr im, int x, int y, int border, int color); void gdImageFill (gdImagePtr im, int x, int y, int color); void gdImageCopyRotated (gdImagePtr dst, gdImagePtr src, double dstX, double dstY, int srcX, int srcY, int srcWidth, int srcHeight, int angle); void gdImageSetBrush (gdImagePtr im, gdImagePtr brush); void gdImageSetTile (gdImagePtr im, gdImagePtr tile); void gdImageSetAntiAliased (gdImagePtr im, int c); void gdImageSetAntiAliasedDontBlend (gdImagePtr im, int c, int dont_blend); void gdImageSetStyle (gdImagePtr im, int *style, int noOfPixels); void gdImageSetThickness (gdImagePtr im, int thickness); void gdImageInterlace (gdImagePtr im, int interlaceArg); void gdImageAlphaBlending (gdImagePtr im, int alphaBlendingArg); void gdImageSaveAlpha (gdImagePtr im, int saveAlphaArg); int gdImageTrueColor (gdImagePtr im); int gdImageColorsTotal (gdImagePtr im); int gdImageRed (gdImagePtr im, int c); int gdImageGreen (gdImagePtr im, int c); int gdImageBlue (gdImagePtr im, int c); int gdImageAlpha (gdImagePtr im, int c); int gdImageGetTransparent (gdImagePtr im); int gdImageGetInterlaced (gdImagePtr im); int gdImageSX (gdImagePtr im); int gdImageSY (gdImagePtr im); ENDMEMBERS #char* gdImageStringTTF (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string); #char* gdImageStringFT (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string); #ENDMEMBERS # Allow operation on these member function on piddles as well: #int gdImageGetPixel (gdImagePtr im, int x, int y); generate_pp_def_members( <<'ENDMEMBERS' ); int gdImageColorAllocate (gdImagePtr im, int r, int g, int b); int gdImageColorAllocateAlpha (gdImagePtr im, int r, int g, int b, int a); void gdImageSetPixel (gdImagePtr im, int x, int y, int color); void gdImageLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageDashedLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageFilledRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color); void gdImageFilledArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color, int style); void gdImageArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color); void gdImageFilledEllipse (gdImagePtr im, int cx, int cy, int w, int h, int color); ENDMEMBERS generate_class_functions( <<'ENDCLASS' ); void gdImageCopy (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int w, int h); void gdImageCopyMerge (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int w, int h, int pct); void gdImageCopyMergeGray (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int w, int h, int pct); void gdImageCopyResized (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int dstW, int dstH, int srcW, int srcH); void gdImageCopyResampled (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int dstW, int dstH, int srcW, int srcH); int gdImageCompare (gdImagePtr im1, gdImagePtr im2); void gdImagePaletteCopy (gdImagePtr dst, gdImagePtr src); ENDCLASS generate_general_functions( <<'ENDGENERAL' ); int gdAlphaBlend (int dest, int src); int gdTrueColor (int r, int g, int b); int gdTrueColorAlpha (int r, int g, int b, int a); void gdFree (void *m); gdFontPtr gdFontGetLarge ( ); gdFontPtr gdFontGetSmall ( ); gdFontPtr gdFontGetMediumBold ( ); gdFontPtr gdFontGetGiant ( ); gdFontPtr gdFontGetTiny ( ); ENDGENERAL # # Keep these in here for later: # my $unused_funcs = <<'ENDUNUSED'; # These have disappeared in later versions of GD: void gdFreeFontCache (); void gdImageEllipse (gdImagePtr im, int cx, int cy, int w, int h, int color); BGD_DECLARE(gdImagePtr) gdImageCreateFromGifPtr (int size, void *data); BGD_DECLARE(gdImagePtr) gdImageCreateFromGifCtx (gdIOCtxPtr in); void gdImagePngCtx (gdImagePtr im, gdIOCtx * out); void gdImagePngCtxEx (gdImagePtr im, gdIOCtx * out, int level); void gdImageWBMPCtx (gdImagePtr image, int fg, gdIOCtx * out); void gdImageJpegCtx (gdImagePtr im, gdIOCtx * out, int quality); void gdImagePngToSink (gdImagePtr im, gdSinkPtr out); gdIOCtx *gdNewFileCtx (FILE *); gdIOCtx *gdNewDynamicCtx (int, void *); gdIOCtx *gdNewSSCtx (gdSourcePtr in, gdSinkPtr out); void *gdDPExtractData (struct gdIOCtx *ctx, int *size); gdImagePtr gdImageCreateFromPngSource (gdSourcePtr in); gdImagePtr gdImageCreateFromGd2Part (FILE * in, int srcx, int srcy, int w, int h); char* gdImageStringFTEx (gdImage * im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string, gdFTStringExtraPtr strex); ENDUNUSED # Add functions that the code gen doesn't handle properly: # #char* gdImageStringTTF (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string); pp_addxs( <<"ENDXS" ); char* _gdImageStringTTF( im, brect, fg, fontlist, ptsize, angle, x, y, string ) gdImagePtr im int * brect int fg char * fontlist double ptsize double angle int x int y char * string CODE: int c_brect[8]; RETVAL = gdImageStringTTF ( im, c_brect, fg, fontlist, ptsize, angle, x, y, string ); brect = c_brect; OUTPUT: RETVAL brect ENDXS pp_addpm( { At => 'Bot' }, <<'ENDPM' ); =head2 StringTTF $image->StringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) Alias for gdImageStringTTF. =cut sub StringTTF { return gdImageStringTTF ( @_ ); } # End of StringTTF()... =head2 gdImageStringTTF $image->gdImageStringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) =cut sub gdImageStringTTF { my $self = shift; return _gdImageStringTTF ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringTTF()... ENDPM #char* gdImageStringFT (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string);= pp_addxs(<<"ENDXS"); char* _gdImageStringFT( im, brect, fg, fontlist, ptsize, angle, x, y, string ) gdImagePtr im int * brect int fg char * fontlist double ptsize double angle int x int y char * string CODE: int c_brect[8]; RETVAL = gdImageStringFT ( im, c_brect, fg, fontlist, ptsize, angle, x, y, string ); brect = c_brect; OUTPUT: RETVAL brect ENDXS pp_addpm({At => 'Bot'}, <<'ENDPM' ); =head2 StringFT $image->StringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) Alias for gdImageStringFT. =cut sub StringFT { return gdImageStringFT ( @_ ); } # End of StringFT()... =head2 gdImageStringFT $image->gdImageStringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) =cut sub gdImageStringFT { my $self = shift; return _gdImageStringFT ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringFT()... ENDPM # Add the final docs: # pp_addpm({At => 'Bot'}, <<'ENDPM'); =head1 AUTHOR Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut ENDPM pp_done(); exit(0); ######### # SUBS: # ######### use Data::Dumper; # # Member functions to create a new object (or populate it from data): # sub generate_create_functions { my @funcs = split( /\n/, shift ); my $sub = "generate_create_functions()"; foreach my $func ( @funcs ) { #print "$sub: Generating read function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; # If it wants a FILE*, we need to do something different in the XS code: if( $info->{ARGS}->{1}->{TYPE} =~ /FILE\s*\*/ ) { my $function_name = $info->{NAME}; my $return_type = $info->{RETURN_TYPE}; pp_addxs(<<"ENDXS"); $return_type _$function_name( char* filename ) CODE: FILE* file; file = fopen( filename, "rb"); RETVAL = $function_name( file ); fclose(file); OUTPUT: RETVAL ENDXS } # Otherwise, it should be pretty easy: else { add_basic_xs( $info, '_' ); } } } # End of generate_create_functions()... # # Member functions to create a new object from a data scalar: # # gdImagePtr gdImageCreateFromPngPtr (int size, void * data); # sub generate_create_from_data_functions { my @funcs = split( /\n/, shift ); my $sub = "generate_create_from_data_functions()"; foreach my $func ( @funcs ) { #print "$sub: Generating read function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; my $function_name = $info->{NAME}; my $return_type = $info->{RETURN_TYPE}; pp_addxs(<<"ENDXS"); $return_type _$function_name( imageData ) SV * imageData PREINIT: char* data; STRLEN len; CODE: data = SvPV( imageData, len ); RETVAL = $function_name( len, (void*)data ); OUTPUT: RETVAL ENDXS } } # End of generate_create_from_data_functions()... #void gdImagePng (gdImagePtr im, FILE * out); #void gdImageWBMP (gdImagePtr image, int fg, FILE * out); sub generate_write_functions { my @funcs = split( /\n/, shift ); my $sub = "generate_write_functions()"; foreach my $func ( @funcs ) { #print "$sub: Generating write function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; my $function_name = $info->{NAME}; my $return_type = $info->{RETURN_TYPE}; my @arg_names = (); my @call_args = (); my $arg_decl_string = ""; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { my $type = $info->{ARGS}->{$num}->{TYPE}; my $name = $info->{ARGS}->{$num}->{NAME}; if( $type =~ /FILE/ ) { push( @arg_names, "filename" ); push( @call_args, "file" ); $arg_decl_string.= "\t\tchar *\t\tfilename\n"; next; } push(@arg_names, $name ); push(@call_args, $name ); $arg_decl_string .= "\t\t$type\t\t$name\n"; } my $arg_list = join(", ", @arg_names); my $call_arg_list = join(", ", @call_args); pp_addxs(<<"ENDXS"); $return_type _$function_name ( $arg_list ) $arg_decl_string CODE: FILE* file; file = fopen( filename, "wb"); $function_name ( $call_arg_list ); fclose( file ); ENDXS # Add the OO code: # # Use template method here to avoid escaping everything: my $pmcode = <<'ENDPM'; =head2 INSERT_NAME_HERE $image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE ) =cut sub INSERT_NAME_HERE { my $self = shift; return INSERT_XS_FUNC_HERE ( $self->{IMG_PTR}, @_ ); } # End of INSERT_NAME_HERE()... ENDPM my $name = "write_" . $function_name; $name =~ s/gdimage//; $name =~ s/gdImage//; $pmcode =~ s/INSERT_NAME_HERE/$name/sg; $pmcode =~ s/INSERT_XS_FUNC_HERE/_$function_name/sg; my @arg_names2; my @doc_args; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { next if ( $info->{ARGS}->{$num}->{TYPE} eq 'gdImagePtr' ); if( $info->{ARGS}->{$num}->{TYPE} =~ /FILE/ ) { push( @arg_names2, "filename" ); push(@doc_args, "\$filename" ); next; } push(@arg_names2, $info->{ARGS}->{$num}->{NAME}); push(@doc_args, "\$" . $info->{ARGS}->{$num}->{NAME} ); } my $arg_list2 = join( ", ", @arg_names2 ); $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list2/sg; my $doc_arg_list = join( ", ", @doc_args ); $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg; pp_addpm( { At => 'Bot' }, $pmcode ); } } # End of generate_write_functions()... # # The functions allow you to get a pointer to a formatted region of memory # that contains image data in the specified format. This is useful, among # other things, because PerlQt has almost no other way to import any image # data from PDL! # #void *gdImageWBMPPtr (gdImagePtr im, int *size, int fg); #void *gdImageJpegPtr (gdImagePtr im, int *size, int quality); #void *gdImagePngPtr (gdImagePtr im, int *size); #void *gdImageGdPtr (gdImagePtr im, int *size); #void *gdImageGd2Ptr (gdImagePtr im, int cs, int fmt, int *size); #void *gdImagePngPtrEx (gdImagePtr im, int *size, int level); # sub generate_data_ptr_functions { my @funcs = split( /\n/, shift ); my $sub = "generate_data_ptr_functions()"; foreach my $func ( @funcs ) { #print "$sub: Generating data_ptr function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; #use Data::Dumper; #print Data::Dumper->Dump([$info], ['info']); my $function_name = $info->{NAME}; my $return_type = $info->{RETURN_TYPE}; my @arg_names = (); my @call_args = (); my $arg_decl_string = ""; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { my $type = $info->{ARGS}->{$num}->{TYPE}; my $name = $info->{ARGS}->{$num}->{NAME}; if( $name =~ /size/ ) { push( @call_args, "\&$name" ); next; } push(@arg_names, $name ); push(@call_args, $name ); $arg_decl_string .= "\t\t$type\t\t$name\n"; } my $arg_list = join(", ", @arg_names); my $call_arg_list = join(", ", @call_args); # Add the low level functions we'll need: # pp_addxs(<<"ENDXS"); SV * _$function_name( $arg_list ) $arg_decl_string CODE: char* imdata; int size; imdata = (char *)$function_name( $call_arg_list ); RETVAL = newSVpv( imdata, size ); gdFree( imdata ); OUTPUT: RETVAL ENDXS # Add the object code for this function: # # Use template method here to avoid escaping everything: my $pmcode = <<'ENDPM'; =head2 INSERT_NAME_HERE $image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE ) =cut sub INSERT_NAME_HERE { my $self = shift; return INSERT_XS_FUNC_HERE ( $self->{IMG_PTR}, @_ ); } # End of INSERT_NAME_HERE()... ENDPM my $format = $function_name; $format =~ s/gdImage//; $format =~ s/Ptr//; my $name = "get_$format" . "_data"; $pmcode =~ s/INSERT_NAME_HERE/$name/sg; $pmcode =~ s/INSERT_XS_FUNC_HERE/_$function_name/sg; my @arg_names2; my @doc_args; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { next if ( $info->{ARGS}->{$num}->{TYPE} eq 'gdImagePtr' ); next if ( $info->{ARGS}->{$num}->{NAME} eq 'size' ); push(@arg_names2, $info->{ARGS}->{$num}->{NAME}); push(@doc_args, "\$" . $info->{ARGS}->{$num}->{NAME} ); } my $arg_list2 = join( ", ", @arg_names2 ); $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list2/sg; my $doc_arg_list = join( ", ", @doc_args ); $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg; pp_addpm( { At => 'Bot' }, $pmcode ); } # foreach func... } # End of generate_data_ptr_functions()... # # Here, we also need to add PM code for the OO side: # sub generate_member_functions { my @funcs = split( /\n/, shift ); my $sub = "generate_member_functions()"; foreach my $func ( @funcs ) { #print "$sub: Generating member function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; # Add the XS portion of the code: my @macro_list = qw( gdImageSX gdImageSY gdImageTrueColor ); if( scalar( grep( /$info->{NAME}/, @macro_list ) ) ) { # Special functions that are actually definitions: add_basic_def_xs( $info, '_' ); } else { # Normal function add_basic_xs( $info, '_' ); } # Add the OO code: # Use template method here to avoid escaping everything: my $pmcode = <<'ENDPM'; INSERT_SHORT_CODE_HERE =head2 INSERT_NAME_HERE $image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE ) =cut sub INSERT_NAME_HERE { my $self = shift; return INSERT_XS_FUNC_HERE ( $self->{IMG_PTR}, @_ ); } # End of INSERT_NAME_HERE()... ENDPM my $short_code_template = <<'ENDSHORTCODE'; =head2 INSERT_SHORT_NAME_HERE $image->INSERT_SHORT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE ) Alias for INSERT_NAME_HERE. =cut sub INSERT_SHORT_NAME_HERE { return INSERT_NAME_HERE ( @_ ); } # End of INSERT_SHORT_NAME_HERE()... ENDSHORTCODE my $name = $info->{NAME}; my $short_name = $name; $short_name =~ s/gdImage//; my $short_code = ''; if( $short_name ne $name ) { $short_code = $short_code_template; $short_code =~ s/INSERT_SHORT_NAME_HERE/$short_name/sg; } $pmcode =~ s/INSERT_SHORT_CODE_HERE/$short_code/sg; $pmcode =~ s/INSERT_NAME_HERE/$name/sg; $pmcode =~ s/INSERT_XS_FUNC_HERE/_$name/sg; my @arg_names; my @doc_args; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { next if ( $info->{ARGS}->{$num}->{TYPE} eq 'gdImagePtr' ); push(@arg_names, $info->{ARGS}->{$num}->{NAME}); push( @doc_args, "\$" . $info->{ARGS}->{$num}->{NAME} ); } my $arg_list = join( ", ", @arg_names ); $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list/sg; my $doc_arg_list = join( ", ", @doc_args ); $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg; pp_addpm( { At => 'Bot' }, $pmcode ); } } # End of generate_member_functions()... # # Add some member functions that can function on piddles: # sub generate_pp_def_members { my @funcs = split( /\n/, shift ); my $sub = "generate_pp_def_members()"; foreach my $func ( @funcs ) { #print "$sub: Generating member function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; my $orig_name = $info->{NAME}; my $name = $orig_name . "s"; my $short_name = $name; $short_name =~ s/gdImage//; my $pdlpp_name = "_$name"; my @arg_names; my @doc_args; my $pdlpp_arg_list = ""; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { my $type = $info->{ARGS}->{$num}->{TYPE}; my $arg_name = $info->{ARGS}->{$num}->{NAME}; next if ( $type eq 'gdImagePtr' ); push(@arg_names, $arg_name ); push( @doc_args, "\$" . $arg_name . "(pdl)" ); $pdlpp_arg_list .= "$type $arg_name(); "; } my $arg_list = join( ", ", @arg_names ); my $doc_arg_list = join( ", ", @doc_args ); my $pdlpp_call_arg_list = "\$" . join( "(), \$", @arg_names ) . "()"; # Add the PDL::PP code: # pp_def( $pdlpp_name, Pars => $pdlpp_arg_list, OtherPars => 'IV img_ptr;', Doc => undef, Code => "$orig_name( INT2PTR(gdImagePtr, \$COMP(img_ptr)), $pdlpp_call_arg_list );" ); # Add the OO code: # Use template method here to avoid escaping everything: my $pmcode = <<'ENDPM'; INSERT_SHORT_CODE_HERE =head2 INSERT_NAME_HERE $image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE ) =cut sub INSERT_NAME_HERE { my $self = shift; return INSERT_PP_FUNC_HERE ( @_, $self->{IMG_PTR} ); } # End of INSERT_NAME_HERE()... ENDPM my $short_code_template = <<'ENDSHORTCODE'; =head2 INSERT_SHORT_NAME_HERE $image->INSERT_SHORT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE ) Alias for INSERT_NAME_HERE. =cut sub INSERT_SHORT_NAME_HERE { return INSERT_NAME_HERE ( @_ ); } # End of INSERT_SHORT_NAME_HERE()... ENDSHORTCODE my $short_code = ''; if( $short_name ne $name ) { $short_code = $short_code_template; $short_code =~ s/INSERT_SHORT_NAME_HERE/$short_name/sg; } $pmcode =~ s/INSERT_SHORT_CODE_HERE/$short_code/sg; $pmcode =~ s/INSERT_NAME_HERE/$name/sg; $pmcode =~ s/INSERT_PP_FUNC_HERE/$pdlpp_name/sg; $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list/sg; $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg; pp_addpm( { At => 'Bot' }, $pmcode ); } } # End of generate_pp_def_members... # # Functions not specific to one object, but that need to take objects as arguments: # sub generate_class_functions { my @funcs = split( /\n/, shift ); my $sub = "generate_class_functions()"; pp_addpm( {At => 'Bot'}, <<'ENDPM' ); =head1 CLASS FUNCTIONS =cut ENDPM foreach my $func ( @funcs ) { #print "$sub: Generating class function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; # Add the XS portion of the code: add_basic_xs( $info, '_' ); # Add the Class functions code: # Figure out the perl arg list where it needs PDL::IO::GDImage objects: # my @perl_arg_names; my @arg_names; my @doc_args; my $arg_shift_string = ""; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { my $type = $info->{ARGS}->{$num}->{TYPE}; my $name = $info->{ARGS}->{$num}->{NAME}; push(@arg_names, $name); $arg_shift_string .= " my \$$name = shift;\n"; if ( $type eq 'gdImagePtr' ) { push(@perl_arg_names, "\$" . $name . "->{IMG_PTR}" ); push(@doc_args, "\$" . $name . "(PDL::IO::GD)" ); next; } push(@doc_args, "\$" . $name); push(@perl_arg_names, "\$" . $name); } # Use template method here to avoid escaping everything: my $pmcode = <<'ENDPM'; =head2 INSERT_NAME_HERE INSERT_NAME_HERE ( INSERT_DOC_ARG_LIST_HERE ) =cut sub INSERT_NAME_HERE { INSERT_ARG_SHIFT_HERE return INSERT_XS_FUNC_HERE ( INSERT_PERL_ARG_LIST_HERE ); } # End of INSERT_NAME_HERE()... ENDPM my $function_name = $info->{NAME}; $pmcode =~ s/INSERT_NAME_HERE/$function_name/sg; $pmcode =~ s/INSERT_XS_FUNC_HERE/_$function_name/sg; $pmcode =~ s/INSERT_ARG_SHIFT_HERE/$arg_shift_string/sg; my $perl_arg_list = join(", ", @perl_arg_names); $pmcode =~ s/INSERT_PERL_ARG_LIST_HERE/$perl_arg_list/sg; my $doc_arg_list = join( ", ", @doc_args ); $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg; pp_addpm( { At => 'Bot' }, $pmcode ); } } # End of generate_class_functions()... # # These functions are not specific to and object instance: # sub generate_general_functions { my @funcs = split( /\n/, shift ); my $sub = "generate_general_functions()"; foreach my $func ( @funcs ) { #print "$sub: Generating general function for $func...\n"; my $info = parse_prototype( $func ) or die "$sub: Couldn't parse prototype!\n"; # Add the XS portion of the code: my @macro_list = qw( gdTrueColor gdTrueColorAlpha ); if( scalar( grep( /$info->{NAME}/, @macro_list ) ) ) { # Special functions that are actually definitions: add_basic_def_xs( $info ); } else { # Normal function add_basic_xs( $info ); } pp_add_exported(" $info->{NAME} "); } } # End of generate_general_functions()... sub add_basic_xs { my $info = shift; my $prefix = shift || ''; my $return_type = $info->{RETURN_TYPE}; my $orig_name = $info->{NAME}; my $name = $prefix . $orig_name; my @arg_names; my @arg_call_names; my @out_arg_names; my $arg_decl_string = ""; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { my $name = $info->{ARGS}->{$num}->{NAME}; my $type = $info->{ARGS}->{$num}->{TYPE}; # Handle perl's handling of pointers: my $call_name = $name; if( $type =~ /((\S+\s*?)+)\s*\*/ && $type !~ /void/ && $type !~ /char/ ) { $type = $1; $call_name = "&$name"; push( @out_arg_names, $name ); } push(@arg_names, $name ); push(@arg_call_names, $call_name ); $arg_decl_string .= "\t\t$type\t\t$name\n"; } chomp( $arg_decl_string ); my $arg_string = join(", ", @arg_names ); my $arg_call_string = join(", ", @arg_call_names); my $retval_output = "\t\tRETVAL\n"; my $retval_input = "RETVAL ="; if( $return_type =~ /void/ ) { $retval_output = ''; $retval_input = ''; } my $arg_output_string = $retval_output . "\t\t" . join("\n\t\t", @out_arg_names); pp_addxs( <<"ENDXS" ); $return_type $name( $arg_string ) $arg_decl_string \tCODE: \t\t$retval_input $orig_name ( $arg_call_string ); \tOUTPUT: $arg_output_string ENDXS } # End of add_basic_xs()... sub add_basic_def_xs { my $info = shift; my $prefix = shift || ''; my $return_type = $info->{RETURN_TYPE}; my $orig_name = $info->{NAME}; my $name = $prefix . $orig_name; my @arg_names; my $arg_decl_string = ""; foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } ) { my $name = $info->{ARGS}->{$num}->{NAME}; my $type = $info->{ARGS}->{$num}->{TYPE}; push(@arg_names, $name ); $arg_decl_string .= "\t\t$type\t\t$name\n"; } chomp( $arg_decl_string ); my $arg_string = join(", ", @arg_names ); pp_addxs( <<"ENDXS" ); $return_type $name( $arg_string ) $arg_decl_string \tCODE: \t\tRETVAL = $orig_name ( $arg_string ); \tOUTPUT: \t\tRETVAL ENDXS } # End of add_basic_def_xs()... sub parse_prototype { my $proto = shift; return undef unless( $proto =~ /(\w+\s*\*?)\s*(\w+)\s*\((.*)\)/ ); my $args = $3; my $hash = { RETURN_TYPE => $1, NAME => $2, }; # Figure out the args: my $arg_count = 1; foreach my $arg ( split (/,/, $args) ) { my ($name) = ($arg =~ /(\w+)$/); $arg =~ s/$name$//; # arg now contains the full C type $arg =~ s/const //; # get rid of 'const' in C type $arg =~ s/^\s+//; $arg =~ s/\s+$//; # pare off the variable type from 'arg' $hash->{ARGS}->{$arg_count} = { NAME => $name, TYPE => $arg, }; $arg_count++; } #use Data::Dumper; #my $dd = Data::Dumper->new( [$hash], [ 'hash' ] ); #$dd->Indent(1); #print STDERR $dd->Dump(); return $hash; } # End of parse_prototype()... PDL-2.018/IO/GD/Makefile.PL0000644060175006010010000000634412562522364013165 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; my ($include_path, $lib_path, $linkname); my $ppfile = "GD.pd"; my $package_name = "PDL::IO::GD"; my $lib_name = "GD"; my @find_libs = ( 'libgd.so', 'libgd.a', 'libgd.dll.a', 'bgd.dll' ); my @find_incs = ( 'gd.h' ); my $config_flag = 'WITH_GD'; my $config_libs = 'GD_LIBS'; my $config_incs = 'GD_INC'; my @lib_locations = ( '/usr/lib64', '/usr/local/lib64', '/lib64', '/usr/lib', '/usr/local/lib', '/lib', split(/ /, $Config{libpth}), ); my @inc_locations = ( '/usr/include', '/usr/local/include', $Config{usrinc}, ); my $msg = ""; my $forcebuild=0; if (defined $PDL::Config{$config_flag} && $PDL::Config{$config_flag}==0) { $msg = "\n Will skip build of $package_name on this system \n"; goto skip; } if (defined $PDL::Config{$config_flag} && $PDL::Config{$config_flag}==1) { print "\n Will forcibly try and build $package_name on this system \n\n"; $forcebuild=1; } # Look for GD includes/libs # get locations from perldl.conf, if specified there: @lib_locations = @{$PDL::Config{$config_libs}} if( defined $PDL::Config{$config_libs} ); @inc_locations = @{$PDL::Config{$config_incs}} if( defined $PDL::Config{$config_incs} ); # # Do the search: # # Look for the libs: foreach my $libdir ( @lib_locations ) { my $found = 0; foreach my $find_lib ( @find_libs ) { if ( -e "$libdir/$find_lib" ) { $lib_path = $libdir; $found = 1; # The lib name is different on windows, so we need to adjust the LIBS, below: $linkname = ( $find_lib =~ /bgd.dll$/ ) ? 'bgd' : 'gd'; } last if $found; } last if $found; } # foreach $libdir... unless( defined( $lib_path ) ) { $msg .= "Cannot find $lib_name library, (@find_libs).\n" . "Please add the correct library path to Makefile.PL or install $lib_name\n."; } # Look for the include files: foreach my $incdir ( @inc_locations ) { foreach my $find_inc ( @find_incs ) { if ( -e "$incdir/$find_inc" ) { $include_path = $incdir; last; } } } unless( defined( $include_path ) ) { $msg .= "Cannot find $lib_name header files, (@find_incs).\n" . "Please add the correct library path to Makefile.PL or install $lib_name.\n"; } # # Make sure everything we wanted is found: # my $donot = 1; if( defined( $include_path ) && defined( $lib_path ) ) { $donot = 0; } $donot = 0 if( $forcebuild ); if ( $donot ) { $msg .= "\n Skipping build of $package_name.\n"; } skip: if ($msg ne "" && $forcebuild==0) { write_dummy_make( $msg ); $donot = 1; $PDL::Config{$config_flag}=0; } else { $PDL::Config{$config_flag}=1; print "\n Building $package_name. Turn off $config_flag if there are any problems\n\n"; } return if $donot; my $package = [$ppfile, $lib_name, $package_name]; my %hash = pdlpp_stdargs($package); $hash{VERSION_FROM} = $ppfile; $hash{DEFINE} = $PDL::Config{GD_DEFINE}; $hash{LIBS} = ["-L$lib_path -l$linkname"]; $hash{INC} = PDL_INCLUDE() . " -I$include_path"; push( @{ $hash{TYPEMAPS} }, 'typemap' ); undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int( $package ); }; WriteMakefile(%hash); PDL-2.018/IO/GD/TODO0000644060175006010010000000030412562522364011671 0ustar chmNone PDL::IO::GD TODO: Documentation Jpeg/etc.. input/output functions (autogenerate?) Read true color images... Decide whether that OO interface I was going to mess with is worth leaving in therePDL-2.018/IO/GD/typemap0000644060175006010010000000027512562522364012612 0ustar chmNone# # Extra type mappings for Judd::PDL::IO::GD # gdImagePtr T_PTR gdImage * T_PTR gdFontPtr T_PTR gdFont * T_PTR gdPointPtr T_PTR int * T_PTR unsigned short * T_PTR PDL-2.018/IO/HDF/0000755060175006010010000000000013110402046011273 5ustar chmNonePDL-2.018/IO/HDF/buildfunc.pm0000644060175006010010000000635613036512175013632 0ustar chmNone#package; use strict; # This file contains functions to build .pd from the HDF prototypes # Define a low-level perl interface to HDF from these definitions. sub create_low_level { # This file must be modified to only include # netCDF 3 function definitions. # Also, all C function declarations must be on one line. my $defn = shift; my $sub = "create_low_level()"; my @lines = split (/\n/, $defn); foreach my $line (@lines) { next if ( $line =~ /^\#/ ); # Skip commented out lines next if ( $line =~ /^\s*$/ ); # Skip blank lines unless ($line =~ /^(\w+\**)\s+(\w+)\((.+)\)(\+*\d*)\;/) { die "$sub: Can't parse this line!\n"; } my ($return_type, $func_name, $params, $add) = ($1, $2, $3, $4); my @vars; my @types; my $output = {}; foreach my $param ( split (/,/, $params) ) { my ($varname) = ($param =~ /(\w+)$/); $param =~ s/$varname//; # parm now contains the full C type $output->{$varname} = 1 if (($param =~ /\*/) && ($param !~ /const/)); $param =~ s/const //; # get rid of 'const' in C type $param =~ s/^\s+//; $param =~ s/\s+$//; # pare off the variable type from 'parm' push (@vars, $varname); push (@types, $param); } # Create the XS header: my $xsout = ''; $xsout .= "$return_type\n"; $xsout .= "_$func_name (" . join (", ", @vars) . ")\n"; # Add in the variable declarations: foreach my $i ( 0 .. $#vars ) { $xsout .= "\t$types[$i]\t$vars[$i]\n"; } # Add the CODE section: $xsout .= "CODE:\n"; $xsout .= "\tRETVAL = "; $xsout .= "$add + " if defined($add); $xsout .= "$func_name ("; # Add more variable stuff: foreach my $i ( 0 .. $#vars ) { my $type = $types[$i]; if ($type =~ /PDL/) { $type =~ s/PDL//; # Get rid of PDL type when writing xs CODE section $xsout .= "($type)$vars[$i]"."->data,"; } else { $xsout .= "$vars[$i],"; } } chop ($xsout); # remove last comma $xsout .= ");\n"; # Add the OUTPUT section: $xsout .= "OUTPUT:\n"; $xsout .= "\tRETVAL\n"; foreach my $var ( sort keys %$output ) { $xsout .= "\t$var\n"; } $xsout .= "\n\n"; # Add it to the PDL::PP file: pp_addxs ('', $xsout); } } # End of create_low_level()... sub create_generic { my $defn = shift; my @alltype = ('char', 'unsigned char', 'short int', 'unsigned short int', 'long int', 'unsigned long int', 'float', 'double'); my @nametype = ('char', 'uchar', 'short', 'ushort', 'long', 'ulong', 'float', 'double'); foreach my $i ( 0 .. $#alltype ) { my $xsout = $defn; $xsout =~ s/GENERIC/$alltype[$i]/eg; $xsout =~ s/NAME/$nametype[$i]/eg; pp_addxs ('', $xsout); } } # End of create_generic()... 1; PDL-2.018/IO/HDF/Changes0000644060175006010010000001043712562522364012613 0ustar chmNoneRevision history for Perl extension PDL::HDF 0.01 13/02/01 - original version 2.0 27 March 2006 (Judd Taylor, judd@marine.usf.edu) - New version I've taken over from the previous authors. - There has been several minor fixes to the old version that I have fixed over the years, and I can't remember them all to document here. Any new functionality has been documented, however. - "Chunking" functionality added. This is an internal tiling and compression on the SD datasets done by the HDF library. This is on by default, and can be inquired/changed through ->Chunking() member function (pass it 0 for off, true for on). The actual chunking section automatically determines a tile size for the dataset, but this may not be optimal for some datasets. Down the road I'll provide better control of this feature. - I've defuncted several functions that had strange (perhaps French) spellings. The originals are still there for the time being, but a future version will come with warnings, and finally be removed from the library even further out. SDgetvariablename -> SDgetvariablenames SDgetattribut -> SDgetattribute SDgetattributname -> SDgetattributenames SDgetdimsizeunlimit -> SDgetunlimiteddimsize SDgetdimname -> SDgetdimnames Vgetchilds -> Vgetchildren VSgetfieldsnames -> VSgetfieldnames - Umm... I don't like fortran array dim order, so I use C order. This may be a concern for you, but I can't verify the problem for everyone since all of my code works fine. I generally save things as X, Y, Z in my code (think an image, for instance), and then when I open the HDF with image viewers, everything is fine. That's not how HDF saves the data, however, so there's a dim reverse in the code for SDget and SDput, but that should (theoretically) be transparent to you. NOTE: there is no reformatting of memory necessary (it's time consuming, and has been avoided), since the C style dim order is how a linear array maps into memory anyways (that's the main reason I like C style over fortran). If this causes _huge_ problems for you, then maybe I can make the ordering optional and you can have it your backwards way if you want :) - I migrated all of the failure codes to return 'undef' instead of the mix they were returning before. This should allow old code to be left alone. - I migrated all of the perl hashes to anonymous hashes. - I removed and internally doc'd several places where buffer overflows are possible, and did my best shot at making the buffer overflows impossible, using the new constants below. NOTE: this is not total elimination of the problem! Look for that in a later version with updates perlXS code on those function to use the C constants. The constants used in the code are cool with the HDF4.2r1 version, assuming you didn't change anything before you compiled the HDF library. The HDF people could theoretically change those values at a later point, so they should be read directly from the HDF system headers, rather than hard coded in this module. - I moved the constants over to 'use constant', so instead of using '$PDL::IO::HDF:DFACC_CREATE', you now would use : 'PDL::IO::HDF->DFACC_CREATE'. This is how constants work in Perl, so get over it and fix your old code that uses things the old way. - I added a couple of constants (all only usefull for allocating memory internally): MAX_NC_NAME => HDF's constant to hold the max name length for an attr/sds/dim MAX_VAR_DIMS => HDF's constant to hold the max number of dims for a HDF variable VNAMELENMAX => HDF's constant for the max length of VS interface names FAIL => HDF's constant failure return code - I moved all of the tests over to 'use Test', for easier clarity and to get them working again. I also modified the tests to clean up their test files when they are no longer needed (some tests use outputs from earlier tests). - I added tests for the SDS chunking features. PDL-2.018/IO/HDF/HDF.pm0000644060175006010010000001307113036512175012250 0ustar chmNonepackage PDL::IO::HDF; =head1 NAME PDL::IO::HDF - A PDL interface to the HDF4 library. =head1 SYNOPSIS use PDL; use PDL::IO::HDF; # Open file 'foo.hdf' with all hdf interface: my $HDF = PDL::IO::HDF->new("foo.hdf"); # You can call functions from either the SD or VS interfaces: $HDF->{SD}->SDget("Foo_data"); $HDF->{VS}->VSgetnames(); # To close the file: $HDF->close(); =head1 DESCRIPTION This library provides functions to manipulate HDF files with the SD, VS, and V HDF interfaces. For more information on HDF, see http://hdf.ncsa.uiuc.edu/ The 'new' function of this package uses the 'new' functions for the individual HDF interfaces. This allows you to use all of the interfaces at one time (if you don't mind the extended syntax). Actually using the HDF files comes down to using one of the particular interfaces, for that see the docs on those modules. =cut our $VERSION = '2.0'; $VERSION = eval $VERSION; use PDL::Primitive; use PDL::Basic; use PDL::IO::HDF::SD; use PDL::IO::HDF::VS; # # Constants: # =head1 CONSTANTS These constants are now implented using the perl 'use constant' pragma. Previously, they were just scalars that were changeable (which is a no-no). See constant(1) for more info on how to use these in your code. =head2 Access Modes =over 8 =item DFACC_READ Open the file in read-only mode. =item DFACC_WRITE Open the file in write-only mode. =item DFACC_CREATE Clobber the file (create it if it doesn't exist, and then open with RW mode). =item DFACC_ALL Open the file in read-write mode. =item DFACC_RDONLY Same as DFACC_READ =item DFACC_RDWR Open the file in read-write mode. =back =cut # Access modes: use constant { DFACC_READ => 1, DFACC_WRITE => 2, DFACC_CREATE => 4, DFACC_ALL => 7, DFACC_RDONLY => 1, DFACC_RDWR => 3, }; =head2 VS Interface Interlacing Modes =over 8 =item FULL_INTERLACE =item NO_INTERLACE =back =cut # VS interlace modes: use constant { FULL_INTERLACE => 0, NO_INTERLACE => 1, }; =head2 HDF4 Data Type Codes: =over 8 =item DFNT_UCHAR HDF's unsigned char ~= PDL's byte =item DFNT_CHAR HDF's char ~= PDL's byte =item DFNT_FLOAT32 HDF's 32-bit float ~= PDL's float =item DFNT_FLOAT64 HDF's 64-bit float ~= PDL's double =item DFNT_INT8 HDF's 8-bit integer ~= PDL's byte =item DFNT_UINT8 HDF's 8-bit unsigned integer ~= PDL's byte =item DFNT_INT16 HDF's 16-bit integer ~= PDL's short =item DFNT_UINT16 HDF's 16-bit unsigned integer ~= PDL's ushort =item DFNT_INT32 HDF's 32-bit integer ~= PDL's long =item DFNT_INT64 HDF's 32-bit integer ~= PDL's long =back =cut # HDF Data type numbers: use constant { DFNT_UCHAR => 3, DFNT_CHAR => 4, DFNT_FLOAT32 => 5, DFNT_FLOAT64 => 6, DFNT_INT8 => 20, DFNT_UINT8 => 21, DFNT_INT16 => 22, DFNT_UINT16 => 23, DFNT_INT32 => 24, DFNT_INT64 => 25, }; =head2 Misc. HDF Library Constants: =over 8 =item MAX_NC_NAME This is the max name length for SDS variables, attribtues, and just about anything else. =item MAX_VAR_DIMS This is the max number of dims a HDF variable can have. =item VNAMELENMAX Max length of V interface names. =back =cut # These are current with HDF4.2r1: # # Maximum Attr/SDS/VS name length: use constant MAX_NC_NAME => 256; # Maximum variable dims (use for alloc'ing mem for the low level calls that return dims: use constant MAX_VAR_DIMS => 32; # Max name len for VS interface: use constant VNAMELENMAX => 64; use constant FAIL => -1; # Declaration of the different 'typemap' globals # NOTE: Since the keys & values below are constants, we need the () around them: #typemap pour convertir typePDL->typeHDF $SDtypeTMAP = { PDL::byte->[0] => (DFNT_UINT8), PDL::short->[0] => (DFNT_INT16), PDL::ushort->[0] => (DFNT_UINT16), PDL::long->[0] => (DFNT_INT32), PDL::float->[0] => (DFNT_FLOAT32), PDL::double->[0] => (DFNT_FLOAT64), #PDL::byte->[0] => $DFNT_UCHAR ###attention PDL::byte 2x }; #typemap pour convertir typeHDF->typePDL $SDinvtypeTMAP = { (DFNT_INT8) => sub { PDL::byte(@_); }, #badtype (DFNT_UINT8) => sub { PDL::byte(@_); }, (DFNT_INT16) => sub { PDL::short(@_); }, (DFNT_UINT16) => sub { PDL::ushort(@_); }, (DFNT_INT32) => sub { PDL::long(@_); }, (DFNT_INT64) => sub { PDL::long(@_); }, #badtype (DFNT_FLOAT32) => sub { PDL::float(@_); }, (DFNT_FLOAT64) => sub { PDL::double(@_); }, (DFNT_UCHAR) => sub { PDL::byte(@_); }, (DFNT_CHAR) => sub { PDL::byte(@_); } #badtype }; $SDinvtypeTMAP2 = { (DFNT_INT8) => PDL::byte, (DFNT_UINT8) => PDL::byte, (DFNT_INT16) => PDL::short, (DFNT_UINT16) => PDL::ushort, (DFNT_INT32) => PDL::long, (DFNT_INT64) => PDL::long, (DFNT_FLOAT32) => PDL::float, (DFNT_FLOAT64) => PDL::double, (DFNT_UCHAR) => PDL::byte, (DFNT_CHAR) => PDL::byte, }; sub new { my $type = shift; my $file = shift; my $obj = {}; $obj->{SD} = PDL::IO::HDF::SD->new( $file ); $obj->{VS} = PDL::IO::HDF::VS->new( $file ); bless $obj, $type; } # End of new()... sub close { my $self = shift; $self->{SD}->close; $self->{VS}->close; } # End of close()... sub DESTROY { my $self = shift; $self->close; } # End of DESTROY()... =head1 CURRENT AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 PREVIOUS AUTHORS Patrick Leilde patrick.leilde@ifremer.fr contribs of Olivier Archer olivier.archer@ifremer.fr =head1 SEE ALSO perl(1), PDL(1), PDL::IO::HDF::SD(1), PDL::IO::HDF::VS(1), constant(1). =cut PDL-2.018/IO/HDF/Makefile.PL0000644060175006010010000001114513036512175013263 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; our ($hdf_include_path, $hdf_lib_path, $hdf_libs, $szip); my $msg = ""; my $forcebuild=0; # Note: forcebuild not used if (defined $PDL::Config{WITH_HDF} && $PDL::Config{WITH_HDF}==0) { $msg = "\n Will skip build of PDL::IO::HDF on this system \n"; goto skip; } if (defined $PDL::Config{WITH_HDF} && $PDL::Config{WITH_HDF}==1) { print "\n Will forcibly try and build PDL::IO::HDF on this system \n\n"; $forcebuild=1; } # Look for HDF4 includes/libs # default locations: my @HDF_lib_locations = ( '/usr/lib64', '/usr/local/netcdf/lib', '/usr/local/lib', '/usr/local/lib64', '/usr/lib64/hdf', '/opt/local/lib', '/usr/lib', '/usr/lib/hdf', '/opt/lib', split(/ /, $Config{libpth}), ); my @HDF_inc_locations = ( '/usr/local/include', '/usr/local/netcdf/include', '/opt/local/include', '/usr/include', '/usr/include/hdf', '/opt/include', $Config{usrinc}, ); # get locations from perldl.conf, if specified there: @HDF_lib_locations = @{$PDL::Config{HDF_LIBS}} if( defined $PDL::Config{HDF_LIBS} ); @HDF_inc_locations = @{$PDL::Config{HDF_INC}} if( defined $PDL::Config{HDF_INC} ); # # Do the search: # my $found_df = 0; my $found_sz = 0; # Look for the libs: foreach my $libdir ( @HDF_lib_locations ) { if (-e "$libdir/libdfalt.a" && !$found_df) { $found_df = 1; $hdf_lib_path = $libdir; $hdf_libs = '-lmfhdfalt -ldfalt'; print "Found libdfalt.a at $libdir/libdfalt.a\n"; } if (-e "$libdir/libdf.a" && !$found_df) { $found_df = 1; $hdf_lib_path = $libdir; $hdf_libs = '-lmfhdf -ldf'; print "Found libdf.a at $libdir/libdf.a\n"; } if (-e "$libdir/libhdf.a" && !$found_df) { $found_df = 1; $hdf_lib_path = $libdir; $hdf_libs = '-lmfhdf -lhdf -lxdr'; print "Found libhdf.a at $libdir/libhdf.a\n"; } # Look for the szip library, which HDF >= 4.2r0 needs, but older versions don't! if (-e "$libdir/libsz.$Config{so}" && !$found_sz) { $found_sz = 1; print "Found libsz.$Config{so} at $libdir/libsz.$Config{so}\n"; } if (-e "$libdir/libsz$Config{lib_ext}" && !$found_sz) { $found_sz = 1; print "Found libsz.$Config{lib_ext} at $libdir/libsz.$Config{lib_ext}\n"; } } # foreach $libdir... unless( defined( $hdf_lib_path ) ) { $msg .= "Cannot find hdf library, libdf.a.\n" . "Please add the correct library path to Makefile.PL or install HDF\n"; } warn "Warning: Did not find libsz, necessary for HDF >= 4.2r0\n" unless $found_sz; $szip = $found_sz ? "-lsz" : ""; # Look for the include files: foreach my $incdir ( @HDF_inc_locations ) { if (-e "$incdir/hdf.h") { $hdf_include_path = ($incdir eq '/usr/local/include' ) ? "" : $incdir; print "Found hdf.h at $incdir/hdf.h\n"; last; } } unless( defined( $hdf_include_path ) ) { $msg .= "Cannot find hdf header file, hdf.h.\n" . "Please add the correct library path to Makefile.PL or install HDF\n"; } # Set up architecture dependent stuff: # NOTE TO SELF: The main PDL developers may not like this... my $cpu = `uname -m`; chomp $cpu; my $hdf_defs; if ($cpu eq 'x86_64') { $hdf_defs = "-DSWAP -DNDEBUG -DHDF -DBIG_LONGS -DIA64 " . "-D_BSD_SOURCE -DLINUX -DGCC32"; } elsif ($cpu eq 'i686') { $hdf_defs = "-DNDEBUG -D_BSD_SOURCE -DLINUX -DGCC32"; } else { print "WARNING: Unknown cpu type $cpu! Not setting \$hdf_defs. (This may not be a bad thing)\n"; } print "Final \$hdf_defs flags: \'$hdf_defs\'\n\n"; # Make sure everything we wanted is found: my $donot = 1; if( defined( $hdf_include_path ) && defined( $hdf_lib_path ) ) { $donot = 0; } if ( $donot ) { $msg .= "\n Skipping build of PDL::IO::HDF.\n"; } skip: if ($msg ne "" && $forcebuild==0) { write_dummy_make( $msg ); $donot = 1; $PDL::Config{WITH_HDF}=0; } else { $PDL::Config{WITH_HDF}=1; print "\n Building PDL::IO::HDF. Turn off WITH_HDF if there are any problems\n\n"; } return if $donot; WriteMakefile( NAME => 'PDL::IO::HDF', DEFINE => $hdf_defs, #OPTIMIZE => "$hdf_defs", VERSION_FROM => 'HDF.pm', TYPEMAPS => [ &PDL_TYPEMAP() ], PM => { 'HDF.pm' => '$(INST_LIBDIR)/HDF.pm', }, INC => &PDL_INCLUDE() . " -I$hdf_include_path", LIBS => [ "-L$hdf_lib_path $hdf_libs -ljpeg -lz $szip" ], dist => { COMPRESS => 'gzip', SUFFIX => 'gz', }, DIR => [ 'SD', 'VS' ], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/HDF/SD/0000755060175006010010000000000013110402046011601 5ustar chmNonePDL-2.018/IO/HDF/SD/Changes0000644060175006010010000000012012562522364013105 0ustar chmNoneRevision history for Perl extension PDL::HDF 0.01 13/02/01 - original version PDL-2.018/IO/HDF/SD/Makefile.PL0000644060175006010010000000141312562522364013572 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; my $package = [ qw(SD.pd SD PDL::IO::HDF::SD) ]; our ($hdf_include_path, $hdf_lib_path, $hdf_libs, $szip); undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int($package); }; WriteMakefile( NAME => 'PDL::IO::HDF::SD', TYPEMAPS => [ &PDL_TYPEMAP() ], OBJECT => 'SD.o ', PM => { 'SD.pm' => '$(INST_LIBDIR)/SD.pm', }, INC => &PDL_INCLUDE() . " -I$hdf_include_path", LIBS => [ "-L$hdf_lib_path $hdf_libs -ljpeg -lz $szip" ], clean => { FILES => 'SD.pm SD.xs SD.o SD.c', }, dist => { COMPRESS => 'gzip', SUFFIX => 'gz' }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/HDF/SD/MANIFEST0000644060175006010010000000003212562522364012745 0ustar chmNoneSD.pd Changes Makefile.PL PDL-2.018/IO/HDF/SD/SD.pd0000644060175006010010000012653413036512175012463 0ustar chmNonepp_addpm({At => Top}, <<'EOD'); =head1 NAME PDL::IO::HDF::SD - PDL interface to the HDF4 SD library. =head1 SYNOPSIS use PDL; use PDL::IO::HDF::SD; # # Creating and writing an HDF file # # Create an HDF file: my $hdf = PDL::IO::HDF::SD->new("-test.hdf"); # Define some data my $data = sequence(short, 500, 5); # Put data in file as 'myData' dataset with the names # of dimensions ('dim1' and 'dim2') $hdf->SDput("myData", $data , ['dim1','dim2']); # Put some local attributes in 'myData' # # Set the fill value to 0 my $res = $hdf->SDsetfillvalue("myData", 0); # Set the valid range from 0 to 2000 $res = $hdf->SDsetrange("myData", [0, 2000]); # Set the default calibration for 'myData' (scale factor = 1, other = 0) $res = $hdf->SDsetcal("myData"); # Set a global text attribute $res = $hdf->SDsettextattr('This is a global text test!!', "myGText" ); # Set a local text attribute for 'myData' $res = $hdf->SDsettextattr('This is a local text testl!!', "myLText", "myData" ); # Set a global value attribute (you can put all values you want) $res = $hdf->SDsetvalueattr( PDL::short( 20 ), "myGValue"); # Set a local value attribute (you can put all values you want) $res = $hdf->SDsetvalueattr( PDL::long( [20, 15, 36] ), "myLValues", "myData" ); # Close the file $hdf->close(); # # Reading from an HDF file: # # Open an HDF file in read only mode: my $hdf = PDL::IO::HDF::SD->new("test.hdf"); # Get a list of all datasets: my @dataset_list = $hdf->SDgetvariablename(); # Get a list of the names of all global attributes: my @globattr_list = $hdf->SDgetattributenames(); # Get a list of the names of all local attributes for a dataset: my @locattr_list = $hdf->SDgetattributenames("myData"); # Get the value of local attribute for a dataset: my $value = $hdf->SDgetattribut("myLText","myData"); # Get a PDL var of the entire dataset 'myData': my $data = $hdf->SDget("myData"); # Apply the scale factor of 'myData' $data *= $hdf->SDgetscalefactor("myData"); # Get the fill value and fill the PDL var in with BAD: $data->inplace->setvaltobad( $hdf->SDgetfillvalue("myData") ); # Get the valid range of a dataset: my @range = $hdf->SDgetrange("myData"); #Now you can do what you want with your data $hdf->close(); =head1 DESCRIPTION This library provides functions to read, write, and manipulate HDF4 files with HDF's SD interface. For more information on HDF4, see http://hdf.ncsa.uiuc.edu/ There have been a lot of changes starting with version 2.0, and these may affect your code. PLEASE see the 'Changes' file for a detailed description of what has been changed. If your code used to work with the circa 2002 version of this module, and does not work anymore, reading the 'Changes' is your best bet. In the documentation, the terms dataset and SDS (Scientific Data Set) are used interchangeably. =cut EOD pp_addhdr(<<'EOH'); #include #include #include #define PDLchar pdl #define PDLuchar pdl #define PDLshort pdl #define PDLint pdl #define PDLlong pdl #define PDLfloat pdl #define PDLdouble pdl #define PDLvoid pdl #define uchar unsigned char #define COMP_CODE_NONE 0 #define COMP_CODE_RLE 1 #define COMP_CODE_SKPHUFF 3 #define COMP_CODE_DEFLATE 4 EOH use FindBin; use lib "$FindBin::Bin/.."; use buildfunc; #------------------------------------------------------------------------- # Create low level interface from HDF SD header file. #------------------------------------------------------------------------- create_low_level (<<'EODEF'); # # SDS Interface # int SDstart(const char *filename, int access_mode); int SDfileinfo(int sd_id, int *ndatasets, int *global_attr); int SDattrinfo(int s_id, int attr_index, char *attr_name, int *number_type, int *count); #int SDreadattr(int s_id, int attr_index, void *data); int SDreadattr(int s_id, int attr_index, PDLvoid *data); int SDgetinfo(int sds_id, char *sds_name, int *rank, int *dimsizes, int *number_type, int *nattrs); int SDselect(int sd_id, int index); int SDgetdimid(int sds_id, int dim_number); int SDdiminfo(int dim_id, char *name, int *count, int *number_type, int *nattrs); int SDnametoindex(int sd_id, const char *sds_name); #int SDreaddata(int sds_id, int *start, int *stride, int *edge, void *buffer); int SDreaddata(int sds_id, int *start, int *stride, int *edge, PDLvoid *buffer); #int SDsetfillvalue(int sds_id, const void *fill_val); int SDsetfillvalue(int sds_id, const PDLvoid *fill_val); #int SDsetrange(int sds_id, const void *max, const void *min); int SDsetrange(int sds_id, const PDLvoid *max, const PDLvoid *min); #int SDwritedata(int sds_id, const int *start, const int *stride, const int *edge, const void *data); int SDwritedata(int sds_id, const int *start, const int *stride, const int *edge, const PDLvoid *data); int SDsetexternalfile(int sds_id, const char *filename, int offset); int SDsetdimstrs(int dim_id, const char *label, const char *unit, const char *format); int SDsetdimscale(int dim_id, int count, int number_type, const void *data); int SDsetdimname(int dim_id, const char *dim_name); int SDsetdatastrs(int sds_id, const char *label, const char *unit, const char *format, const char *coordsys); int SDsetcal(int sds_id, double cal, double cal_err, double offset, double offset_err, int number_type); #int SDsetcal(int sds_id, float cal, float cal_err, float offset, float offset_err, int number_type); int SDsetattr(int s_id, const char *attr_name, int num_type, int count, const void *values); int SDreftoindex(int sd_id, int sds_ref); int SDiscoordvar(int sds_id); int SDidtoref(int sds_id); int SDgetdimstrs(int dim_id, char *label, char *unit, char *format, int len); int SDgetdimscale(int dim_id, void *data); int SDgetdatastrs(int sds_id, char *label, char *unit, char *format, char *coordsys, int len); #ORIG: #int SDgetcal(int sds_id, double cal, double cal_err, double offset, double offset_err, double number_type); #int SDgetcal(int sds_id, float cal, float cal_err, float offset, float offset_err, int number_type); #int SDgetcal(int sds_id, double *cal, double *cal_err, float64 *offset, float64 *offset_err, int *number_type); int SDendaccess(int sds_id); int SDend(int sd_id); int SDcreate(int sd_id, const char *name, int number_type, int rank, const int *dimsizes); int SDwritechunk(int sds_id, const int* origin, const PDLvoid *data); int SDsetchunkcache(int sds_id, int maxcache, int flag); EODEF pp_addxs('',<<'ENDXS'); void _HEprint(int level) CODE: HEprint(stderr, level); int _SDgetcal(sds_id, cal, cal_err, offset, offset_err, number_type) int sds_id double cal double cal_err double offset double offset_err int* number_type CODE: RETVAL = SDgetcal(sds_id, &cal, &cal_err, &offset, &offset_err, number_type); OUTPUT: RETVAL void UnpackSBigEndianPDL(size, buff, p) int size unsigned char * buff PDLint * p CODE: int i, INTtmp; unsigned char bch1, bch2; int * data; data = p->data; for(i=0; i= 32768 ) { INTtmp -= 65536; } data[i] = INTtmp; } OUTPUT: p int _SDsetcompress(sd_id, ldef); int sd_id int ldef CODE: comp_info c_info; c_info.deflate.level = ldef; RETVAL = SDsetcompress(sd_id, COMP_CODE_DEFLATE, &c_info) + 1; OUTPUT: RETVAL int _SDsetchunk(sds_id, rank, chunk_lengths); int sds_id int rank int* chunk_lengths CODE: HDF_CHUNK_DEF c_def; int i; int32 status = FAIL; for(i = 0; i < rank; i++) { /* fprintf(stderr, "_SDsetchunk(): chunk_lengths[%d] = %d\n", i , chunk_lengths[i]); */ c_def.chunk_lengths[i] = chunk_lengths[i]; c_def.comp.chunk_lengths[i] = chunk_lengths[i]; } c_def.comp.comp_type = COMP_CODE_DEFLATE; c_def.comp.cinfo.deflate.level = 6; status = SDsetchunk(sds_id, c_def, (HDF_CHUNK | HDF_COMP) ); if( status == FAIL ) { fprintf(stderr, "_SDsetchunk(): return status = %d\n", status); HEprint(stderr, 0); } RETVAL = status; OUTPUT: RETVAL int _SDinitchunk(sds_id, type, rank, chunk_lengths); int sds_id int type int rank int* chunk_lengths CODE: void* data = NULL; int* origin = NULL; int i; size_t size; int status; origin = HDgetspace( sizeof( int ) * rank ); for( i = 0; i < rank; i++ ) origin[i] = 0; /* Just use the largest datatype here: */ size = DFKNTsize(type) * chunk_lengths[0]; if( rank > 1 ) { for( i = 1; i < rank; i++ ) size *= chunk_lengths[i]; } data = HDgetspace( size ); status = SDwritechunk(sds_id, origin, data); if( status == FAIL ) { fprintf(stderr, "_SDinitchunk(): return status = %d\n", status); HEprint(stderr, 0); } HDfreespace( data ); HDfreespace( origin ); RETVAL = status; OUTPUT: RETVAL int Hishdf(filename); char* filename CODE: RETVAL = Hishdf(filename); OUTPUT: RETVAL int _SDgetunlimiteddim(sds_id, dim); int sds_id int dim CODE: char sds_name[250]; int rank; int dimsizes[32]; int num_type; int nattrs; RETVAL = SDgetinfo(sds_id, sds_name, &rank, dimsizes, &num_type, &nattrs) + 1; if(RETVAL==1){RETVAL = dimsizes[dim];} OUTPUT: RETVAL int _SDsetattr_text(s_id, name, text, size); int s_id char * name char * text int size CODE: RETVAL = SDsetattr(s_id, name, 4, size, text); OUTPUT: RETVAL int _SDsetattr_values(s_id, name, values, size, type); int s_id char * name pdl * values int size int type CODE: RETVAL = SDsetattr(s_id, name, type, size, values->data); OUTPUT: RETVAL ENDXS pp_addpm(<<'EOPM'); use PDL::Primitive; use PDL::Basic; use PDL::IO::HDF; require POSIX; sub _pkg_name { return "PDL::IO::HDF::SD::" . shift() . "()"; } # Convert a byte to a char: sub Byte2Char { my ($strB) = @_; my $strC; for(my $i=0; $i<$strB->nelem; $i++) { $strC .= chr( $strB->at($i) ); } return($strC); } # End of Byte2Char()... =head1 CLASS METHODS =head2 new =for ref Open or create a new HDF object. =for usage Arguments: 1 : The name of the file. if you want to write to it, prepend the name with the '+' character : "+name.hdf" if you want to create it, prepend the name with the '-' character : "-name.hdf" otherwise the file will be open in read only mode Returns the hdf object (die on error) =for example my $hdf = PDL::IO::HDF::SD->new("file.hdf"); =cut sub new { # General: my $type = shift; my $filename = shift; my $sub = _pkg_name( 'new' ); my $debug = 0; my $self = {}; if (substr($filename, 0, 1) eq '+') { # open for writing $filename = substr ($filename, 1); # chop off + $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } if (substr($filename, 0, 1) eq '-') { # Create new file $filename = substr ($filename, 1); # chop off - print "$sub: Creating HDF File $filename\n" if $debug; $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE; $self->{SDID} = PDL::IO::HDF::SD::_SDstart( $filename, $self->{ACCESS_MODE} ); my $res = PDL::IO::HDF::SD::_SDend( $self->{SDID} ); die "$sub: _ERR::Create\n" if( ($self->{SDID} == PDL::IO::HDF->FAIL ) || ( $res == PDL::IO::HDF->FAIL )); $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } unless( defined( $self->{ACCESS_MODE} ) ) { # Default to Read-only access: $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ; } $self->{FILE_NAME} = $filename; # SD interface: print "$sub: Loading HDF File $self->{FILE_NAME}\n" if $debug; $self->{SDID} = PDL::IO::HDF::SD::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} ); die "$sub: _ERR::SDstart\n" if( $self->{SDID} == PDL::IO::HDF->FAIL ); my $num_datasets = -999; my $num_global_attrs = -999; my $res = _SDfileinfo( $self->{SDID}, $num_datasets, $num_global_attrs ); die "$sub: ** sdFileInfo **\n" if($res == PDL::IO::HDF->FAIL); foreach my $i ( 0 .. $num_global_attrs-1 ) { print "$sub: Loading Global Attribute #$i\n" if $debug; my $attrname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $type = 0; my $count = 0; $res = _SDattrinfo( $self->{SDID}, $i, $attrname, $type, $count ); die "$sub: ** sdAttrInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$attrname = \'$attrname\'\n" if $debug; $self->{GLOBATTR}->{$attrname} = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$type}, $count ); $res = _SDreadattr( $self->{SDID}, $i, $self->{GLOBATTR}->{$attrname} ); die "$sub: ** sdReadAttr **\n" if($res == PDL::IO::HDF->FAIL); if( $type == PDL::IO::HDF->DFNT_CHAR ) { $self->{GLOBATTR}->{$attrname} = Byte2Char( $self->{GLOBATTR}->{$attrname} ); } } my @dataname; foreach my $i ( 0 .. $num_datasets-1 ) { print "$sub: Loading SDS #$i\n" if $debug; my $sds_id = _SDselect( $self->{SDID}, $i ); die "$sub: ** sdSelect **\n" if($sds_id == PDL::IO::HDF->FAIL); my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $rank = 0; my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 ); my $numtype = 0; my $num_attrs = 0; $res = _SDgetinfo($sds_id, $name, $rank, $dimsize, $numtype, $num_attrs); die "$sub: ** sdGetInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$name = \'$name\'\n" if $debug; print "$sub: \$dimsize = \'$dimsize\'\n" if $debug; $self->{DATASET}->{$name}->{TYPE} = $numtype; $self->{DATASET}->{$name}->{RANK} = $rank; $self->{DATASET}->{$name}->{SDSID} = $sds_id; # Load up information on the dimensions (named, unlimited, etc...): # foreach my $j ( 0 .. $self->{DATASET}->{$name}->{RANK}-1 ) { print "$sub: Loading SDS($i) Dimension #$j\n" if $debug; my $dim_id = _SDgetdimid( $sds_id, $j ); die "$sub: ** sdGetDimId **\n" if($dim_id == PDL::IO::HDF->FAIL); my $dimname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $size = 0; my $num_type = 0; my $num_dim_attrs = 0; $res = _SDdiminfo( $dim_id, $dimname, $size, $num_type, $num_dim_attrs ); die "$sub: ** sdDimInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$dimname = \'$dimname\'\n" if $debug; $self->{DATASET}->{$name}->{DIMS}->{$j}->{DIMID} = $dim_id; $self->{DATASET}->{$name}->{DIMS}->{$j}->{SIZE} = $size; $self->{DATASET}->{$name}->{DIMS}->{$j}->{NAME} = $dimname; # The size comes back as 0 if it has the HDF unlimited dimension thing going on: # So, lets figure out what the size is currently at: unless ( $size ) { $self->{DATASET}->{$name}->{DIMS}->{$j}->{REAL_SIZE} = _SDgetunlimiteddim( $sds_id, $j); } } # Load up info on the SDS's attributes: # foreach my $j ( 0 .. $num_attrs-1 ) { print "$sub: Loading SDS($i) Attribute #$j\n" if $debug; my $attrname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $type = 0; my $count = 0; $res = _SDattrinfo( $sds_id, $j, $attrname, $type, $count); die "$sub: ** sdAttrInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$attrname = \'$attrname\'\n" if $debug; $self->{DATASET}->{$name}->{ATTRS}->{$attrname} = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$type}, $count ); $res = _SDreadattr( $sds_id, $j, $self->{DATASET}->{$name}->{ATTRS}->{$attrname} ); die "$sub: ** sdReadAttr **\n" if($res == PDL::IO::HDF->FAIL); # FIXME: This should be a constant if( $type == PDL::IO::HDF->DFNT_CHAR ) { $self->{DATASET}->{$name}->{ATTRS}->{$attrname} = Byte2Char( $self->{DATASET}->{$name}->{ATTRS}->{$attrname} ); } } } bless $self, $type; # Now that we're blessed, run our own accessors: # Default to using this (it's a good thing :) $self->Chunking( 1 ); return $self; } # End of new()... =head2 Chunking =for ref Accessor for the chunking mode on this HDF file. 'Chunking' is an internal compression and tiling the HDF library can perform on an SDS. This variable only affects they way SDput() works, and is ON by default. The code modifications enabled by this flag automatically partition the dataset to chunks of at least 100x100 values in size. The logic on this is pretty fancy, and would take a while to doc out here. If you _really_ have to know how it auto-partitions the data, then look at the code. Someday over the rainbow, I'll add some features for better control of the chunking parameters, if the need arises. For now, it's just stupid easy to use. =for usage Arguments: 1 (optional): new value for the chunking flag. =for example # See if chunking is currently on for this file: my $chunkvar = $hdf->Chunking(); # Turn the chunking off: my $newvar = $hdf->Chunking( 0 ); # Turn the chunking back on: my $newvar = $hdf->Chunking( 1 ); =cut # See the changelog for more docs on this feature: sub Chunking { my $self = shift; my $var = shift; if( defined( $var ) ) { $self->{CHUNKING} = $var ? 1 : 0; } return $self->{CHUNKING}; } # End of Chunking()... =head2 SDgetvariablenames =for ref get the list of datasets. =for usage No arguments Returns the list of dataset or undef on error. =for example my @DataList = $hdfobj->SDgetvariablenames(); =cut sub SDgetvariablenames { my($self) = @_; return keys %{$self->{DATASET}}; } # End of SDgetvariablenames()... sub SDgetvariablename { my $self = shift; return $self->SDgetvariablenames( @_ ); } # End of SDgetvariablename()... =head2 SDgetattributenames =for ref Get a list of the names of the global or SDS attributes. =for usage Arguments: 1 (optional) : The name of the SD dataset from which you want to get the attributes. This arg is optional, and without it, it will return the list of global attribute names. Returns a list of names or undef on error. =for example # For global attributes : my @attrList = $hdf->SDgetattributenames(); # For SDS attributes : my @attrList = $hdf->SDgetattributenames("dataset_name"); =cut sub SDgetattributenames { my($self, $name) = @_; if( defined( $name ) ) { return( undef ) unless defined( $self->{DATASET}->{$name} ); return keys %{ $self->{DATASET}->{$name}->{ATTRS} }; } else { return keys %{ $self->{GLOBATTR} }; } } # End of SDgetattributenames()... # Wrapper (this is now defunct): sub SDgetattributname { my $self = shift; return $self->SDgetattributenames( @_ ); } # End of SDgetattributname()... =head2 SDgetattribute =for ref Get a global or SDS attribute value. =for usage Arguments: 1 : The name of the attribute. 2 (optional): The name of the SDS from which you want to get the attribute value. Without this arg, it returns the global attribute value of that name. Returns an attribute value or undef on error. =for example # for global attributs : my $attr = $hdf->SDgetattribute("attr_name"); # for local attributs : my $attr = $hdf->SDgetattribute("attr_name", "dataset_name"); =cut sub SDgetattribute { my($self, $name, $dataset) = @_; if( defined($dataset) ) { # It's an SDS attribute: return( undef ) unless defined( $self->{DATASET}->{$dataset} ); return $self->{DATASET}->{$dataset}->{ATTRS}->{$name}; } else { # Global attribute: return( undef ) unless defined( $self->{GLOBATTR}->{$name} ); return $self->{GLOBATTR}->{$name}; } } # End of SDgetattribute()... # Wrapper (this is now defunct): sub SDgetattribut { my $self = shift; return $self->SDgetattribute( @_ ); } # End of SDgetattribut()... =head2 SDgetfillvalue =for ref Get the fill value of an SDS. =for usage Arguments: 1 : The name of the SDS from which you want to get the fill value. Returns the fill value or undef on error. =for example my $fillvalue = $hdf->SDgetfillvalue("dataset_name"); =cut sub SDgetfillvalue { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return ($self->{DATASET}->{$name}->{ATTRS}->{_FillValue})->at(0); } # End of SDgetfillvalue()... =head2 SDgetrange =for ref Get the valid range of an SDS. =for usage Arguments: 1 : the name of the SDS from which you want to get the valid range. Returns a list of two elements [min, max] or undef on error. =for example my @range = $hdf->SDgetrange("dataset_name"); =cut sub SDgetrange { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return $self->{DATASET}->{$name}->{ATTRS}->{valid_range}; } # End of SDgetrange()... =head2 SDgetscalefactor =for ref Get the scale factor of an SDS. =for usage Arguments: 1 : The name of the SDS from which you want to get the scale factor. Returns the scale factor or undef on error. =for example my $scale = $hdf->SDgetscalefactor("dataset_name"); =cut sub SDgetscalefactor { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return ($self->{DATASET}->{$name}->{ATTRS}->{scale_factor})->at(0); } # End of SDgetscalefactor()... =head2 SDgetdimsize =for ref Get the dimensions of a dataset. =for usage Arguments: 1 : The name of the SDS from which you want to get the dimensions. Returns an array of n dimensions with their sizes or undef on error. =for example my @dim = $hdf->SDgetdimsize("dataset_name"); =cut sub SDgetdimsize { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dims; foreach( sort keys %{ $self->{DATASET}->{$name}->{DIMS} } ) { push @dims, $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE}; } return( @dims ); } # End of SDgetdimsize()... =head2 SDgetunlimiteddimsize =for ref Get the actual dimensions of an SDS with 'unlimited' dimensions. =for usage Arguments: 1 : The name of the SDS from which you want to the dimensions. Returns an array of n dimensions with the dim sizes or undef on error. =for example my @dims = $hdf->SDgetunlimiteddimsize("dataset_name"); =cut sub SDgetunlimiteddimsize { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dim; foreach( sort keys %{$self->{DATASET}{$name}{DIMS}} ) { if( $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE} == 0 ) { $dim[ $_ ] = $self->{DATASET}->{$name}->{DIMS}->{$_}->{REAL_SIZE}; } else { $dim[ $_ ] = $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE}; } } return(@dim); } # End of SDgetunlimiteddimsize()... # Wrapper (this is now defunct): sub SDgetdimsizeunlimit { my $self = shift; return $self->SDgetunlimiteddimsize( @_ ); } # End of SDgetdimsizeunlimit()... =head2 SDgetdimnames =for ref Get the names of the dimensions of a dataset. =for usage Arguments: 1 : the name of a dataset you want to get the dimensions'names . Returns an array of n dimensions with their names or an empty list if error. =for example my @dim_names = $hdf->SDgetdimnames("dataset_name"); =cut sub SDgetdimnames { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dims=(); foreach( sort keys %{ $self->{DATASET}->{$name}->{DIMS} } ) { push @dims,$self->{DATASET}->{$name}->{DIMS}->{$_}->{NAME}; } return(@dims); } # End of SDgetdimnames()... sub SDgetdimname { my $self = shift; return $self->SDgetdimnames( @_ ); } # End of SDgetdimname(); =head2 SDgetcal =for ref Get the calibration factor from an SDS. =for usage Arguments: 1 : The name of the SDS Returns (scale factor, scale factor error, offset, offset error, data type), or undef on error. =for example my ($cal, $cal_err, $off, $off_err, $d_type) = $hdf->SDgetcal("dataset_name"); =cut sub SDgetcal { my ($self, $name ) = @_; my ($cal, $cal_err, $off, $off_err, $type); return( undef ) unless defined( $self->{DATASET}->{$name} ); return( undef ) unless defined( $self->{DATASET}->{$name}->{ATTRS}->{scale_factor} ); $cal = $self->{DATASET}->{$name}->{ATTRS}->{scale_factor}; $cal_err = $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err}; $off = $self->{DATASET}->{$name}->{ATTRS}->{add_offset}; $off_err = $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err}; $type = $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt}; return( $cal, $cal_err, $off, $off_err, $type ); } # End of SDgetcal()... =head2 SDget =for ref Get a the data from and SDS, or just a slice of that SDS. =for usage Arguments: 1 : The name of the SDS you want to get. 2 (optional): The start array ref of the slice. 3 (optional): The size array ref of the slice (HDF calls this the 'edge'). 4 (optional): The stride array ref of the slice. Returns a PDL of data if ok, PDL::null on error. If the slice arguments are not given, this function will read the entire SDS from the file. The type of the returned PDL variable is the PDL equivalent of what was stored in the HDF file. =for example # Get the entire SDS: my $pdldata = $hdf->SDget("dataset_name"); # get a slice of the dataset my $start = [10,50,10]; # the start position of the slice is [10, 50, 10] my $edge = [20,20,20]; # read 20 values on each dimension from @start my $stride = [1, 1, 1]; # Don't skip values my $pdldata = $hdf->SDget( "dataset_name", $start, $edge, $stride ); =cut sub SDget { my($self, $name, $start, $end, $stride) = @_; my $sub = _pkg_name( 'SDget' ); return null unless defined( $self->{DATASET}->{$name} ); unless( defined( $end ) ) { # \@end was not passed in, so we need to set everything else to defaults: ($start, $end) = []; my @dimnames=$self->SDgetdimnames($name); for my $dim (0 .. $#dimnames) { my $use_size = $self->{DATASET}->{$name}->{DIMS}->{$dim}->{SIZE} || $self->{DATASET}->{$name}->{DIMS}->{$dim}->{REAL_SIZE}; $$end[ $dim ] = $use_size; $$start[ $dim ] = 0; $$stride[ $dim ] = 1; } } my $c_start = pack ("L*", @$start); my $c_end = pack ("L*", @$end); my $c_stride = pack ("L*", @$stride); #print STDERR "$sub: start:[".join(',',@$start) # ."]=>$c_start end:[".join(',',@$end) # ."]=>$c_end stride:[".join(',',@$stride)."]=>$c_stride\n"; my $buff = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$self->{DATASET}->{$name}->{TYPE}}, reverse @$end ); my $res = _SDreaddata( $self->{DATASET}->{$name}->{SDSID}, $c_start, $c_stride, $c_end, $buff ); if($res == PDL::IO::HDF->FAIL) { $buff = null; print "$sub: Error returned from _SDreaddata()!\n"; } return $buff; } # End of SDget()... =head2 SDsetfillvalue =for ref Set the fill value for an SDS. =for usage Arguments: 1 : The name of the SDS. 2 : The fill value. Returns true on success, undef on error. =for example my $res = $hdf->SDsetfillvalue("dataset_name",$fillvalue); =cut sub SDsetfillvalue { my ($self, $name, $value) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); $value = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($value); $self->{DATASET}->{$name}->{ATTRS}->{_FillValue} = $value; return( _SDsetfillvalue($self->{DATASET}->{$name}->{SDSID}, $value) + 1 ); } # End of SDsetfillvalue()... =head2 SDsetrange =for ref Set the valid range of an SDS. =for usage Arguments: 1 : The name of the SDS 2 : an anonymous array of two elements : [min, max]. Returns true on success, undef on error. =for example my $res = $hdf->SDsetrange("dataset_name", [$min, $max]); =cut sub SDsetrange { my ($self, $name, $range) = @_; return undef unless defined( $self->{DATASET}->{$name} ); my $min = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($$range[0]); my $max = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($$range[1]); $range = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($range); $self->{DATASET}->{$name}->{ATTRS}->{valid_range} = $range; return( _SDsetrange($self->{DATASET}->{$name}->{SDSID}, $max, $min) + 1 ); } # End of SDsetrange()... =head2 SDsetcal =for ref Set the HDF calibration for an SDS. In HDF lingo, this means to define: scale factor scale factor error offset offset error =for usage Arguments: 1 : The name of the SDS. 2 (optional): the scale factor (default is 1) 3 (optional): the scale factor error (default is 0) 4 (optional): the offset (default is 0) 5 (optional): the offset error (default is 0) Returns true on success, undef on error. NOTE: This is not required to make a valid HDF SDS, but is there if you want to use it. =for example # Create the dataset: my $res = $hdf->SDsetcal("dataset_name"); # To just set the scale factor: $res = $hdf->SDsetcal("dataset_name", $scalefactor); # To set all calibration parameters: $res = $hdf->SDsetcal("dataset_name", $scalefactor, $scale_err, $offset, $off_err); =cut sub SDsetcal { my $self = shift; my $name = shift; return( undef ) unless defined( $self->{DATASET}->{$name} ); $self->{DATASET}->{$name}->{ATTRS}->{scale_factor} = shift || 1; $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err} = shift || 0; $self->{DATASET}->{$name}->{ATTRS}->{add_offset} = shift || 0; $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err} = shift || 0; # PDL_Double is the default type: $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt} = shift || 6; return( _SDsetcal( $self->{DATASET}->{$name}->{SDSID}, $self->{DATASET}->{$name}->{ATTRS}->{scale_factor}, $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err}, $self->{DATASET}->{$name}->{ATTRS}->{add_offset}, $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err}, $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt} ) + 1); } # End of SDsetcal()... =head2 SDsetcompress =for ref Set the internal compression on an SDS. =for usage Arguments: 1 : The name of the SDS. 2 (optional): The gzip compression level ( 1 - 9 ). If not specified, then 6 is used. Returns true on success, undef on failure. WARNING: This is a fairly buggy feature with many version of the HDF library. Please just use the 'Chunking' features instead, as they work far better, and are more reliable. =for example my $res = $hdf->SDsetfillvalue("dataset_name",$deflate_value); =cut sub SDsetcompress { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); # NOTE: Behavior change from the old version: # it used to set to 6 if the passed value was greater than 8 # it now sets it to 9 if it's greater than 9. my $deflate = shift || 6; $deflate = 9 if( $deflate > 9 ); return( 1 + _SDsetcompress( $self->{DATASET}->{$name}->{SDSID}, $deflate ) ); } # End of SDsetcompress()... =head2 SDsettextattr =for ref Add a text HDF attribute, either globally, or to an SDS. =for usage Arguments: 1 : The text you want to add. 2 : The name of the attribute 3 (optional): The name of the SDS. Returns true on success, undef on failure. =for example # Set a global text attribute: my $res = $hdf->SDsettextattr("my_text", "attribut_name"); # Set a local text attribute for 'dataset_name': $res = $hdf->SDsettextattr("my_text", "attribut_name", "dataset_name"); =cut sub SDsettextattr { my ($self, $text, $name, $dataset) = @_; if( defined($dataset) ) { return( undef ) unless defined( $self->{DATASET}->{$dataset} ); $self->{DATASET}->{$dataset}->{ATTRS}->{$name} = $text; return( _SDsetattr_text( $self->{DATASET}->{$dataset}->{SDSID}, $name, $text, length($text) ) + 1 ); } # Implied else it's a global attribute: $self->{GLOBATTR}->{$name} = $text; return( _SDsetattr_text( $self->{SDID}, $name, $text, length($text) ) + 1); } # End of SDsettextattr()... =head2 SDsetvalueattr =for ref Add a non-text HDF attribute, either globally, or to an SDS. =for usage Arguments: 1 : A pdl of value(s) you want to store. 2 : The name of the attribute. 3 (optional): the name of the SDS. Returns true on success, undef on failure. =for example my $attr = sequence( long, 4 ); # Set a global attribute: my $res = $hdf->SDsetvalueattr($attribute, "attribute_name"); # Set a local attribute for 'dataset_name': $res = $hdf->SDsetvalueattr($attribute, "attribute_name", "dataset_name"); =cut sub SDsetvalueattr { my ($self, $values, $name, $dataset) = @_; if( defined($dataset) ) { return( undef ) unless defined( $self->{DATASET}->{$dataset} ); $self->{DATASET}->{$dataset}->{ATTRS}->{$name} = $values; return( _SDsetattr_values( $self->{DATASET}->{$dataset}->{SDSID}, $name, $values, $values->nelem(), $PDL::IO::HDF::SDtypeTMAP->{$values->get_datatype()} ) + 1); } # Implied else it's a global attribute: $self->{GLOBATTR}->{$name} = $values; return( _SDsetattr_values( $self->{SDID}, $name, $values, $values->nelem(), $PDL::IO::HDF::SDtypeTMAP->{$values->get_datatype()} ) + 1); } # End of SDsetvalueattr()... =head2 SDsetdimname =for ref Set or rename the dimensions of an SDS. =for usage Arguments: 1 : The name of the SDS. 2 : An anonymous array with the dimensions names. For dimensions you want to leave alone, leave 'undef' placeholders. Returns true on success, undef on failure. =for example # Rename all dimensions my $res = $hdf->SDsetdimname("dataset_name", ['dim1','dim2','dim3']); # Rename some dimensions $res = $hdf->SDsetdimname("dataset_name", ['dim1', undef ,'dim3']); =cut # FIXME: There are several problems with this: # - The return code is an aggregate, and not necessarily accurate # - It bails on the first error without trying the rest. If that is still # desired, then it should run the check first, and if it's ok, then actually # make the HDF library call. sub SDsetdimname { my ($self, $name, $dimname) = @_; return undef unless defined( $self->{DATASET}->{$name} ); my $res = 0; foreach( sort keys %{$self->{DATASET}->{$name}->{DIMS}} ) { return( undef ) unless defined( $$dimname[ $_ ] ); $res = _SDsetdimname( $self->{DATASET}->{$name}->{DIMS}->{$_}->{DIMID}, $$dimname[ $_ ] ) + 1; } return( $res ); } # End of SDsetdimname()... =head2 SDput =for ref Write to a SDS in an HDF file or create and write to it if it doesn't exist. =for usage Arguments: 1 : The name of the SDS. 2 : A pdl of data. 3 (optional): An anonymous array of the dim names (only for creation) 4 (optional): An anonymous array of the start of the slice to store (only for putting a slice) Returns true on success, undef on failure. The datatype of the SDS in the HDF file will match the PDL equivalent as much as possible. =for example my $data = sequence( float, 10, 20, 30 ); #any value you want # Simple case: create a new dataset with a $data pdl my $result = $hdf->SDput("dataset_name", $data); # Above, but also naming the dims: $res = $hdf->SDput("dataset_name", $data, ['dim1','dim2','dim3']); # Just putting a slice in there: my $start = [x,y,z]; $res = $hdf->SDput("dataset_name", $data->slice("..."), undef, $start); =cut sub SDput { my($self, $name, $data, $dimname_p, $from) = @_; my $sub = _pkg_name( 'SDput' ); my $rank = $data->getndims(); my $dimsize = pack ("L*", reverse $data->dims); # If this dataset doesn't already exist, then create it: # unless ( defined( $self->{DATASET}->{$name} ) ) { my $hdf_type = $PDL::IO::HDF::SDtypeTMAP->{$data->get_datatype()}; my $res = _SDcreate( $self->{SDID}, $name, $hdf_type, $rank, $dimsize ); return( undef ) if ($res == PDL::IO::HDF->FAIL); $self->{DATASET}->{$name}->{SDSID} = $res; $self->{DATASET}->{$name}->{TYPE} = $hdf_type; $self->{DATASET}->{$name}->{RANK} = $rank; if( $self->Chunking() ) { # Setup chunking on this dataset: my @chunk_lens; my $min_chunk_size = 100; my $num_chunks = 10; my $total_chunks = 1; foreach my $dimsize ( $data->dims() ) { my $chunk_size = ($dimsize + 9) / $num_chunks; my $num_chunks_this_dim = $num_chunks; if( $chunk_size < $min_chunk_size ) { $chunk_size = $min_chunk_size; # Re-calc the num_chunks_per_dim: $num_chunks_this_dim = POSIX::ceil( $dimsize / $chunk_size ); } push(@chunk_lens, $chunk_size); $total_chunks *= $num_chunks_this_dim; } my $chunk_lengths = pack("L*", reverse @chunk_lens); $res = _SDsetchunk( $self->{DATASET}->{$name}->{SDSID}, $rank, $chunk_lengths ); return( undef ) if ($res == PDL::IO::HDF->FAIL); $res = _SDsetchunkcache( $self->{DATASET}->{$name}->{SDSID}, $total_chunks, 0); return( undef ) if ($res == PDL::IO::HDF->FAIL); } # End of chunking section... } # End of dataset creation... my $start = []; my $stride = []; if( defined( $from ) ) { $start = $from; foreach($data->dims) { push(@$stride, 1); } } else { # $from was not defined, so assume we're doing all of it: foreach($data->dims) { push(@$start, 0); push(@$stride, 1); } } $start = pack ("L*", @$start); $stride = pack ("L*", @$stride); $data->make_physical(); $res = _SDwritedata( $self->{DATASET}->{$name}->{SDSID}, $start, $stride, $dimsize, $data ); return( undef ) if ($res == PDL::IO::HDF->FAIL); foreach my $j ( 0 .. $rank-1 ) { # Probably not a good way to bail: my $dim_id = _SDgetdimid( $self->{DATASET}->{$name}->{SDSID}, $j ); return( undef ) if( $dim_id == PDL::IO::HDF->FAIL); if( defined( @$dimname_p[$j] ) ) { $res = _SDsetdimname( $dim_id, @$dimname_p[$j] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); } my $dimname = " "x(PDL::IO::HDF->MAX_NC_NAME); my $size = 0; my $num_dim_attrs = 0; $res = _SDdiminfo( $dim_id, $dimname, $size, $numtype=0, $num_dim_attrs); return( undef ) if ($res == PDL::IO::HDF->FAIL); $self->{DATASET}->{$name}->{DIMS}->{$j}->{NAME} = $dimname; $self->{DATASET}->{$name}->{DIMS}->{$j}->{SIZE} = $size; $self->{DATASET}->{$name}->{DIMS}->{$j}->{DIMID} = $dim_id; } return( 1 ); } # End of SDput()... =head2 close =for ref Close an HDF file. =for usage No arguments. =for example my $result = $hdf->close(); =cut # NOTE: This may not be enough, since there may be opened datasets as well! SDendaccess()! sub close { my $self = shift; my $sdid = $self->{SDID}; $self = undef; return( _SDend( $sdid ) + 1); } # End of close()... sub DESTROY { my $self = shift; $self->close; } # End of DESTROY()... EOPM # # Add the tail of the documentation to the module: # pp_addpm(<<'EOD'); =head1 CURRENT AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 PREVIOUS AUTHORS Patrick Leilde patrick.leilde@ifremer.fr contribs of Olivier Archer olivier.archer@ifremer.fr =head1 SEE ALSO perl(1), PDL(1), PDL::IO::HDF(1). =cut EOD pp_done(); PDL-2.018/IO/HDF/TODO0000644060175006010010000000213512562522364012004 0ustar chmNone# # PDL::IO::HDF # # Version 2.0 TODO: # We get there and it'll be included in the main PDL distribution! # # Judd Taylor, USF IMaRS # 17 March 2006 # ############ # General: # ############ Internally, everything should be using Class::Accessor methods, to seperate the naming semantics... I've always wanted better error handling, but that's a little ambitious for this version. The current error handling is to just die, but that's a major pain, since you may just want to open HDF files as a test and do something else if it fails. If the sub doesn't just die(), then it returns alls sorts of things currently (0, [], undef) I prefer lazy population of information, as it speeds up doing simple things on the files greatly. [NOTE: I've also written my own HDF4 C++ lib, and it works great there]. Real OO re-design and re-implementation (not for this version, though). ########## # Tests: # ########## ################## # Documentation: # ################## The VS.pd file needs a lot more documentation. PDL-2.018/IO/HDF/typemap0000644060175006010010000000210712562522364012715 0ustar chmNone# Extra type mappings for PDL::IO::HDF # basic C types int * T_PVI long int * T_PVI size_t * T_PVI nc_type * T_PVI nc_type T_IV PDLchar * T_PDL PDLuchar * T_PDL PDLshort * T_PDL PDLint * T_PDL PDLlong * T_PDL PDLfloat * T_PDL PDLdouble * T_PDL PDLvoid * T_PDL PDLlist * T_PVI ############################################################################# INPUT T_PVI $var = ($type)SvPV($arg,PL_na) T_PDLB $var = (unsigned char *)(PDL->SvPDLV($arg)->data) T_PDLS $var = (short *)(PDL->SvPDLV($arg)->data) T_PDLUS $var = (unsigned short *)(PDL->SvPDLV($arg)->data) T_PDLL $var = (long *)(PDL->SvPDLV($arg)->data) T_PDLF $var = (float *)(PDL->SvPDLV($arg)->data) T_PDLD $var = (double *)(PDL->SvPDLV($arg)->data) ############################################################################# OUTPUT T_PVI sv_setiv((SV*)$arg, (IV)*$var); T_PDLB PDL->SetSV_PDL($arg,$var); T_PDLS PDL->SetSV_PDL($arg,$var); T_PDLUS PDL->SetSV_PDL($arg,$var); T_PDLL PDL->SetSV_PDL($arg,$var); T_PDLF PDL->SetSV_PDL($arg,$var); T_PDLD PDL->SetSV_PDL($arg,$var); PDL-2.018/IO/HDF/VS/0000755060175006010010000000000013110402046011623 5ustar chmNonePDL-2.018/IO/HDF/VS/Changes0000644060175006010010000000012012562522364013127 0ustar chmNoneRevision history for Perl extension PDL::HDF 0.01 13/02/01 - original version PDL-2.018/IO/HDF/VS/Makefile.PL0000644060175006010010000000141112562522364013612 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; our ($hdf_include_path, $hdf_lib_path, $hdf_libs, $szip); my $package = [ qw(VS.pd VS PDL::IO::HDF::VS) ]; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int($package); }; WriteMakefile( NAME => 'PDL::IO::HDF::VS', TYPEMAPS => [ &PDL_TYPEMAP() ], OBJECT => 'VS.o', PM => { 'VS.pm' => '$(INST_LIBDIR)/VS.pm', }, INC => &PDL_INCLUDE() . " -I$hdf_include_path", LIBS => [ "-L$hdf_lib_path $hdf_libs -ljpeg -lz $szip" ], clean => { FILES => 'VS.pm VS.xs VS.o VS.c', }, dist => { COMPRESS => 'gzip', SUFFIX => 'gz', }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/HDF/VS/MANIFEST0000644060175006010010000000003212562522364012767 0ustar chmNoneVS.pd Changes Makefile.PL PDL-2.018/IO/HDF/VS/VS.pd0000644060175006010010000005460613036512175012527 0ustar chmNonepp_addpm({At => Top}, <<'EOD'); =head1 NAME PDL::IO::HDF - An interface library for HDF4 files. =head1 SYNOPSIS use PDL; use PDL::IO::HDF::VS; #### no doc for now #### =head1 DESCRIPTION This librairy provide functions to manipulate HDF4 files with VS and V interface (reading, writing, ...) For more information on HDF4, see http://www.hdfgroup.org/products/hdf4/ =head1 FUNCTIONS =cut EOD pp_addhdr(<<'EOH'); #include #include #include #include #include #include #include #define PDLchar pdl #define PDLuchar pdl #define PDLshort pdl #define PDLint pdl #define PDLlong pdl #define PDLfloat pdl #define PDLdouble pdl #define PDLvoid pdl #define uchar unsigned char #define PDLlist pdl EOH #define AVRef AV #pp_bless ("PDL::IO::HDF::VS"); use FindBin; use lib "$FindBin::Bin/.."; use buildfunc; #------------------------------------------------------------------------- # Create low level interface from HDF VS and V header file. #------------------------------------------------------------------------- create_low_level (<<'EODEF'); # # HDF (H) Interface # int Hishdf(const char *filename); int Hopen(const char *filename, int access, int n_dds); int Hclose(int file_id)+1; # # VGROUP/VDATA Interface # int Vstart(int hdfid); int Vend(int hdfid); int Vgetid(int hdfid, int vgroup_ref); int Vattach(int hdfid, int vgroup_ref, const char *access); int Vdetach(int vgroup_id); int Vntagrefs(int vgroup_id); int Vgettagref(int vgroup_id, int index, int *tag, int *ref); int Vinquire(int vgroup_id, int *n_entries, char *vgroup_name); int Vsetname(int vgroup_id, const char *vgroup_name); int Vsetclass(int vgroup_id, const char *vgroup_class); int Visvg(int vgroup_id, int obj_ref); int Visvs(int vgroup_id, int obj_ref); int Vaddtagref(int vgroup_id, int tag, int ref); int Vinsert(int vgroup_id, int v_id); int VSsetname(int vdata_id, const char *vdata_name); int VSsetclass(int vdata_id, const char *vdata_class); int VSgetid(int hdfid, int vdata_ref); int VSattach(int hdfid, int vdata_ref, const char *access); int VSdetach(int vdata_id); int VSelts(int vdata_id); int VSsizeof(int vdata_id, const char *fields); int VSfind(int hdfid, const char *vdata_name); int VFfieldtype(int vdata_id, int field_index); int VFnfields(int vdata_ref); int VFfieldorder(int vdata_ref, int field_index); int VSfdefine(int vata_id, const char *fieldname, int data_type, int order)+1; int VSsetfields(int vata_id, const char *fieldname_list)+1; int VSwrite(int vdata_id, const PDLvoid *databuf, int n_records, int interlace_mode); int VSread(int vdata_id, PDLvoid *databuf, int n_records, int interlace_mode); #int VSlone(int file_id, int *ref_array, int max_ref); int VSfnattrs(int vdata_id, int field_index); int VSgetattr(int vdata_id, int field_index, int attr_index, PDLlong *values); int VSisattr(int vdata_id); int SDstart(const char *filename, int access_mode); int SDreftoindex(int sd_id, int sds_ref); int SDselect(int sd_id, int index); int SDgetinfo(int sds_id, char *sds_name, int *rank, int *dimsizes, int *number_type, int *nattrs); int SDendaccess(int sds_id); int SDend(int sd_id); EODEF pp_addxs('',<<'ENDOFXS'); int _WriteMultPDL(VID, nb_records, nb_fields, interlace_mode, ...); int VID int nb_records int nb_fields int interlace_mode PROTOTYPE: @ CODE: unsigned char *databuff, *ptrbuff; unsigned long int total_size; int i, j, k, curvalue, cursdim; SV * sizeofPDL; SV * listofPDL; SV * sdimofPDL; SV * * SvTmp1, * * SvTmp2, * * SvTmp3; pdl *curPDL; sizeofPDL = SvRV( ST(4) ); sdimofPDL = SvRV( ST(5) ); listofPDL = SvRV( ST(6) ); total_size = 0; for(i=0; iSvPDLV( *SvTmp2 ); SvTmp3 = av_fetch((AV*)sdimofPDL, j, 0); cursdim = SvIV( *SvTmp3 ); SvTmp1 = av_fetch((AV*)sizeofPDL, j, 0); curvalue = SvIV( *SvTmp1 ); for(k=0; kdata + curvalue*i + curvalue*k*nb_records)); memcpy( ptrbuff, (unsigned char *)(curPDL->data + curvalue*i + curvalue*k*nb_records), curvalue ); #printf("Value %d=%d\n", k, *(int *)(curPDL->data + curvalue*i*cursdim + curvalue*k)); #memcpy( ptrbuff, (unsigned char *)(curPDL->data + curvalue*i*cursdim + curvalue*k), curvalue ); #printf("buffer %d= %d\n", k, *(int *)ptrbuff); ptrbuff += curvalue; } } } } else { for(j=0; jSvPDLV( *SvTmp2 ); SvTmp1 = av_fetch((AV*)sizeofPDL, j, 0); curvalue = SvIV( *SvTmp1 ); SvTmp3 = av_fetch((AV*)sdimofPDL, j, 0); cursdim = SvIV( *SvTmp3 ); memcpy( ptrbuff, (unsigned char *)(curPDL->data), curvalue*nb_records*cursdim ); ptrbuff += curvalue*nb_records*cursdim; #printf("buffer %d= %d\n", k, curvalue*nb_records*cursdim); } interlace_mode = 1; } fprintf(stderr, "Calling VSwrite(VID=%d, databuff=%p, nb_records=%d, interlace_mode=%d)...\n", VID, databuff, nb_records, interlace_mode); RETVAL = VSwrite(VID, databuff, nb_records, interlace_mode); OUTPUT: RETVAL void _Vgetname(vgroup_id, vgroup_name); int vgroup_id char *vgroup_name CODE: vgroup_name=(char *)malloc(VGNAMELENMAX); Vgetname(vgroup_id,vgroup_name); OUTPUT: vgroup_name void _VSgetname(vdata_id, vdata_name); int vdata_id char *vdata_name CODE: vdata_name=(char *)malloc(VGNAMELENMAX*sizeof(char)); VSgetname(vdata_id,vdata_name); OUTPUT: vdata_name void _Vgetclass(vgroup_id, vgroup_class); int vgroup_id char *vgroup_class CODE: vgroup_class=(char *)malloc(VGNAMELENMAX*sizeof(char)); Vgetclass(vgroup_id,vgroup_class); OUTPUT: vgroup_class void _VSgetclass(vdata_id, vdata_class); int vdata_id char *vdata_class CODE: vdata_class=(char *)malloc(VGNAMELENMAX*sizeof(char)); VSgetclass(vdata_id,vdata_class); OUTPUT: vdata_class int _VSgetfields(vdata_id, fields); int vdata_id char *fields CODE: char *tmpfields; int len; tmpfields=(char *)malloc(10000*sizeof(char)); RETVAL=VSgetfields(vdata_id, tmpfields); len=strlen(tmpfields); fields=(char *)malloc(len*sizeof(char)+1); strcpy(fields,tmpfields); OUTPUT: RETVAL fields AV * _VSlone(file_id); int file_id; CODE: AV *ref_vdata_list; int *ref_array; SV *ref_vdata; int32 nlone; ref_vdata_list=newAV(); ref_array=(int *)malloc(MAX_FIELD_SIZE*sizeof(int)); nlone = VSlone(file_id, ref_array, MAX_FIELD_SIZE); int32 i; for(i=0;i[0] => 1, PDL::short->[0] => 2, PDL::ushort->[0] => 2, PDL::long->[0] => 4, PDL::float->[0] => 4, PDL::double->[0] => 8 }; sub _pkg_name { return "PDL::IO::HDF::VS::" . shift() . "()"; } =head2 new =for ref Open or create a new HDF object with VS and V interface. =for usage Arguments: 1 : The name of the HDF file. If you want to write to it, prepend the name with the '+' character : "+name.hdf" If you want to create it, prepend the name with the '-' character : "-name.hdf" Otherwise the file will be opened in read only mode. Returns the hdf object (die on error) =for example my $hdf = PDL::IO::HDF::VS->new("file.hdf"); =cut sub new { # general my $type = shift; my $filename = shift; my $self = {}; if (substr($filename, 0, 1) eq '+') { # open for writing $filename = substr ($filename, 1); # chop off + $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } if (substr($filename, 0, 1) eq '-') { # Creating $filename = substr ($filename, 1); # chop off - $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE; } unless( defined($self->{ACCESS_MODE}) ) { $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ; } $self->{FILE_NAME} = $filename; $self->{HID} = PDL::IO::HDF::VS::_Hopen( $self->{FILE_NAME}, $self->{ACCESS_MODE}, 20 ); if ($self->{HID}) { PDL::IO::HDF::VS::_Vstart( $self->{HID} ); my $SDID = PDL::IO::HDF::VS::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} ); #### search for vgroup my $vgroup = {}; my $vg_ref = -1; while( ($vg_ref = PDL::IO::HDF::VS::_Vgetid( $self->{HID}, $vg_ref )) != PDL::IO::HDF->FAIL) { my $vg_id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $vg_ref, 'r' ); my $n_entries = 0; my $vg_name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_Vinquire( $vg_id, $n_entries, $vg_name ); my $vg_class = ""; PDL::IO::HDF::VS::_Vgetclass( $vg_id, $vg_class ); $vgroup->{$vg_name}->{ref} = $vg_ref; $vgroup->{$vg_name}->{class} = $vg_class; my $n_pairs = PDL::IO::HDF::VS::_Vntagrefs( $vg_id ); for ( 0 .. $n_pairs-1 ) { my ($tag, $ref); $res = PDL::IO::HDF::VS::_Vgettagref( $vg_id, $_, $tag = 0, $ref = 0 ); if($tag == 1965) { # Vgroup my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'r' ); my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_Vgetname( $id, $name ); PDL::IO::HDF::VS::_Vdetach( $id ); $vgroup->{$vg_name}->{children}->{$name} = $ref; $vgroup->{$name}->{parents}->{$vg_name} = $vg_ref; } elsif($tag == 1962) { # Vdata my $id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $ref, 'r' ); my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_VSgetname( $id, $name ); my $class = ""; PDL::IO::HDF::VS::_VSgetclass( $id, $class ); PDL::IO::HDF::VS::_VSdetach( $id ); $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'VData'; $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref; $vgroup->{$vg_name}->{attach}->{$name}->{class} = $class if( $class ne '' ); } if( ($SDID != PDL::IO::HDF->FAIL) && ($tag == 720)) #tag for SDS tag/ref (see 702) { my $i = _SDreftoindex( $SDID, $ref ); my $sds_ID = _SDselect( $SDID, $i ); my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $rank = 0; my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 ); my $numtype = 0; my $nattrs = 0; $res = _SDgetinfo( $sds_ID, $name, $rank, $dimsize , $numtype, $nattrs ); $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'SDS_Data'; $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref; } } # for each pair... PDL::IO::HDF::VS::_Vdetach( $vg_id ); } # while vg_ref... PDL::IO::HDF::VS::_SDend( $SDID ); $self->{VGROUP} = $vgroup; #### search for vdata my $vdata_ref=-1; my $vdata_id=-1; my $vdata = {}; # get lone vdata (not member of a vgroup) my $lone=PDL::IO::HDF::VS::_VSlone($self->{HID}); my $MAX_REF = 0; while ( $vdata_ref = shift @$lone ) { my $mode="r"; if ( $self->{ACCESS_MODE} != PDL::IO::HDF->DFACC_READ ) { $mode="w"; } $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, $mode ); my $vdata_size = 0; my $n_records = 0; my $interlace = 0; my $fields = ""; my $vdata_name = ""; my $status = PDL::IO::HDF::VS::_VSinquire( $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name ); die "PDL::IO::HDF::VS::_VSinquire (vdata_id=$vdata_id)" unless $status; $vdata->{$vdata_name}->{REF} = $vdata_ref; $vdata->{$vdata_name}->{NREC} = $n_records; $vdata->{$vdata_name}->{INTERLACE} = $interlace; $vdata->{$vdata_name}->{ISATTR} = PDL::IO::HDF::VS::_VSisattr( $vdata_id ); my $field_index = 0; foreach my $onefield ( split( ",", $fields ) ) { $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{TYPE} = PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $field_index ); $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{INDEX} = $field_index; $field_index++; } PDL::IO::HDF::VS::_VSdetach( $vdata_id ); } # while vdata_ref... $self->{VDATA} = $vdata; } # if $self->{HDID}... bless($self, $type); } # End of new()... sub Vgetchildren { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{children} ); return keys %{$self->{VGROUP}->{$name}->{children}}; } # End of Vgetchildren()... # Now defunct: sub Vgetchilds { my $self = shift; return $self->Vgetchildren( @_ ); } # End of Vgetchilds()... sub Vgetattach { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{attach} ); return keys %{$self->{VGROUP}->{$name}->{children}}; } # End of Vgetattach()... sub Vgetparents { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{parents} ); return keys %{$self->{VGROUP}->{$name}->{parents}}; } # End of Vgetparents()... sub Vgetmains { my ($self) = @_; my @rlist; foreach( keys %{$self->{VGROUP}} ) { push(@rlist, $_) unless defined( $self->{VGROUP}->{$_}->{parents} ); } return @rlist; } # End of Vgetmains()... sub Vcreate { my($self, $name, $class, $where) = @_; my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, -1, 'w' ); return( undef ) if( $id == PDL::IO::HDF->FAIL ); my $res = _Vsetname($id, $name); $res = _Vsetclass($id, $class) if defined( $class ); $self->{VGROUP}->{$name}->{ref} = '???'; $self->{VGROUP}->{$name}->{class} = $class if defined( $class ); if( defined( $where ) ) { return( undef ) unless defined( $self->{VGROUP}->{$where} ); my $ref = $self->{VGROUP}->{$where}->{ref}; my $Pid = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'w' ); my $index = PDL::IO::HDF::VS::_Vinsert( $Pid, $id ); my ($t, $r) = (0, 0); $res = PDL::IO::HDF::VS::_Vgettagref( $Pid, $index, $t, $r ); PDL::IO::HDF::VS::_Vdetach( $Pid ); $self->{VGROUP}->{$name}->{parents}->{$where} = $ref; $self->{VGROUP}->{$where}->{children}->{$name} = $r; $self->{VGROUP}->{$name}->{ref} = $r; } return( _Vdetach( $id ) + 1 ); } # End of Vcreate()... =head2 close =for ref Close the VS interface. =for usage no arguments =for example my $result = $hdf->close(); =cut sub close { my $self = shift; _Vend( $self->{HID} ); my $Hid = $self->{HID}; $self = undef; return( _Hclose($Hid) + 1 ); } # End of close()... sub VSisattr { my($self, $name) = @_; return undef unless defined( $self->{VDATA}->{$name} ); return $self->{VDATA}->{$name}->{ISATTR}; } # End of VSisattr()... sub VSgetnames { my $self = shift; return keys %{$self->{VDATA}}; } # End of VSgetnames()... sub VSgetfieldnames { my ( $self, $name ) = @_; my $sub = _pkg_name( 'VSgetfieldnames' ); die "$sub: vdata name $name doesn't exist!\n" unless defined( $self->{VDATA}->{$name} ); return keys %{$self->{VDATA}->{$name}->{FIELDS}}; } # End of VSgetfieldnames()... # Now defunct: sub VSgetfieldsnames { my $self = shift; return $self->VSgetfieldnames( @_ ); } # End of VSgetfieldsnames()... sub VSread { my ( $self, $name, $field ) = @_; my $sub = _pkg_name( 'VSread' ); my $data = null; my $vdata_ref = PDL::IO::HDF::VS::_VSfind( $self->{HID}, $name ); die "$sub: vdata name $name doesn't exist!\n" unless $vdata_ref; my $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, 'r' ); my $vdata_size = 0; my $n_records = 0; my $interlace = 0; my $fields = ""; my $vdata_name = ""; my $status = PDL::IO::HDF::VS::_VSinquire( $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name ); my $data_type = PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} ); die "$sub: data_type $data_type not implemented!\n" unless defined( $PDL::IO::HDF::SDinvtypeTMAP->{$data_type} ); my $order = PDL::IO::HDF::VS::_VFfieldorder( $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} ); if($order == 1) { $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records ); } else { $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records, $order ); } $status = PDL::IO::HDF::VS::_VSsetfields( $vdata_id, $field ); die "$sub: _VSsetfields\n" unless $status; $status = PDL::IO::HDF::VS::_VSread( $vdata_id, $data, $n_records, $interlace); PDL::IO::HDF::VS::_VSdetach( $vdata_id ); return $data; } # End of VSread()... sub VSwrite { my($self, $name, $mode, $field, $value) = @_; return( undef ) if( $$value[0]->getndims > 2); #too many dims my $VD_id; my $res; my @foo = split( /:/, $name ); return( undef ) if defined( $self->{VDATA}->{$foo[0]} ); $VD_id = _VSattach( $self->{HID}, -1, 'w' ); return( undef ) if( $VD_id == PDL::IO::HDF->FAIL ); $res = _VSsetname( $VD_id, $foo[0] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); $res = _VSsetclass( $VD_id, $foo[1] ) if defined( $foo[1] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); my @listfield = split( /,/, $field ); for( my $i = 0; $i <= $#$value; $i++ ) { my $HDFtype = $PDL::IO::HDF::SDtypeTMAP->{$$value[$i]->get_datatype()}; $res = _VSfdefine( $VD_id, $listfield[$i], $HDFtype, $$value[$i]->getdim(1) ); return( undef ) unless $res; } $res = _VSsetfields( $VD_id, $field ); return( undef ) unless $res; my @sizeofPDL; my @sdimofPDL; foreach ( @$value ) { push(@sdimofPDL, $_->getdim(1)); push(@sizeofPDL, $TMAP->{$_->get_datatype()}); } $res = _WriteMultPDL( $VD_id, $$value[0]->getdim(0), $#$value+1, $mode, \@sizeofPDL, \@sdimofPDL, $value); return( undef ) if( _VSdetach($VD_id) == PDL::IO::HDF->FAIL ); return $res; } # End of VSwrite()... sub DESTROY { my $self = shift; $self->close; } # End of DESTROY()... EOPM # # Add the tail of the docs: # pp_addpm(<<'EOD'); =head1 CURRENT AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 PREVIOUS AUTHORS Olivier Archer olivier.archer@ifremer.fr contribs of Patrick Leilde patrick.leilde@ifremer.fr =head1 SEE ALSO perl(1), PDL(1), PDL::IO::HDF(1). =cut EOD pp_done(); PDL-2.018/IO/IDL/0000755060175006010010000000000013110402045011301 5ustar chmNonePDL-2.018/IO/IDL/IDL.pm0000644060175006010010000005344712562522364012305 0ustar chmNone=head1 NAME PDL::IO::IDL -- I/O of IDL Save Files =head1 DESCRIPTION PDL::IO::IDL allows you to read and write IDL(tm) data files. Currently, only reading is implemented. Scalars, arrays, and structures are all supported. Heap pointers, compiled code, and objects are not supported. Of those three, only heap pointers are likely to be supported in the future. This code was not developed by RSI, makers of IDL. =head1 NOTES These things seem to work: =over 3 =item BYTE, SHORT, LONG, FLOAT, and DOUBLE numeric types and arrays All of these types seem to work fine. The corresponding variable is stored as a PDL in the hash element with the same name as the original variable in the file. Arrays are byteswapped as needed and are read in so that the dim list has the same indexing order within PDL as it did within IDL. =item STRINGs and arrays of STRINGs String types are stored as Perl list refs, in the hash element with the same name as the original variable in the file. =item Structures Structures are stored as hash refs. The elements of the hash may be accessed as values within the hash. =item Common blocks Variables that are notated as being in a common block are read as normal. Common-block names are collected in the special hash value '+common', which contains a hash each keyword of which is the name of a common block and each value of which is an array of variable names. =back These things are known to be not working and may one day be fixed: =over 3 =item COMPLEX numbers These could be implemented as 2-arrays or as PDL::Complex values, but aren't yet. =item PTR types These could be implemented as perl refs but currently aren't. =item writing Maybe one day -- but why bother writing a broken file format? NetCDF is better. =back These things are known to be not working and will probably never be fixed =over 3 =item Compiled code Decompiling IDL code is a violation of the IDL end-user license. To implement this, someone who does not hold an IDL license would have to reverse-engineer a set of .SAV files sent to that person by someone else with an IDL license. =item Objects IDL objects contain compiled code. =back =head1 FUNCTIONS =cut package PDL::IO::IDL; BEGIN { use Exporter (); package PDL::IO::IDL; @ISA = ( Exporter ); @EXPORT_OK = qw( ridl ); @EXPORT = @EXPORT_OK; @EXPORT_TAGS = ( Func=>[@EXPORT_OK] ); our $VERSION = "0.5"; $VERSION = eval $VERSION; use PDL; use PDL::Exporter; use Carp; } use strict; =head2 ridl =for usage $a = ridl("foo.sav"); =for ref Read an IDL save file from a file. Upon successful completion, $a is a hash ref containing all of the variables that are present in the save file, indexed by original variable name. IDL identifiers are case insensitive; they're all converted to upper-case in the hash that gets returned. This may be adjustable at a future date. Furthermore, because IDL identifiers can't contain special characters, some fields that start with '+' are used to store metadata about the file itself. Numeric arrays are stored as PDLs, structures are stored as hashes, and string and structure arrays are stored as perl lists. Named structure types don't exist in perl in the same way that they do in IDL, so named structures are described in the 'structs' field of the global metadata. Anonymous structures are treated as simple hashes. Named structures are also simple hashes, but they also contain a field '+name' that refers to the name of the structure type. =cut sub ridl { my( $name ) = shift; STDERR->autoflush(1); open(IDLSAV,"<$name") || barf("ridl: Can't open `$name' for reading\n"); my $hash = read_preamble(); read_records($hash); my @snames = sort keys %{$PDL::IO::IDL::struct_table}; @snames = grep(!m/^\+/,@snames); if(@snames) { $hash->{'+structs'}={}; local $_; for(@snames) { $hash->{'+structs'}->{$_} = $PDL::IO::IDL::struct_table->{$_}->{'names'}; } } return $hash; } ############################################################ ## ## Data structure definitions... ## ## This is a list, each element of which contains a description and ## subroutine to read that particular record type. ## our $types = [ ['START_MARKER',undef] # 0 (start of SAVE file) ,['COMMON_BLOCK',\&r_com] # 1 (COMMON block definition) ,['VARIABLE',\&r_var] # 2 (Variable data) ,['SYSTEM_VARIABLE',undef] # 3 (System variable data) ,undef # 4 (??) ,undef # 5 (??) ,['END_MARKER',\&r_end] # 6 (End of SAVE file) ,undef # 7 (??) ,undef # 8 (??) ,undef # 9 (??) ,['TIMESTAMP',\&r_ts] # 10 (Timestamp of the save file) ,undef # 11 (??) ,['COMPILED',undef] # 12 (Compiled procedure or func) ,['IDENTIFICATION',undef] # 13 (Author identification) ,['VERSION',\&r_v] # 14 (IDL Version information) ,['HEAP_HEADER',undef] # 15 (Heap index information) ,['HEAP_DATA',undef] # 16 (Heap data) ,['PROMOTE64',\&r_p64] # 17 (Starts 64-bit file offsets) ]; ############################################################ ## ## Vtypes -- Representations of IDL scalar variable types. ## The first element is the name, the second element is either a ## perl string (that should be fed to unpack) or a code ref to a ## sub that decodes the type. ## our $vtypes = [ undef # 0 ,["Byte", \&r_byte_pdl, [] ] # 1 ,["Short", \&r_n_cast, [long,short] ] # 2 ,["Long", \&r_n_pdl, [long] ] # 3 ,["Float", \&r_n_pdl, [float] ] # 4 ,["Double", \&r_n_pdl, [double] ] # 5 ,["Complex", undef ] # 6 ,["String", \&r_strvar, [] ] # 7 ,["Structure", sub {}, [] ] # 8 ,["ComplexDbl",undef ] # 9 ,["HeapPtr", undef ] # 10 ,["Object", undef ] # 11 ,["UShort", \&r_n_cast, [long,ushort] ] # 12 ,["ULong", \&r_n_pdl, [long] ] # 13 ,["LongLong", undef ] # 14 ,["ULongLong", undef ] # 15 ]; ### # Cheesy way to check if 64-bit is OK our $quad_ok = eval { my @a = unpack "q","00000001"; $a[0]; }; ### Initialized in read_preamble. our $little_endian; our $swab; our $p64; ############################## # # read_preamble # # Reads the preamble of a file and returns the preamble as a hash # ref. In case of failure, it barfs. Also initializes the structure table. # sub read_preamble { my $buf; my $out; sysread(IDLSAV,$buf,4) || barf ("PDL::IO::IDL: Couldn't read preamble\n"); my @sig = unpack("a2S",$buf); barf("PDL::IO::IDL: This isn't an IDL save file (wrong magic)\n") if($sig[0] ne 'SR'); if($sig[1] == 1024 || $sig[1] == 4) { $little_endian = ($sig[1] == 1024); } else { barf "Unrecognized IDL save file type\n"; } $swab = $little_endian; $p64 = 0; $PDL::IO::IDL::struct_table = {}; return {"+meta"=>{}}; } ############################## # # read_records # # Reads all the records of the file. Splits out into several other # types of record reader... # # sub read_records { my $hash = shift; my ($buf, $tbuf); my $retval; my %nexts; my $tag_count = 0; do { ### Read header of the record sysread(IDLSAV, $tbuf, 4) || barf("PDL::IO::IDL: unexpected EOF\n"); my $type = unpack "N",$tbuf; ### Record the next seek location ### (and discard 8 more bytes) my $next; if($p64) { print "Reading 64-bit location..." if($PDL::debug); sysread(IDLSAV,$buf,8 + 8); my @next = unpack "NN",$buf; $next = $next[1] + 2**32 * $next[0]; } else { print "Reading 32-bit location..." if($PDL::debug); sysread(IDLSAV,$buf,4 + 8); $next = unpack "N",$buf; } print "$next\n" if($PDL::debug); ### ### Infinite-loop detector ### barf("Repeat index finder was activated! This is a bug or a problem with your file.\n") if($nexts{$next}) ; $nexts{$next} = 1; ### ### Call the appropriate handling routine ### $retval = 1; if(defined $types->[$type]) { if(defined ($types->[$type]->[1])) { print "Found record of type $types->[$type]->[0]...\n" if($PDL::debug || $PDL::IO::IDL::test); $retval = &{$types->[$type]->[1]}($hash); print "OK.\n" if($PDL::debug); } else { print STDERR "Ignoring record of type ".$types->[$type]->[0]." - not implemented.\n"; } } else { print STDERR "\nIgnoring record of unknown type $type - not implemented.\n"; } print "Seeking $next ($tag_count tags read so far...)\n" if($PDL::debug || $PDL::IO::IDL::test); $tag_count++; sysseek(IDLSAV, $next, 0); $FOO::hash = $hash; } while($retval); } ############################## # r_com # # Jumptable entry for the COMMONBLOCK keyword -- this loads # the variable names that belong in the COMMON block into a # metavariable. sub r_com { my $hash = shift; my $buf; sysread(IDLSAV,$buf,4); my $nvars = unpack "N",$buf; my $name = r_string(); $hash->{"+common"}->{$name} = []; for my $i(1..$nvars) { push(@{$hash->{"+common"}->{$name}},r_string()); } return 1; } ############################## # r_end # # Jumptable entry for the END TABLE keyword -- just return 0. sub r_end { 0; } ############################## # r_ts # # TIMESTAMP record handler # sub r_ts { my $hash = shift; my $buf; ### Read and discard a LONARR(258) -- why? I don't know. sysread(IDLSAV,$buf,1024); $hash->{"+meta"}->{t_date} = r_string(); $hash->{"+meta"}->{t_user} = r_string(); $hash->{"+meta"}->{t_host} = r_string(); return 1; } ############################## # r_version # # VERSION record handler # sub r_v { my $hash = shift; my $buf; my $version; sysread(IDLSAV,$buf,4); $version = $hash->{"+meta"}->{v_fmt} = unpack "N",$buf; # barf("Unknown IDL save file version ".$version) print STDERR "Warning: IDL file is v$version (neither 5 nor 6); winging it. Check results!\n" if($version != 5 && $version != 6); $hash->{"+meta"}->{v_arch} = r_string(); $hash->{"+meta"}->{v_os} = r_string(); $hash->{"+meta"}->{v_release} = r_string(); return 1; } ############################## # r_p64 sub r_p64 { my $hash = shift; $p64 = 1; } ############################## # r_var # # VARIABLE reader - parse a single variable out of a VARIABLE record. # sub r_var { my $hash = shift; ### Read in the variable name my $name = r_string(); ### Read in and parse the type my $buf; sysread(IDLSAV,$buf,8); my ($type,$flags) = unpack "NN",$buf; unless(defined $vtypes->[$type]) { barf("PDL::IO::IDL: Unknown variable type $type"); } unless(defined $vtypes->[$type]->[1]) { print STDERR "Ignoring variable $name: unsupported type ".$vtypes->[$type]->[0]."\n"; return 1; } print "Variable $name found (flags is $flags)...\n" if($PDL::debug); if((($flags & 4) == 0) and (($flags & 32) == 0)) { print "it's a scalar\n" if($PDL::debug); sysread(IDLSAV,$buf,4); my($seven) = unpack "N",$buf; if($seven != 7) { print STDERR "Warning: expected data-start key (7) but got $seven, for variable $name\n"; } ## Scalar case $hash->{$name} = &{$vtypes->[$type]->[1]} ($flags, [], @{$vtypes->[$type]->[2]}) } else { ## Array case my($arrdesc) = r_arraydesc(); if(($flags & 32) == 0) { ## Simple array case sysread(IDLSAV,$buf,4); my($indicator) = unpack "N",$buf; print STDERR "Warning: Reading data from an array but got code $indicator (expected 7)\n" if($indicator != 7); print "simple array...type=$type\n" if($PDL::debug); my @args= ($flags,[ @{$arrdesc->{dims}}[0..$arrdesc->{ndims}-1]], @{$vtypes->[$type]->[2]}); my $pdl = &{$vtypes->[$type]->[1]}(@args); $hash->{$name} = $pdl; } else { ## Structure case print "structure...\n" if($PDL::debug); my($sname) = r_structdesc(); my @structs; print "Reading $arrdesc->{nelem} structures....\n" if($PDL::debug || $PDL::IO::IDL::test); my $i; {my $buf; sysread(IDLSAV,$buf,4);} for ($i=0;$i<$arrdesc->{nelem};$i++) { if($PDL::IO::IDL::test && !($i%100)){ print "$i of $arrdesc->{nelem}...\n"; } push(@structs,r_struct($sname)); } # Make a multi-dimensional list that contains the structs $hash->{$name} = multi_dimify($arrdesc,\@structs); } } return 1; } ############################## # multi_dimify # # Take a linear list of items and an array descriptor, and # hand back a multi-dimensional perl list with the correct dimension # according to the descriptor. (This isn't necessary for PDL types, # only for structures and strings). # sub multi_dimify { my($arrdesc,$structs,$n) = @_; return shift @{$structs} if($arrdesc->{ndims} <= $n or $arrdesc->{ndims} == 0 or $arrdesc->{ndims}-$n == 1 && $arrdesc->{dims}->[$n]==1); if($arrdesc->{ndims} - $n == 1){ my @ret = splice @{$structs},0,$arrdesc->{dims}->[$n]; return \@ret; } my $out = []; my $i; for ($i=0;$i<$arrdesc->{dims}->[$n];$i++) { push(@{$out},multi_dimify($arrdesc,$structs,$n+1)); } return $out; } ###################################################################### ###################################################################### # # r_arraydesc - read an array descriptor from the file # our $r_arraydesc_table = ['a','b','nbytes','nelem','ndims','c','d','nmax']; sub r_arraydesc { my $out = {}; my $buf; sysread(IDLSAV,$buf,4*8); my(@vals) = unpack("N"x8,$buf); print STDERR "r_arraydesc_table: vals[0]=".$vals[0]." (should be 8)\n" if($vals[0] != 8); for my $i(0..7) { $out->{$r_arraydesc_table->[$i]} = $vals[$i]; } my $nmax = $vals[7]; my $nelem = $vals[3]; sysread(IDLSAV,$buf,$nmax*4); $out->{dims} = [unpack("N"x$nmax,$buf)]; my $dims = pdl(@{$out->{dims}}); $out->{pdldims} = $dims; print STDERR "PDL::IO::IDL: Inconsistent array dimensions in variable (nelem=$nelem, dims=".join("x",@{$out->{dims}}).")" if($nelem != $dims->prod); $out; } ############################## # # r_structdesc reads a structure description and stores it in the struct_table. # You get back the name of the structure. # sub r_structdesc { my $buf; print "Reading a structure description...\n" if($PDL::IO::IDL::test); sysread(IDLSAV,$buf,4); # Discard initial long (value=9) from descriptor my($name) = r_string(); # Have to store structures in the structure table. $name =~ s/\s//g; $name = "+anon".scalar(keys %{$PDL::IO::IDL::struct_table}) if($name eq ''); sysread(IDLSAV,$buf,4*3); my($predef,$ntags,$nbytes) = unpack("N"x3,$buf); print "predef=$predef,ntags=$ntags,nbytes=$nbytes\n" if($PDL::debug); if(!($predef & 1)) { my $i; print "not predefined. ntags=$ntags..\n" if($PDL::debug || $PDL::IO::IDL::test); my $st = $PDL::IO::IDL::struct_table->{$name} = { "ntags" => $ntags ,"nbytes"=> $nbytes ,"names" => [] ,"arrays" => [] ,"structs" => [] }; ### Read tag descriptors. sysread(IDLSAV,$buf,3*4*$ntags); $st->{descrip} = [(unpack "N"x(3*$ntags), $buf)]; print "ntags is $ntags\n" if($PDL::debug || $PDL::IO::IDL::test); ### Read tag names. for $i(0..$ntags-1) { push(@{$st->{names}},r_string()); } ### Search for nested arrays & structures my ($nstructs,$narrays); for $i(0..$ntags-1) { my $a = $st->{descrip}->[$i*3+2]; $nstructs++ if($a & 32); $narrays++ if($a & 38); } print "narrays=$narrays\n" if($PDL::debug || $PDL::IO::IDL::test); for $i(0..($narrays-1)) { push( @{$st->{arrays}}, r_arraydesc() ); } print "nstructs=$nstructs\n" if($PDL::debug || $PDL::IO::IDL::test); for $i(0..($nstructs-1)) { push( @{$st->{structs}}, r_structdesc() ); } } print "finished with structure desc...\n" if($PDL::IO::IDL::test); return $name; } ############################## # # r_struct # # Given the name of a structure type, read in exactly one of them. # If I were smarter, this would be the same code as the variable # reader, but I'm not so it's only similar. # our $r_struct_recursion = 0; sub r_struct { my($sname) = shift; print ("_ "x$r_struct_recursion) . "Reading a structure...\n" if($PDL::IO::IDL::test); my $zz=$r_struct_recursion; local($r_struct_recursion) = $zz++; # Get the structure descriptor from the table. my($sd) = $PDL::IO::IDL::struct_table->{$sname}; barf "Unknown structure type $sname" unless defined($sd); # Initialize the structure itself and the array and structure indices. my($struct) = {}; $struct->{'+name'} = $sname unless($sname =~ m/^\+/); my($array_no, $struct_no); # Loop over tags and snarf each one my($i); for($i=0;$i<$sd->{ntags};$i++) { my($name) = $sd->{names}->[$i]; my($type) = $sd->{descrip}->[$i*3+1]; my($flags) = $sd->{descrip}->[$i*3+2]; print "reading tag #$i ($sd->{names}->[$i])\n" if($PDL::debug); barf("PDL::IO::IDL: Unknown variable type $type in structure") unless defined($vtypes->[$type]); unless(defined($vtypes->[$type]->[1])) { print "Skipping tag $name in structure - unsupported type ".$vtypes->[$type]->[0]."\n"; $array_no++ if($flags & 38); $struct_no++ if($flags & 32); } else { if( (($flags & 4)==0) and (($flags & 32)==0) ) { ## Scalar tag case $struct->{$name} = &{$vtypes->[$type]->[1]} ($flags, [], @{$vtypes->[$type]->[2]}); } else { ### Array and/or structure case ### my($arrdesc) = $sd->{arrays}->[$array_no++]; # sysread(IDLSAV,my $buf,4); # skip indicator if(($flags & 32) == 0) { ### Tag is a simple array ### my @args = ($flags,[ @{$arrdesc->{dims}}[0..$arrdesc->{ndims}-1]], @{$vtypes->[$type]->[2]}); my $pdl = &{$vtypes->[$type]->[1]}(@args); print " pdl is $pdl\n" if($PDL::debug); $struct->{$name} = $pdl; } else { ### Tag is a structure ### my $tsname = $sd->{structs}->[$struct_no++]; my @structs = (); for $i(1..$arrdesc->{nelem}) { push(@structs,r_struct($tsname)); } $struct->{$name} = multi_dimify($arrdesc,\@structs); } } } } # end of ntags loop return $struct; } ############################## # # r_string # # Reads a string value, leaving the file pointer correctly aligned # on a 32-bit boundary (if it started that way). Returns the string as # a perl scalar. # sub r_string{ my ($buf,$foo); sysread(IDLSAV, $buf, 4); # Read the length... my ($len) = unpack "N",$buf; # Pad the length out to the next 32-bit boundary my $plen = $len - ($len % -4) ; sysread(IDLSAV,$buf,$plen); return unpack "A$len",$buf; } ############################## # # r_strvar # # Reads a string variable (different than r_string because # of the extra length duplication in the IDL file...) # sub r_strvar { my $buf; my $flags = shift; sysread(IDLSAV,$buf,4); return r_string(); } ############################## # # r_byte_pdl # # Reads a byte PDL (stored as a strvar) # sub r_byte_pdl { my($flags,$dims) = @_; sysread(IDLSAV,my $buf,4) if($#$dims > 1); $a = r_string(); my $pdl = new PDL; $pdl->set_datatype(byte->enum); $pdl->setdims($dims); ${ $pdl->get_dataref() } = $a; $pdl->upd_data; $pdl; } ############################## # # r_n_pdl # # Reads normal integer-type numerical values as a pdl. # You feed in the dimlist and type, you get back the # final pdl. The read is padded to the nearest word boundary. # sub r_n_pdl { my($flags,$dims,$type) = @_; my $nelem = pdl($dims)->prod; my $dsize = PDL::Core::howbig($type); my $hunksize = $dsize * $nelem; my $pdl = PDL->new_from_specification($type,@$dims); my $dref = $pdl->get_dataref(); my $len = sysread(IDLSAV, $$dref, $hunksize - ($hunksize % -4) ); $pdl->upd_data; print "bytes were ",join(",",unpack "C"x($hunksize-($hunksize%-4)),$$dref),"\n" if($PDL::debug); if($swab) { bswap2($pdl) if($dsize==2); bswap4($pdl) if($dsize==4); bswap8($pdl) if($dsize==8); } $pdl; } sub r_n_cast { my($flags,$dims,$type1,$type2) = @_; (r_n_pdl($flags,$dims,$type1))->convert($type2); } =head1 AUTHOR, LICENSE, NO WARRANTY THIS CODE IS PROVIDED WITH NO WARRANTY and may be distributed and/or modified under the same terms as PDL itself. This code is based on the analysis of the IDL save file format published by Craig Markwardt in 2002. IDL is a trademark of Research Systems Incorporated (RSI). The PDL development team, and authors of this code, are not affiliated with RSI. =cut 1; PDL-2.018/IO/IDL/Makefile.PL0000644060175006010010000000064512562522364013301 0ustar chmNoneuse ExtUtils::MakeMaker; use strict; use warnings; # With dmake a postamble is sometimes (incorrectly) written # in the Makefile. The following prevents that: undef &MY::postamble; # suppress warning *MY::postamble = sub { return ""; }; WriteMakefile( NAME => "PDL::IO::IDL", 'VERSION_FROM' => '../../Basic/Core/Version.pm', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/IDL/README0000755060175006010010000000347612562522364012217 0ustar chmNoneIDL has updated their status to allow reading of IDL SAV data files from other languages. This implementation is based on a 3rd party spec by Craig Markwardt based on the IDL 4.x and 5.x save files. It cannot read save files created by IDL 8.x. +------------------------------------------------------------------+ From Joe Hourcle, who worked to get permission to distribute this code: In January of 2011, our group had a meeting with our NASA account rep, Amanda O'Connor. I brought up that they had announced at the IDL User Meeting at either the 2009 or 2010 Fall AGU Meeting that there was now a python library to read IDL save files, and I asked what was the process to be allowed to read them from Perl. This was the response that I received. ... -Joe Begin forwarded message: > From: "Thomas Harris" > Date: February 3, 2011 12:29:18 PM EST > To: , ... > Cc: "Amanda O'Connor" > Subject: FW: ITT-VIS meeting Follow-up > > Hi all: > My name is Thomas Harris and I'm working with Amanda this year on NASA. > Amanda and I checked in to your questions regarding IDL SAV files with > our Product Management. Here is their response: > > "...We are perfectly fine with people wanting to read IDL save files > with Data in them, in whatever language they want - IDL, Matlab, Perl, > Python. > > Finally, we are going to remove the Copyright restriction from data Save > files (probably in IDL 8.1), but keep it in for code Save files. That > way there should be no confusion." > > Let me know if you have any additional questions. > Best regards, > > Thomas Harris > Technical Account Manager - Federal Sales > ITT Visual Information Solutions > > tharris@ittvis.com > direct: 303.402.4666 > tel: 303.786.9900 > mobile: 720.256.1098 > fax: 303.786.9909 > www.ittvis.com PDL-2.018/IO/IO.pod0000644060175006010010000002647413036512175011736 0ustar chmNone=head1 NAME PDL::IO - An overview of the modules in the PDL::IO namespace. =head1 SYNOPSIS # At your system shell, type: perldoc PDL::IO =head1 DESCRIPTION PDL contains many modules for displaying, loading, and saving data. =over =item * Perlish or Text-Based A few IO modules provide Perl-inspired capabilities. These are PDL::IO::Dumper and PDL::IO::Storable. PDL::IO::Misc provides simpler routines for dealing with delimited files, though its capabilities are limited to tabular or at most 3-d data sets. =item * Raw Format PDL has two modules that store their data in a raw binary format; they are PDL::IO::FastRaw and PDL::IO::FlexRaw. They are fast but the files they produce will not be readable across different architectures. These two modules are so similar that they could probably be combined. =item * Data Browsing At the moment, only PDL::IO::Browser provides data browsing functionality. =item * Image Handling PDL has a handful of modules that will load images into piddles for you. They include PDL::IO::Dicom, PDL::IO::FITS, PDL::IO::GD, PDL::IO::Pic, and PDL::IO::Pnm. However, PDL::IO::FITS should also be considered something of a general data format. =item * Disk Caching Both PDL::IO::FastRaw and PDL::IO::FlexRaw provide for direct piddle-to-disk mapping, but they use PDL's underlying mmap functionality to do it, and that doesn't work for Windows. However, users of all operating systems can still use PDL::DiskCache, which can use any desired IO read/write functionality (though you may have to write a small wrapper function). =item * General Data Storage Formats PDL has a number of modules that interface general data storage libraries. They include PDL::IO::HDF and PDL::IO::NDF (the latter is now a separate CPAN module). There is a PDL::IO::IDL, though at the moment it is not distributed with PDL. PDL::IO::FITS is something of a general data format, since piddle data can be stored to a FITS file without loss. PDL::IO::FlexRaw and PDL::IO::FastRaw read and write data identical C's low-level C function and PDL::IO::FlexRaw can work with FORTRAN 77 UNFORMATTED files. FlexRaw and Storable provide general data storage capabilities. Finally, PDL can read Grib (weather-data) files using the CPAN module PDL::IO::Grib. =item * Making Movies You can make an MPEG animation using PDL::IO::Pic's wmpeg function. =back Here's a brief summary of all of the modules, in alphabetical order. =head2 PDL::DiskCache The DiskCache module allows you to tie a Perl array to a collection of files on your disk, which will be loaded into and out of memory as piddles. Although the module defaults to working with FITS files, it allows you to specify your own reading and writing functions. This allows you to vastly streamline your code by hiding the unnecessary details of loading and saving files. If you find yourself writing scripts to procss many data files, especially if that data processing is not necessarily in sequential order, you should consider using PDL::DiskCache. To read more, check the L. =head2 PDL::IO::Browser The Browser module provides a text-based data browser for 2D data sets. It uses the CURSES library to do the scrolling, so if your operating system does not have the cureses library, you won't be able to install this on your machine. (Note that the package containing the header files for the CURSES library may be called C or possibly C.) PDL::IO::Browser is not installed by default because it gives trouble on Mac OS X, and not enough is known to fix the problem. If you want to enable it, edit the perldl configuration file and rebuild PDL. To learn more about editing the configuration file, see the INSTALLATION section in L. (Also, if you are familiar with CURSES on Mac, your help would be much appreciated!) To see if the module is installed on your machine (and to get more information about PDL::IO::Browser), follow L or type at the system prompt: perldoc PDL::IO::Browser If you want to get more information about PDL::IO::Browser and it's not installed on your system, I'm afraid you'll have to pick out the pod from the source file, which can be found online at L. =head2 PDL::IO::Dicom DICOM is an image format, and this module allows you to read image files with the DICOM file format. To read more, check the L. =head2 PDL::IO::Dumper Provides functionality similar to L for piddles. L stringifies a data structure, creating a string that can be Ced to reproduce the original data structure. It's also usually suitable for printing, to visualize the structure. To read more, check the L. See also PDL::IO::Storable for a more comprehensive structured data solution. =head2 PDL::IO::FastRaw Very simple module for quickly writing, reading, and memory-mapping piddles to/from disk. It is fast to learn and fast to use, though you may be frustrated by its lack of options. To quote from the original POD: "The binary files are in general NOT interchangeable between different architectures since the binary file is simply dumped from the memory region of the piddle. This is what makes the approach efficient." This creates two files for every piddle saved - one that stores the raw data and another that stores the header file, which indicates the dimensions of the data stored in the raw file. Even if you save 1000 different piddles with the exact same dimensions, you will still need to write out a header file for each one. You cannot store multiple piddles in one file. Note that at the time of writing, memory-mapping is not possible on Windows. For more details, see L. For a more flexible raw IO module, see PDL::IO::FlexRaw. =head2 PDL::IO::FITS Allows basic reading and writing of FITS files. You can read more about FITS formatted files at L and L. It is an image format commonly used in Astronomy. This module may or may not be installed on your machine. To get more information, check online at L. To see if the module is installed on your machine, follow L or type at the system prompt: perldoc PDL::IO::FITS =head2 PDL::IO::FlexRaw Somewhat smarter module (compared to FastRaw) for reading, writing, and memory mapping piddles to disk. In addition to everything that FastRaw can do, FlexRaw can also store multiple piddles in a single file, take user-specified headers (so you can use one header file for multiple files that have identical structure), and read compressed data. However, FlexRaw cannot memory-map compressed data, and just as with FastRaw, the format will not work across multiple architectures. FlexRaw and FastRaw produce identical raw files and have essentially identical performance. Use whichever module seems to be more comfortable. I would generally recommend using FlexRaw over FastRaw, but the differences are minor for most uses. Note that at the time of writing, memory-mapping is not possible on Windows. For more details on FlexRaw, see L. =head2 PDL::IO::GD GD is a library for reading, creating, and writing bitmapped images, written in C. You can read more about the C-library here: L. In addition to reading and writing .png and .jpeg files, GD allows you to modify the bitmap by drawing rectangles, adding text, and probably much more. The documentation can be L. As such, it should probably be not only considered an IO module, but a Graphics module as well. This module provides PDL bindings for the GD library, which ought not be confused with the Perl bindings. The perl bindings were developed independently and can be found at L, if you have Perl's GD bindings installed. =head2 PDL::IO::Grib A CPAN module last updated in 2000 that allows you to read Grib files. GRIB is a data format commonly used in meteorology. In the off-chance that you have it installed, you should L. =head2 PDL::IO::HDF, PDL::IO::HDF5 Provides an interface to HDF4 and HDF5 file formats, which are kinda like cross-platform binary XML files. HDF stands for Beierarchicl Bata Bormat. HDF was originally developed at the NCSA. To read more about HDF, see L. Note that HDF5 is not presently distributed with PDL, and neither HDF4 nor HDF5 will be installed unless you have the associated C libraries that these modules interface. Also note that the HDF5 library on CPAN is rather old and somebody from HDF contacted the mailing list in the Fall of 2009 to develop new and better HDF5 bindings for Perl. You should look into the L or L, depending upon which module you have installed. =head2 PDL::IO::IDL Once upon a time, PDL had a module for reading IDL data files. Unfortunately, it cannot be distributed because the original author, Craig DeForest, signed the IDL license agreement and was unable to negotiate the administrative hurdles to get it published. However, it can be found in Sourceforge's CVS attic, and any PDL user who has not signed IDL's license agreement can fix it up and resubmit it. =head2 PDL::IO::Misc Provides mostly text-based IO routines. Data input and output is restricted mostly to tabular (i.e. two-dimensional) data sets, though limited support is provided for 3d data sets. Alternative text-based modules support higher dimensions, such as PDL::IO::Dumper and PDL::IO::Storable. Check the L for more details. =head2 PDL::IO::NDF Starlink developed a file format for N-Dimensional data Files, which it cleverly dubbed NDF. If you work with these files, you're in luck! Check the L for more details. =head2 PDL::IO::Pic Provides reading/writing of images to/from piddles, as well as creating MPEG animations! The module uses the netpbm library, so you will need that on your machine in order for this to work. To read more, see the L. Also look into the next module, as well as PDL::IO::GD. =head2 PDL::IO::Pnm Provides methods for reading and writing pnm files (of which pbm is but one). Check the L for more details. Also check out the previous module and PDL::IO::GD. =head2 PDL::IO::Storable Implements the relevant methods to be able to store and retrieve piddles via Storable. True, you can use many methods to save a single piddle. In contrast, this module is particularly useful if you need to save a complex Perl structure that contain piddles, such as an array of hashes, each of which contains piddles. Check the L for more details. See also PDL::IO::Dumper for an alternative stringifier. =head1 COPYRIGHT Copyright 2010 David Mertens (dcmertens.perl@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.018/IO/Makefile.PL0000644060175006010010000000147212562522364012670 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; # do we build PDL::IO::Browser ? my @dirs = qw( FastRaw Misc FlexRaw Pnm Storable FITS HDF GD Dicom IDL ); if ($PDL::Config{WITH_IO_BROWSER} && $PDL::Config{WITH_IO_BROWSER}) { push @dirs, 'Browser'; print " Building PDL::IO::Browser. Turn off WITH_IO_BROWSER if this is incorrect.\n"; } else { print " Not building PDL::IO::Browser. Turn on WITH_IO_BROWSER if this is incorrect.\n"; } WriteMakefile( 'NAME' => 'PDL::IO', 'VERSION_FROM' => '../Basic/Core/Version.pm', 'PM' => { 'Dumper.pm' => '$(INST_LIB)/PDL/IO/Dumper.pm', 'IO.pod' => '$(INST_LIB)/PDL/IO.pod', }, 'DIR' => [ @dirs ], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/IO/Misc/0000755060175006010010000000000013110402046011565 5ustar chmNonePDL-2.018/IO/Misc/Makefile.PL0000644060175006010010000000036312562522364013561 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["misc.pd", qw(Misc PDL::IO::Misc)]); undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile( pdlpp_stdargs_int(@pack) ); PDL-2.018/IO/Misc/misc.pd0000644060175006010010000013451513036512175013072 0ustar chmNone # check for bad value support use PDL::Config; my $bvalflag = $PDL::Config{WITH_BADVAL} || 0; # and endian-ness of machine require PDL::Core::Dev; my $isbigendian = PDL::Core::Dev::isbigendian(); pp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::IO::Misc - misc IO routines for PDL =head1 DESCRIPTION Some basic I/O functionality: FITS, tables, byte-swapping =head1 SYNOPSIS use PDL::IO::Misc; =cut EOD pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) Karl Glazebrook 1997, Craig DeForest 2001, 2003, and Chris Marshall 2010. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_add_exported('',"rcols wcols swcols rgrep rdsa"); ############################## PM CODE ######################################## pp_addpm(<<'!NO!SUBS!'); use PDL::Primitive; use PDL::Types; use PDL::Options; use PDL::Bad; use Carp; use Symbol qw/ gensym /; use List::Util; use strict; !NO!SUBS! defpdl( 'bswap2', 'x(); ', '', ' int i; PDL_Short *aa; PDL_Short bb; PDL_Byte *a,*b; int n = sizeof($x()) / sizeof(PDL_Short); aa = (PDL_Short*) &$x(); for(i=0;idims; my @nnew = @nold; $nnew[-1] += $n; # add $n to the last dimension my $b = zeroes($a->type,@nnew); # New pdl my $bb = $b->mv(-1,0)->slice("0:".($nold[-1]-1))->mv(0,-1); $bb .= $a; $_[0] = $b; } 1; } # Implements PDL->at() for either 1D PDL or ARRAY arguments # TODO: Need to add support for multidim piddles parallel to rcols sub _at_1D ($$) { # Called by wcols and swcols my $data = $_[0]; my $index = $_[1]; if (ref $data eq 'ARRAY') { return $data->[$index]; } else { return $data->at($index); } } # squeezes "fluffy" perl list values into column data type sub _burp_1D { my $data = $_[0]->[0]; my $databox = $_[0]->[1]; my $index = $_[1]; my $start = $index - @{$databox} + 1; my $tmp; # work around for perl -d "feature" if (ref $data eq 'ARRAY') { push @{$data}, @{$databox}; } elsif ( ref($databox->[0]) eq "ARRAY" ) { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) ($tmp = $data->slice(":,$start:$index")) .= pdl($databox); } else { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) ($tmp = $data->slice("$start:$index")) .= pdl($databox); } $_[0] = [ $data, [] ]; } # taken outside of rcols() to avoid clutter sub _handle_types ($$$) { my $ncols = shift; my $deftype = shift; my $types = shift; barf "Unknown PDL type given for DEFTYPE.\n" unless ref($deftype) eq "PDL::Type"; my @cols = ref($types) eq "ARRAY" ? @$types : (); if ( $#cols > -1 ) { # truncate if required $#cols = $ncols if $#cols > $ncols; # check input values are sensible for ( 0 .. $#cols ) { barf "Unknown value '$cols[$_]' in TYPES array.\n" unless ref($cols[$_]) eq "PDL::Type"; } } # fill in any missing columns for ( ($#cols+1) .. $ncols ) { push @cols, $deftype; } return @cols; } # sub: _handle_types # Whether an object is an IO handle use Scalar::Util; sub _is_io_handle { my $h = shift; # reftype catches almost every handle, except: *MYHANDLE # fileno catches *MYHANDLE, but doesn't catch handles that aren't files my $reftype = Scalar::Util::reftype($h); return defined(fileno($h)) || (defined($reftype) && $reftype eq 'GLOB'); } =head2 rcols =for ref Read specified ASCII cols from a file into piddles and perl arrays (also see L). =for usage Usage: ($x,$y,...) = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, $col1, $col2, ... ) $x = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, [] ) ($x,$y,...) = rcols( *HANDLE|"filename", $col1, $col2, ..., { EXCLUDE => '/^!/' } ) ($x,$y,...) = rcols( *HANDLE|"filename", "/foo/", $col1, $col2, ... ) For each column number specified, a 1D output PDL will be generated. Anonymous arrays of column numbers generate 2D output piddles with dim0 for the column data and dim1 equal to the number of columns in the anonymous array(s). An empty anonymous array as column specification will produce a single output data piddle with dim(1) equal to the number of columns available. There are two calling conventions - the old version, where a pattern can be specified after the filename/handle, and the new version where options are given as as hash reference. This reference can be given as either the second or last argument. The default behaviour is to ignore lines beginning with a # character and lines that only consist of whitespace. Options exist to only read from lines that match, or do not match, supplied patterns, and to set the types of the created piddles. Can take file name or *HANDLE, and if no explicit column numbers are specified, all are assumed. For the allowed types, see L. Options (case insensitive): EXCLUDE or IGNORE - ignore lines matching this pattern (default B<'/^#/'>). INCLUDE or KEEP - only use lines which match this pattern (default B<''>). LINES - a string pattern specifying which line numbers to use. Line numbers start at 0 and the syntax is 'a:b:c' to use every c'th matching line between a and b (default B<''>). DEFTYPE - default data type for stored data (if not specified, use the type stored in C<$PDL::IO::Misc::deftype>, which starts off as B). TYPES - reference to an array of data types, one element for each column to be read in. Any missing columns use the DEFTYPE value (default B<[]>). COLSEP - splits on this string/pattern/qr{} between columns of data. Defaults to $PDL::IO::Misc::defcolsep. PERLCOLS - an array of column numbers which are to be read into perl arrays rather than piddles. Any columns not specified in the explicit list of columns to read will be returned after the explicit columns. (default B). COLIDS - if defined to an array reference, it will be assigned the column ID values obtained by splitting the first line of the file in the identical fashion to the column data. CHUNKSIZE - the number of input data elements to batch together before appending to each output data piddle (Default value is 100). If CHUNKSIZE is greater than the number of lines of data to read, the entire file is slurped in, lines split, and perl lists of column data are generated. At the end, effectively pdl(@column_data) produces any result piddles. VERBOSE - be verbose about IO processing (default C<$PDL::vebose>) =for example For example: $x = PDL->rcols 'file1'; # file1 has only one column of data $x = PDL->rcols 'file2', []; # file2 can have multiple columns, still 1 piddle output # (empty array ref spec means all possible data fields) ($x,$y) = rcols 'table.csv', { COLSEP => ',' }; # read CSV data file ($x,$y) = rcols *STDOUT; # default separator for lines like '32 24' # read in lines containing the string foo, where the first # example also ignores lines that begin with a # character. ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/' }; ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/', EXCLUDE => '' }; # ignore the first 27 lines of the file, reading in as ushort's ($x,$y) = rcols 'file3', { LINES => '27:-1', DEFTYPE => ushort }; ($x,$y) = rcols 'file3', { LINES => '27:', TYPES => [ ushort, ushort ] }; # read in the first column as a perl array and the next two as piddles # with the perl column returned after the piddle outputs ($x,$y,$name) = rcols 'file4', 1, 2 , { PERLCOLS => [ 0 ] }; printf "Number of names read in = %d\n", 1 + $#$name; # read in the first column as a perl array and the next two as piddles # with PERLCOLS changing the type of the first returned value to perl list ref ($name,$x,$y) = rcols 'file4', 0, 1, 2, { PERLCOLS => [ 0 ] }; # read in the first column as a perl array returned first followed by the # the next two data columns in the file as a single Nx2 piddle ($name,$xy) = rcols 'file4', 0, [1, 2], { PERLCOLS => [ 0 ] }; NOTES: 1. Quotes are required on patterns or use the qr{} quote regexp syntax. 2. Columns are separated by whitespace by default, use the COLSEP option separator to specify an alternate split pattern or string or specify an alternate default separator by setting C<$PDL::IO::Misc::defcolsep> . 3. Legacy support is present to use C<$PDL::IO::Misc::colsep> to set the column separator but C<$PDL::IO::Misc::colsep> is not defined by default. If you set the variable to a defined value it will get picked up. 4. LINES => '-1:0:3' may not work as you expect, since lines are skipped when read in, then the whole array reversed. 5. For consistency with wcols and rcols 1D usage, column data is loaded into the rows of the pdls (i.e., dim(0) is the elements read per column in the file and dim(1) is the number of columns of data read. =cut use vars qw/ $colsep $defcolsep $deftype /; $defcolsep = ' '; # Default column separator $deftype = double; # Default type for piddles my $defchunksize = 100; # Number of perl list items to append to piddle my $usecolsep; # This is the colsep value that is actually used # NOTE: XXX # need to look at the line-selection code. For instance, if want # lines => '-1:0:3', # read in all lines, reverse, then apply the step # -> fix point 4 above # # perhaps should just simplify the LINES option - ie remove # support for reversed arrays? sub rcols{ PDL->rcols(@_) } sub PDL::rcols { my $class = shift; barf 'Usage ($x,$y,...) = rcols( *HANDLE|"filename", ["/pattern/" or \%options], $col1, $col2, ..., [ \%options] )' if $#_<0; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; shift; # set up default options my $opt = new PDL::Options( { CHUNKSIZE => undef, COLIDS => undef, COLSEP => undef, DEFTYPE => $deftype, EXCLUDE => '/^#/', INCLUDE => undef, LINES => '', PERLCOLS => undef, TYPES => [], VERBOSE=> $PDL::verbose, } ); $opt->synonyms( { IGNORE => 'EXCLUDE', KEEP => 'INCLUDE' } ); # has the user supplied any options if ( defined($_[0]) ) { # ensure the old-style behaviour by setting the exclude pattern to undef if ( $_[0] =~ m|^/.*/$| ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "Regexp" ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "HASH" ) { $opt->options( shift ); } } # maybe the last element is a hash array as well $opt->options( pop ) if defined($_[-1]) and ref($_[-1]) eq "HASH"; # a reference to a hash array my $options = $opt->current(); # handle legacy colsep variable $usecolsep = (defined $colsep) ? qr{$colsep} : undef; $usecolsep = qr{$options->{COLSEP}} if $options->{COLSEP}; # what are the patterns? foreach my $pattern ( qw( INCLUDE EXCLUDE ) ) { if ( $options->{$pattern} and ref($options->{$pattern}) ne "Regexp" ) { if ( $options->{$pattern} =~ m|^/.*/$| ) { $options->{$pattern} =~ s|^/(.*)/$|$1|; $options->{$pattern} = qr($options->{$pattern}); } else { barf "rcols() - unable to process $pattern value.\n"; } } } # CHUNKSIZE controls memory/time tradeoff of piddle IO my $chunksize = $options->{CHUNKSIZE} || $defchunksize; my $nextburpindex = -1; # which columns are to be read into piddles and which into perl arrays? my @end_perl_cols = (); # unique perl cols to return at end my @perl_cols = (); # perl cols index list from PERLCOLS option @perl_cols = @{ $$options{PERLCOLS} } if $$options{PERLCOLS}; my @is_perl_col; # true if index corresponds to a perl column for (@perl_cols) { $is_perl_col[$_] = 1; }; # print STDERR "rcols: \@is_perl_col is @is_perl_col\n"; my ( @explicit_cols ) = @_; # call specified columns to read # print STDERR "rcols: \@explicit_cols is @explicit_cols\n"; # work out which line numbers are required # - the regexp's are a bit over the top my ( $a, $b, $c ); if ( $$options{LINES} ne '' ) { if ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*$/ ) { $a = $1; $b = $2; } elsif ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*:\s*([+]?\d*)\s*$/ ) { $a = $1; $b = $2; $c = $3; } else { barf "rcols() - unable to parse LINES option.\n"; } } # Since we do not know how many lines there are in advance, things get a bit messy my ( $index_start, $index_end ) = ( 0, -1 ); $index_start = $a if defined($a) and $a ne ''; $index_end = $b if defined($b) and $b ne ''; my $line_step = $c || 1; # $line_rev = 0/1 for normal order/reversed # $line_start/_end refer to the first and last line numbers that we want # (the values of which we may not know until we've read in all the file) my ( $line_start, $line_end, $line_rev ); if ( ($index_start >= 0 and $index_end < 0) ) { # eg 0:-1 $line_rev = 0; $line_start = $index_start; } elsif ( $index_end >= 0 and $index_start < 0 ) { # eg -1:0 $line_rev = 1; $line_start = $index_end; } elsif ( $index_end >= $index_start and $index_start >= 0 ) { # eg 0:10 $line_rev = 0; $line_start = $index_start; $line_end = $index_end; } elsif ( $index_start > $index_end and $index_end >= 0 ) { # eg 10:0 $line_rev = 1; $line_start = $index_end; $line_end = $index_start; } elsif ( $index_start <= $index_end ) { # eg -5:-1 $line_rev = 0; } else { # eg -1:-5 $line_rev = 1; } my @ret; my ($k,$fhline); my $line_num = -1; my $line_ctr = $line_step - 1; # ensure first line is always included my $index = -1; my $pdlsize = 0; my $extend = 10000; my $line_store; # line numbers of saved data RCOLS_IO: { if ($options->{COLIDS}) { print STDERR "rcols: processing COLIDS option\n" if $options->{VERBOSE}; undef $!; if (defined($fhline = <$fh>) ) { # grab first line's fields for column IDs $fhline =~ s/\r?\n$//; # handle DOS on unix files better my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); @{$options->{COLIDS}} = @v; } else { die "rcols: reading COLIDS info, $!" if $!; last RCOLS_IO; } } while( defined($fhline = <$fh>) ) { # chomp $fhline; $fhline =~ s/\r?\n$//; # handle DOS on unix files better $line_num++; # the order of these checks is important, particularly whether we # check for line_ctr before or after the pattern matching # Prior to PDL 2.003 the line checks were done BEFORE the # pattern matching # # need this first check, even with it almost repeated at end of loop, # incase the pattern matching excludes $line_num == $line_end, say last if defined($line_end) and $line_num > $line_end; next if defined($line_start) and $line_num < $line_start; next if $options->{EXCLUDE} and $fhline =~ /$options->{EXCLUDE}/; next if $options->{INCLUDE} and not $fhline =~ /$options->{INCLUDE}/; next unless ++$line_ctr == $line_step; $line_ctr = 0; $index++; my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); # map empty fields '' to undef value @v = map { $_ eq '' ? undef : $_ } @v; # if the first line, set up the output piddles using all the columns # if the user doesn't specify anything if ( $index == 0 ) { # Handle implicit multicolumns in command line if ($#explicit_cols < 0) { # implicit single col data @explicit_cols = ( 0 .. $#v ); } if (scalar(@explicit_cols)==1 and ref($explicit_cols[0]) eq "ARRAY") { if ( !scalar(@{$explicit_cols[0]}) ) { # implicit multi-col data @explicit_cols = ( [ 0 .. $#v ] ); } } my $implicit_pdls = 0; my $is_explicit = {}; foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY") { $implicit_pdls++ if !scalar(@$col); } else { $is_explicit->{$col} = 1; } } if ($implicit_pdls > 1) { die "rcols: only one implicit multicolumn piddle spec allowed, found $implicit_pdls!\n"; } foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY" and !scalar(@$col)) { @$col = grep { !$is_explicit->{$_} } ( 0 .. $#v ); } } # remove declared perl columns from pdl data list $k = 0; my @pdl_cols = (); foreach my $col (@explicit_cols) { # strip out declared perl cols so they won't be read into piddles if ( ref($col) eq "ARRAY" ) { @$col = grep { !$is_perl_col[$_] } @{$col}; push @pdl_cols, [ @{$col} ]; } elsif (!$is_perl_col[$col]) { push @pdl_cols, $col; } } # strip out perl cols in explicit col list for return at end @end_perl_cols = @perl_cols; foreach my $col (@explicit_cols) { if ( ref($col) ne "ARRAY" and defined($is_perl_col[$col]) ) { @end_perl_cols = grep { $_ != $col } @end_perl_cols; } }; # sort out the types of the piddles my @types = _handle_types( $#pdl_cols, $$options{DEFTYPE}, $$options{TYPES} ); if ( $options->{VERBOSE} ) { # dbg aid print "Reading data into piddles of type: [ "; foreach my $t ( @types ) { print $t->shortctype() . " "; } print "]\n"; } $k = 0; for (@explicit_cols) { # Using mixed list+piddle data structure for performance tradeoff # between memory usage (perl list) and speed of IO (PDL operations) if (ref($_) eq "ARRAY") { # use multicolumn piddle here push @ret, [ $class->zeroes($types[$k++],scalar(@{$_}),1), [] ]; } else { push @ret, ($is_perl_col[$_] ? [ [], [] ] : [ $class->zeroes($types[$k],1), [] ]); $k++ unless $is_perl_col[$_]; } } for (@end_perl_cols) { push @ret, [ [], [] ]; } $line_store = [ $class->zeroes(long,1), [] ]; # only need to store integers } # if necessary, extend PDL in buffered manner $k = 0; if ( $pdlsize < $index ) { for (@ret, $line_store) { _ext_lastD( $_->[0], $extend ); } $pdlsize += $extend; } # - stick perl arrays onto end of $ret $k = 0; for (@explicit_cols, @end_perl_cols) { if (ref($_) eq "ARRAY") { push @{ $ret[$k++]->[1] }, [ @v[ @$_ ] ]; } else { push @{ $ret[$k++]->[1] }, $v[$_]; } } # store the line number push @{$line_store->[1]}, $line_num; # need to burp out list if needed if ( $index >= $nextburpindex ) { for (@ret, $line_store) { _burp_1D($_,$index); } $nextburpindex = $index + $chunksize; } # Thanks to Frank Samuelson for this last if defined($line_end) and $line_num == $line_end; } } close($fh) unless $is_handle; # burp one final time if needed and # clean out additional ARRAY ref level for @ret for (@ret, $line_store) { _burp_1D($_,$index) if defined $_ and scalar @{$_->[1]}; $_ = $_->[0]; } # have we read anything in? if not, return empty piddles if ( $index == -1 ) { print "Warning: rcols() did not read in any data.\n" if $options->{VERBOSE}; if ( wantarray ) { foreach ( 0 .. $#explicit_cols ) { if ( $is_perl_col[$_] ) { $ret[$_] = PDL->null; } else { $ret[$_] = []; } } for ( @end_perl_cols ) { push @ret, []; } return ( @ret ); } else { return PDL->null; } } # if the user has asked for lines => 0:-1 or 0:10 or 1:10 or 1:-1, # - ie not reversed and the last line number is known - # then we can skip the following nastiness if ( $line_rev == 0 and $index_start >= 0 and $index_end >= -1 ) { for (@ret) { ## $_ = $_->mv(-1,0)->slice("0:${index}")->mv(0,-1) unless ref($_) eq 'ARRAY'; $_ = $_->mv(-1,0)->slice("0:${index}") unless ref($_) eq 'ARRAY'; # cols are dim(0) }; if ( $options->{VERBOSE} ) { if ( ref($ret[0]) eq 'ARRAY' ) { print "Read in ", scalar( @{ $ret[0] } ), " elements.\n"; } else { print "Read in ", $ret[0]->nelem, " elements.\n"; } } wantarray ? return(@ret) : return $ret[0]; } # Work out which line numbers we want. First we clean up the piddle # containing the line numbers that have been read in $line_store = $line_store->slice("0:${index}"); # work out the min/max line numbers required if ( $line_rev ) { if ( defined($line_start) and defined($line_end) ) { my $dummy = $line_start; $line_start = $line_end; $line_end = $dummy; } elsif ( defined($line_start) ) { $line_end = $line_start; } else { $line_start = $line_end; } } $line_start = $line_num + 1 + $index_start if $index_start < 0; $line_end = $line_num + 1 + $index_end if $index_end < 0; my $indices; { no warnings 'precedence'; if ( $line_rev ) { $indices = which( $line_store >= $line_end & $line_store <= $line_start )->slice('-1:0'); } else { $indices = which( $line_store >= $line_start & $line_store <= $line_end ); } } # truncate the piddles for my $col ( @explicit_cols ) { if ( ref($col) eq "ARRAY" ) { for ( @$col ) { $ret[$_] = $ret[$_]->index($indices); } } else { $ret[$col] = $ret[$col]->index($indices) unless $is_perl_col[$col] }; } # truncate/reverse/etc the perl arrays my @indices_array = list $indices; foreach ( @explicit_cols, @end_perl_cols ) { if ( $is_perl_col[$_] ) { my @temp = @{ $ret[$_] }; $ret[$_] = []; foreach my $i ( @indices_array ) { push @{ $ret[$_] }, $temp[$i] }; } } # print some diagnostics if ( $options->{VERBOSE} ) { my $done = 0; foreach my $col (@explicit_cols) { last if $done; next if $is_perl_col[$col]; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } foreach my $col (@explicit_cols, @end_perl_cols) { last if $done; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } } # fix 2D pdls to match what wcols generates foreach my $col (@ret) { next if ref($col) eq "ARRAY"; $col = $col->mv(0,1) if $col->ndims == 2; } wantarray ? return(@ret) : return $ret[0]; } =head2 wcols =for ref Write ASCII columns into file from 1D or 2D piddles and/or 1D listrefs efficiently. Can take file name or *HANDLE, and if no file/filehandle is given defaults to STDOUT. Options (case insensitive): HEADER - prints this string before the data. If the string is not terminated by a newline, one is added. (default B<''>). COLSEP - prints this string between columns of data. Defaults to $PDL::IO::Misc::defcolsep. FORMAT - A printf-style format string that is cycled through column output for user controlled formatting. =for usage Usage: wcols $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; # or wcols $format_string, $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; where the $dataN args are either 1D piddles, 1D perl array refs, or 2D piddles (as might be returned from rcols() with the [] column syntax and/or using the PERLCOLS option). dim(0) of all piddles written must be the same size. The printf-style $format_string, if given, overrides any FORMAT key settings in the option hash. e.g., =for example $x = random(4); $y = ones(4); wcols $x, $y+2, 'foo.dat'; wcols $x, $y+2, *STDERR; wcols $x, $y+2, '|wc'; $a = sequence(3); $b = zeros(3); $c = random(3); wcols $a,$b,$c; # Orthogonal version of 'print $a,$b,$c' :-) wcols "%10.3f", $a,$b; # Formatted wcols "%10.3f %10.5g", $a,$b; # Individual column formatting $a = sequence(3); $b = zeros(3); $units = [ 'm/sec', 'kg', 'MPH' ]; wcols $a,$b, { HEADER => "# a b" }; wcols $a,$b, { Header => "# a b", Colsep => ', ' }; # case insensitive option names! wcols " %4.1f %4.1f %s",$a,$b,$units, { header => "# Day Time Units" }; $a52 = sequence(5,2); $b = ones(5); $c = [ 1, 2, 4 ]; wcols $a52; # now can write out 2D pdls (2 columns data in output) wcols $b, $a52, $c # ...and mix and match with 1D listrefs as well NOTES: 1. Columns are separated by whitespace by default, use C<$PDL::IO::Misc::defcolsep> to modify the default value or the COLSEP option 2. Support for the C<$PDL::IO::Misc::colsep> global value of PDL-2.4.6 and earlier is maintained but the initial value of the global is undef until you set it. The value will be then be picked up and used as if defcolsep were specified. 3. Dim 0 corresponds to the column data dimension for both rcols and wcols. This makes wcols the reverse operation of rcols. =cut *wcols = \&PDL::wcols; sub PDL::wcols { barf 'Usage: wcols($optional_format_string, 1_or_2D_pdls, *HANDLE|"filename", [\%options])' if @_<1; # handle legacy colsep variable $usecolsep = (defined $colsep) ? $colsep : $defcolsep; # if last argument is a reference to a hash, parse the options my ($format_string, $step, $fh); my $header; if ( ref( $_[-1] ) eq "HASH" ) { my $opt = pop; foreach my $key ( keys %$opt ) { if ( $key =~ /^H/i ) { $header = $opt->{$key}; } # option: HEADER elsif ( $key =~ /^COLSEP/i ) { $usecolsep = $opt->{$key}; } # option: COLSEP elsif ( $key =~ /^FORMAT/i ) { $format_string = $opt->{$key}; } # option: FORMAT else { print "Warning: wcols does not understand option <$key>.\n"; } } } if (ref(\$_[0]) eq "SCALAR" || $format_string) { $format_string = shift if (ref(\$_[0]) eq "SCALAR"); # 1st arg not piddle, explicit format string overrides option hash FORMAT $step = $format_string; $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my $file = $_[-1]; my $file_opened; my $is_handle = !UNIVERSAL::isa($file,'PDL') && !UNIVERSAL::isa($file,'ARRAY') && _is_io_handle $file; if ($is_handle) { # file handle passed directly $fh = $file; pop; } else{ if (ref(\$file) eq "SCALAR") { # Must be a file name $fh = gensym; if (!$is_handle) { $file = ">$file" unless $file =~ /^\|/ or $file =~ /^\>/; open $fh, $file or barf "File $file can not be opened for writing\n"; } pop; $file_opened = 1; } else{ # Not a filehandle or filename, assume something else # (probably piddle) and send to STDOUT $fh = *STDOUT; } } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->dim(0); my @dogp = (); # need to break 2D pdls into a their 1D pdl components for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "wcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; push @dogp, $_; } else { barf "wcols: 1D args must have same number of elements\n" if $_->dim(0) != $n or $_->getndims > 2; if ( $_->getndims == 2 ) { push @dogp, $_->dog; } else { push @dogp, $_; } } } if ( defined $header ) { $header .= "\n" unless $header =~ m/\n$/; print $fh $header; } my $i; my $pcnt = scalar @dogp; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; my $pdone = 0; for (@dogp) { push @d,_at_1D($_,$i); $pdone++; if (@d == $step) { printf $fh $format_string,@d; printf $fh $usecolsep unless $pdone==$pcnt; $#d = -1; } } if (@d && !$i) { my $str; if ($#dogp>0) { $str = ($#dogp+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { my $pdone = 0; for (@dogp) { $pdone++; print $fh _at_1D($_,$i) . ( ($pdone==$pcnt) ? '' : $usecolsep ); } } print $fh "\n"; } close($fh) if $file_opened; return 1; } =head2 swcols =for ref generate string list from C format specifier and a list of piddles C takes an (optional) format specifier of the printf sort and a list of 1D piddles as input. It returns a perl array (or array reference if called in scalar context) where each element of the array is the string generated by printing the corresponding element of the piddle(s) using the format specified. If no format is specified it uses the default print format. =for usage Usage: @str = swcols format, pdl1,pdl2,pdl3,...; or $str = swcols format, pdl1,pdl2,pdl3,...; =cut *swcols = \&PDL::swcols; sub PDL::swcols{ my ($format_string,$step); my @outlist; if (ref(\$_[0]) eq "SCALAR") { $step = $format_string = shift; # 1st arg not piddle $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->nelem; for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "swcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; } else { barf "swcols: 1D args must have same number of elements\n" if $_->nelem != $n or $_->getndims!=1; } } my $i; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; for (@p) { push @d,_at_1D($_,$i); if (@d == $step) { push @outlist,sprintf $format_string,@d; $#d = -1; } } if (@d && !$i) { my $str; if ($#p>0) { $str = ($#p+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { for (@p) { push @outlist,sprintf _at_1D($_,$i),$usecolsep; } } } wantarray ? return @outlist: return \@outlist; } =head2 rgrep =for ref Read columns into piddles using full regexp pattern matching. Options: UNDEFINED: This option determines what will be done for undefined values. For instance when reading a comma-separated file of the type C<1,2,,4> where the C<,,> indicates a missing value. The default value is to assign C<$PDL::undefval> to undefined values, but if C is set this is used instead. This would normally be set to a number, but if it is set to C and PDL is compiled with Badvalue support (see L) then undefined values are set to the appropriate badvalue and the column is marked as bad. DEFTYPE: Sets the default type of the columns - see the documentation for L TYPES: A reference to a Perl array with types for each column - see the documentation for L BUFFERSIZE: The number of lines to extend the piddle by. It might speed up the reading a little bit by setting this to the number of lines in the file, but in general L is a better choice Usage =for usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename") e.g. =for example ($a,$b) = rgrep {/Foo (.*) Bar (.*) Mumble/} $file; i.e. the vectors C<$a> and C<$b> get the progressive values of C<$1>, C<$2> etc. =cut sub rgrep (&@) { barf 'Usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename", [{OPTIONS}])' if $#_ > 2; my (@ret,@v,$nret); my ($m,$n)=(-1,0); # Count/PDL size my $pattern = shift; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; if (ref($pattern) ne "CODE") { die "Got a ".ref($pattern)." for rgrep?!"; } # set up default options my $opt = new PDL::Options( { DEFTYPE => $deftype, TYPES => [], UNDEFINED => $PDL::undefval, BUFFERSIZE => 10000 } ); # Check if the user specified options my $u_opt = $_[1] || {}; $opt->options( $u_opt); my $options = $opt->current(); # If UNDEFINED is set to .*bad.* then undefined are set to # bad - unless we have a Perl that is not compiled with Bad support my $undef_is_bad = ($$options{UNDEFINED} =~ /bad/i); if ($undef_is_bad && !$PDL::Bad::Status) { carp "UNDEFINED cannot be set to Badvalue when PDL hasn't been compiled with Bad value support - \$PDL::undefval used instead\n"; $undef_is_bad = 0; } barf "Unknown PDL type given for DEFTYPE.\n" unless ref($$options{DEFTYPE}) eq "PDL::Type"; while(<$fh>) { next unless @v = &$pattern; $m++; # Count got if ($m==0) { $nret = $#v; # Last index of values to return # Handle various columns as in rcols - added 18/04/05 my @types = _handle_types( $nret, $$options{DEFTYPE}, $$options{TYPES} ); for (0..$nret) { # Modified 18/04/05 to use specified precision. $ret[$_] = [ PDL->zeroes($types[$_], 1), [] ]; } } else { # perhaps should only carp once... carp "Non-rectangular rgrep" if $nret != $#v; } if ($n<$m) { for (0..$nret) { _ext_lastD( $ret[$_]->[0], $$options{BUFFERSIZE} ); # Extend PDL in buffered manner } $n += $$options{BUFFERSIZE}; } for(0..$nret) { # Set values - '1*' is to ensure numeric # We now (JB - 18/04/05) also check for defined values or not # Ideally this should include Badvalue support.. if ($v[$_] eq '') { # Missing value - let us treat this specially if ($undef_is_bad) { set $ret[$_]->[0], $m, $$options{DEFTYPE}->badvalue(); # And set bad flag on $ref[$_]! $ret[$_]->[0]->badflag(1); } else { set $ret[$_]->[0], $m, $$options{UNDEFINED}; } } else { set $ret[$_]->[0], $m, 1*$v[$_]; } } } close($fh) unless $is_handle; for (@ret) { $_ = $_->[0]->slice("0:$m")->copy; }; # Truncate wantarray ? return(@ret) : return $ret[0]; } =head2 rdsa =for ref Read a FIGARO/NDF format file. Requires non-PDL DSA module. Contact Frossie (frossie@jach.hawaii.edu) Usage: =for usage ([$xaxis],$data) = rdsa($file) =for example $a = rdsa 'file.sdf' Not yet tested with PDL-1.9X versions =cut sub rdsa{PDL->rdsa(@_)} use vars qw/ $dsa_loaded /; sub PDL::rdsa { my $class = shift; barf 'Usage: ([$xaxis],$data) = rdsa($file)' if $#_!=0; my $file = shift; my $pdl = $class->new; my $xpdl; eval 'use DSA' unless $dsa_loaded++; barf 'Cannot use DSA library' if $@ ne ""; my $status = 0; # Most of this stuff stolen from Frossie: dsa_open($status); dsa_named_input('IMAGE',$file,$status); goto skip if $status != 0; dsa_get_range('IMAGE',my $vmin,my $vmax,$status); my @data_dims; dsa_data_size('IMAGE',5, my $data_ndims, \@data_dims, my $data_elements, $status); dsa_map_data('IMAGE','READ','FLOAT',my $data_address,my $data_slot, $status); @data_dims = @data_dims[0..$data_ndims-1]; print "Dims of $file = @data_dims\n" if $PDL::verbose; $pdl->set_datatype($PDL_F); $pdl->setdims([@data_dims]); my $dref = $pdl->get_dataref; mem2string($data_address,4*$data_elements,$$dref); $pdl->upd_data(); if (wantarray) { # Map X axis values my @axis_dims; dsa_axis_size('IMAGE',1,5, my $axis_ndims, \@axis_dims, my $axis_elements, $status); dsa_map_axis_data('IMAGE',1,'READ','FLOAT',my $axis_address, my $axis_slot,$status); @axis_dims = @axis_dims[0..$axis_ndims-1]; $xpdl = $class->new; $xpdl->set_datatype($PDL_F); $xpdl->setdims([@axis_dims]); my $xref = $xpdl->get_dataref; mem2string($axis_address,4*$axis_elements,$$xref); $xpdl->upd_data(); } skip: dsa_close($status); barf("rdsa: obtained DSA error") if $status != 0; return ($xpdl,$pdl); } =head2 isbigendian =for ref Determine endianness of machine - returns 0 or 1 accordingly =cut !NO!SUBS! # $isbigendian is set up at top of file pp_addpm( "sub PDL::isbigendian { return $isbigendian; };\n*isbigendian = \\&PDL::isbigendian;\n"); pp_add_exported("", "isbigendian"); ################################ XS CODE ###################################### sub defpdl { pp_def( $_[0], Pars => $_[1], OtherPars => $_[2], Code => $_[3], Doc => $_[4], ); } ###### Read ASCII Function ########## pp_addhdr(<<'EOH'); #define SWALLOWLINE(fp) while ((s = PerlIO_getc(fp)) != '\n' && s != EOF) #define TRAILING_WHITESPACE_CHECK(s) \ if (s!=' ' && s!='\t' && s!='\r' && s!='\n' && s!=',') return -1 int getfloat(PerlIO *fp, PDL_Float *fz) { PDL_Float f = 0; int nread = 0; int i, s = PerlIO_getc(fp); int afterp = 0, aftere=0; int expo = 0; PDL_Float sig = 1.0, esig = 1.0; PDL_Float div = 1.0; if (s == EOF) return 0; while (1) { if (s == EOF) return 0; /* signal end of line */ if (s == '#') SWALLOWLINE(fp); if ((s >='0' && s <='9') || s =='.' || s == 'e' || s == 'E' || s == '+' || s == '-') break; if (s!=' ' && s!='\t' && s!='\r' && s!='\n' && s!=',') return -1; /* garbage */ s = PerlIO_getc(fp); /* else skip whitespace */ } /* parse number */ while (1) { switch (s) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (aftere) expo = (expo*10) + (s - '0'); else if (afterp) { div /= 10.0; f += div*(s - '0'); } else f = (f*10) + (s - '0'); break; case '+': /* ignore */ break; case '-': if (aftere) esig = -1; else sig = -1; break; case 'e': case 'E': if (aftere) return -1; aftere = 1; break; case '.': if (afterp || aftere) return -1; afterp = 1; break; default: goto endread; break; } nread++; s = PerlIO_getc(fp); } endread: f *= sig; for (i=0;i 0 ? 10.0 : 0.1); *fz = f; TRAILING_WHITESPACE_CHECK(s); return nread; } int getdouble(PerlIO *fp, PDL_Double *fz) { PDL_Double f = 0; int nread = 0; int i, s = PerlIO_getc(fp); int afterp = 0, aftere=0; int expo = 0; PDL_Double sig = 1.0, esig = 1.0; PDL_Double div = 1.0; if (s == EOF) return 0; while (1) { if (s == EOF) return 0; /* signal end of line */ if (s == '#') SWALLOWLINE(fp); if ((s >='0' && s <='9') || s =='.' || s == 'e' || s == 'E' || s == '+' || s == '-') break; if (s!=' ' && s!='\t' && s!='\r' && s!='\n' && s!=',') return -1; /* garbage */ s = PerlIO_getc(fp); /* else skip whitespace */ } /* parse number */ while (1) { switch (s) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (aftere) expo = (expo*10) + (s - '0'); else if (afterp) { div /= 10.0; f += div*(s - '0'); } else f = (f*10) + (s - '0'); break; case '+': /* ignore */ break; case '-': if (aftere) esig = -1; else sig = -1; break; case 'e': case 'E': if (aftere) return -1; aftere = 1; break; case '.': if (afterp || aftere) return -1; afterp = 1; break; default: goto endread; break; } nread++; s = PerlIO_getc(fp); } endread: f *= sig; for (i=0;i 0 ? 10.0 : 0.1); *fz = f; TRAILING_WHITESPACE_CHECK(s); return nread; } EOH pp_add_exported('', 'rasc rcube'); pp_addpm(<<'EOPM'); =head2 rasc =for ref Simple function to slurp in ASCII numbers quite quickly, although error handling is marginal (to nonexistent). =for usage $pdl->rasc("filename"|FILEHANDLE [,$noElements]); Where: filename is the name of the ASCII file to read or open file handle $noElements is the optional number of elements in the file to read. (If not present, all of the file will be read to fill up $pdl). $pdl can be of type float or double (for more precision). =for example # (test.num is an ascii file with 20 numbers. One number per line.) $in = PDL->null; $num = 20; $in->rasc('test.num',20); $imm = zeroes(float,20,2); $imm->rasc('test.num'); =cut sub rasc {PDL->rasc(@_)} sub PDL::rasc { use IO::File; my ($pdl, $file, $num) = @_; $num = -1 unless defined $num; my $fi = $file; my $is_openhandle = defined fileno $fi ? 1 : 0; unless ($is_openhandle) { barf 'usage: rasc $pdl, "filename"|FILEHANDLE, [$num_to_read]' if !defined $file || ref $file; $fi = new IO::File "<$file" or barf "Can't open $file"; } $pdl->_rasc(my $ierr=null,$num,$fi); close $fi unless $is_openhandle; return all $ierr > 0; } # ---------------------------------------------------------- =head2 rcube =for ref Read list of files directly into a large data cube (for efficiency) =for usage $cube = rcube \&reader_function, @files; =for example $cube = rcube \&rfits, glob("*.fits"); This IO function allows direct reading of files into a large data cube, Obviously one could use cat() but this is more memory efficient. The reading function (e.g. rfits, readfraw) (passed as a reference) and files are the arguments. The cube is created as the same X,Y dims and datatype as the first image specified. The Z dim is simply the number of images. =cut sub rcube { my $reader = shift; barf "Usage: blah" unless ref($reader) eq "CODE"; my $k=0; my ($im,$cube,$tmp,$nx,$ny); my $nz = scalar(@_); for my $file (@_) { print "Slice ($k) - reading file $file...\n" if $PDL::verbose; $im = &$reader($file); ($nx, $ny) = dims $im; if ($k == 0) { print "Creating $nx x $ny x $nz cube...\n" if $PDL::verbose; $cube = $im->zeroes($im->type,$nx,$ny,$nz); } else { barf "Dimensions do not match for file $file!\n" if $im->getdim(0) != $nx or $im->getdim(1) != $ny ; } $tmp = $cube->slice(":,:,($k)"); $tmp .= $im; $k++; } return $cube; } EOPM # in the future this function should return a state indicating an error # if appropriate pp_def('_rasc', Pars => '[o] nums(n); int [o] ierr(n)', OtherPars => 'int num => n; SV* fd', GenericTypes => [F,D], Code => q@ int ns, i, j; PerlIO *fp; IO *io; /* io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO)); */ io = sv_2io($COMP(fd)); if (!io || !(fp = IoIFP(io))) croak("Can\'t figure out FP"); ns = $SIZE(n); threadloop %{ for (i=0;ii) = $TFD(getfloat,getdouble)(fp, &($nums(n=>i)))) <= 0) break; } for (j=i+1; jj) = $ierr(n=>i); /* inherit error flags */ %} @, # Doc => 'Internal Function used by rasc. ' Doc => undef, ); pp_done(); PDL-2.018/IO/Pnm/0000755060175006010010000000000013110402046011424 5ustar chmNonePDL-2.018/IO/Pnm/Makefile.PL0000644060175006010010000000050412562522364013415 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["pnm.pd", qw(Pnm PDL::IO::Pnm)]); my %hash = pdlpp_stdargs_int(@pack); $hash{'PM'}->{'Pic.pm'} = '$(INST_LIBDIR)/Pic.pm'; # Add genpp rule undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/IO/Pnm/Pic.pm0000644060175006010010000007245713036512175012530 0ustar chmNone=head1 NAME PDL::IO::Pic -- image I/O for PDL =head1 DESCRIPTION =head2 Image I/O for PDL based on the netpbm package. This package implements I/O for a number of popular image formats by exploiting the xxxtopnm and pnmtoxxx converters from the netpbm package (which is based on the original pbmplus by Jef Poskanzer). Netpbm is available at ftp://wuarchive.wustl.edu/graphics/graphics/packages/NetPBM/ Pbmplus (on which netpbm is based) might work as well, I haven't tried it. If you want to read/write JPEG images you additionally need the two converters cjpeg/djpeg which come with the libjpeg distribution (the "official" archive site for this software is L). Image I/O for all formats is established by reading and writing only the PNM format directly while the netpbm standalone apps take care of the necessary conversions. In accordance with netpbm parlance PNM stands here for 'portable any map' meaning any of the PBM/PGM/PPM formats. As it appeared to be a reasonable place this package also contains the routine wmpeg to write mpeg movies from PDLs representing image stacks (the image stack is first written as a sequence of PPM images into some temporary directory). For this to work you need the program ffmpeg also. =cut package PDL::IO::Pic; @EXPORT_OK = qw( wmpeg rim wim rpic wpic rpiccan wpiccan ); %EXPORT_TAGS = (Func => [@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use PDL::Types; use PDL::ImageRGB; use PDL::IO::Pnm; use PDL::Options; use PDL::Config; use File::Basename; use SelfLoader; use File::Spec; use strict; use vars qw( $Dflags @ISA %converter ); @ISA = qw( PDL::Exporter ); =head2 Configuration The executables from the netpbm package are assumed to be in your path. Problems in finding the executables may show up as PNM format errors when calling wpic/rpic. If you run into this kind of problem run your program with perl C<-w> so that perl prints a message if it can't find the filter when trying to open the pipe. ['] =cut # list of converters by type # might get more fields in the future to provide a generic representation # of common flags like COMPRESSION, LUT, etc which would hold the correct # flags for the particular converter or NA if not supported # conventions: # NONE we need no converter (directly supported format) # NA feature not available # 'whatevertopnm' name of the executable # The 'FLAGS' key must be used if the converter needs other flags than # the default flags ($Dflags) # # # The "referral" field, if present, contains a within-perl referral # to other methods for reading/writing the PDL as that type of file. The # methods must have the same syntax as wpic/rpic (e.g. wfits/rfits). # $PDL::IO::Pic::debug = $PDL::IO::Pic::debug || 0; &init_converter_table(); # setup functions sub init_converter_table { # default flag to be used with any converter unless overridden with FLAGS $Dflags = ''; %converter = (); # Pbmplus systems have cjpeg/djpeg; netpbm systems have pnmtojpeg and # jpegtopnm. my $jpeg_conv=''; { my @path = File::Spec->path(); my $ext = $^O =~ /MSWin/i ? '.exe' : ''; local $_; my $pbmplus; for (@path) { $jpeg_conv="cjpeg" if ( -x "$_/cjpeg" . $ext ); $jpeg_conv="pnmtojpeg" if ( -x "$_/pnmtojpeg" . $ext ); } } my @normal = qw/TIFF SGI RAST PCX PNG/; push(@normal,"JPEG") if($jpeg_conv eq 'pnmtojpeg'); for (@normal) { my $conv = lc; $converter{$_} = {put => "pnmto$conv", get => "$conv".'topnm'} } my @special = (['PNM','NONE','NONE'], ['PS','pnmtops -dpi=100', 'pstopnm -stdout -xborder=0 -yborder=0 -quiet -dpi=100'], ['GIF','ppmtogif','giftopnm'], ['IFF','ppmtoilbm','ilbmtoppm'] ); push(@special,['JPEG', 'cjpeg' ,'djpeg']) if($jpeg_conv eq 'cjpeg'); for(@special) { $converter{$_->[0]} = {put => $_->[1], get => $_->[2]} } $converter{'FITS'}={ 'referral' => {'put' => \&PDL::wfits, 'get' => \&PDL::rfits} }; # these converters do not understand pbmplus flags: $converter{'JPEG'}->{FLAGS} = ''; $converter{'GIF'}->{Prefilt} = 'ppmquant 256 |'; my $key; for $key (keys %converter) { $converter{$key}->{Rok} = inpath($converter{$key}->{'get'}) if defined($converter{$key}->{'get'}); $converter{$key}->{Wok} = inpath($converter{$key}->{'put'}) if defined($converter{$key}->{'put'}); if (defined $converter{$key}->{Prefilt}) { my $filt = $1 if $converter{$key}->{Prefilt} =~ /^\s*(\S+)\s+/; $converter{$key}->{Wok} = inpath($filt) if $converter{$key}->{Wok}; } } $PDL::IO::Pic::biggrays = &hasbiggrays(); print "using big grays\n" if $PDL::IO::Pic::debug && $PDL::IO::Pic::biggrays; for (keys %converter) { $converter{$_}->{ushortok} = $PDL::IO::Pic::biggrays ? (m/GIF/ ? 0 : 1) : (m/GIF|RAST|IFF/ ? 0 : 1); } } sub inpath { my ($prog) = @_; my $pathsep = $^O =~ /win32/i ? ';' : ':'; my $exe = $^O =~ /win32/i ? '.exe' : ''; for(split $pathsep,$ENV{PATH}){return 1 if -x "$_/$prog$exe" || $prog =~ /^NONE$/} return 0; } sub hasbiggrays { my ($checked,$form) = (0,''); require IO::File; for (&rpiccan()) { next if /^PNM$/; $form = $_; $checked=1; last } unless ($checked) { warn "PDL::IO::Pic - couldn't find any pbm converter" if $PDL::IO::Pic::debug; return 0; } *SAVEERR = *SAVEERR; # stupid fix to shut up -w (AKA pain-in-the-...-flag) open(SAVEERR, ">&STDERR"); my $tmp = new_tmpfile IO::File or barf "couldn't open tmpfile"; my $pos = $tmp->getpos; my $txt; { local *IN; *IN = *$tmp; # doesn't seem to work otherwise open(STDERR,">&IN") or barf "couldn't redirect stdder"; system("$converter{$form}->{get} -version"); open(STDERR, ">&PDL::IO::Pic::SAVEERR"); $tmp->setpos($pos); # rewind $txt = join '',; close IN; undef $tmp; } return ($txt =~ /PGM_BIGGRAYS/); } =head1 FUNCTIONS =head2 rpiccan, wpiccan =for ref Test which image formats can be read/written =for example $im = PDL->rpic('PDL.jpg') if PDL->rpiccan('JPEG'); @wformats = PDL->wpiccan(); finds out if PDL::IO::Pic can read/write certain image formats. When called without arguments returns a list of supported formats. When called with an argument returns true if format is supported on your computer (requires appropriate filters in your path), false otherwise. =cut sub rpiccan {return PDL->rpiccan(@_)} sub wpiccan {return PDL->wpiccan(@_)} sub PDL::rpiccan {splice @_,1,0,'R'; return PDL::IO::Pic::piccan(@_)} sub PDL::wpiccan {splice @_,1,0,'W'; return PDL::IO::Pic::piccan(@_)} =head2 rpic =for ref Read images in many formats with automatic format detection. =for example $im = rpic $file; $im = PDL->rpic 'PDL.jpg' if PDL->rpiccan('JPEG'); I =for opt FORMAT => 'JPEG' # explicitly read this format XTRAFLAGS => '-nolut' # additional flags for converter Reads image files in most of the formats supported by netpbm. You can explicitly specify a supported format by additionally passing a hash containing the FORMAT key as in $im = rpic ($file, {FORMAT => 'GIF'}); This is especially useful if the particular format isn't identified by a magic number and doesn't have the 'typical' extension or you want to avoid the check of the magic number if your data comes in from a pipe. The function returns a pdl of the appropriate type upon completion. Option parsing uses the L module and therefore supports minimal options matching. You can also read directly into an existing pdl that has to have the right size(!). This can come in handy when you want to read a sequence of images into a datacube, e.g. $stack = zeroes(byte,3,500,300,4); rpic $stack->slice(':,:,:,(0)'),"PDL.jpg"; reads an rgb image (that had better be of size (500,300)) into the first plane of a 3D RGB datacube (=4D pdl datacube). You can also do transpose/inversion upon read that way. =cut my $rpicopts = { FORMAT => undef, XTRAFLAGS => undef, }; sub rpic {PDL->rpic(@_)} sub PDL::rpic { barf 'Usage: $im = rpic($file[,hints]) or $im = PDL->rpic($file[,hints])' if $#_<0; my ($class,$file,$hints,$maybe) = @_; my ($type, $pdl); if (ref($file)) { # $file is really a pdl in this case $pdl = $file; $file = $hints; $hints = $maybe; } else { $pdl = $class->initialize; } $hints = { iparse $rpicopts, $hints } if ref $hints; if (defined($$hints{'FORMAT'})) { $type = $$hints{'FORMAT'}; barf "unsupported (input) image format" unless (exists($converter{$type}) && $converter{$type}->{'get'} !~ /NA/); } else { $type = chkform($file); barf "can't figure out file type, specify explicitly" if $type =~ /UNKNOWN/; } my($converter) = $PDL::IO::Pic::converter; if (defined($converter{$type}->{referral})) { if(ref ($converter{$type}->{referral}->{'get'}) eq 'CODE') { return &{$converter{$type}->{referral}->{'get'}}(@_); } else { barf "rpic: internal error with referral (format is $type)\n"; } } my $flags = $converter{$type}->{FLAGS}; $flags = "$Dflags" unless defined($flags); $flags .= " $$hints{XTRAFLAGS}" if defined($$hints{XTRAFLAGS}); my $cmd = "$converter{$type}->{get} $flags $file |"; $cmd = $file if $converter{$type}->{'get'} =~ /^NONE/; print("conversion by '$cmd'\n") if $PDL::IO::Pic::debug > 10; return rpnm($pdl,$cmd); } =head2 wpic =for ref Write images in many formats with automatic format selection. =for usage Usage: wpic($pdl,$filename[,{ options... }]) =for example wpic $pdl, $file; $im->wpic('web.gif',{LUT => $lut}); for (@images) { $_->wpic($name[0],{CONVERTER => 'ppmtogif'}) } Write out an image file. Function will try to guess correct image format from the filename extension, e.g. $pdl->wpic("image.gif") will write a gif file. The data written out will be scaled to byte if input is of type float/double. Input data that is of a signed integer type and contains negative numbers will be rejected (assuming the user should have the desired conversion to an unsigned type already). A number of options can be specified (as a hash reference) to get more direct control of the image format that is being written. Valid options are (key => example_value): =for options CONVERTER => 'ppmtogif', # explicitly specify pbm converter FLAGS => '-interlaced -transparent 0', # flags for converter IFORM => 'PGM', # explicitly specify intermediate format XTRAFLAGS => '-imagename iris', # additional flags to defaultflags FORMAT => 'PCX', # explicitly specify output image format COLOR => 'bw', # specify color conversion LUT => $lut, # use color table information Option parsing uses the L module and therefore supports minimal options matching. A detailed explanation of supported options follows. =over 7 =item CONVERTER directly specify the converter, you had better know what you are doing, e.g. CONVERTER => 'ppmtogif', =item FLAGS flags to use with the converter; ignored if !defined($$hints{CONVERTER}), e.g. with the gif format FLAGS => '-interlaced -transparent 0', =item IFORM intermediate PNM/PPM/PGM/PBM format to use; you can append the strings 'RAW' or 'ASCII' to enforce those modes, eg IFORMAT=>'PGMRAW' or IFORM => 'PGM', =item XTRAFLAGS additional flags to use with an automatically chosen converter, this example works when you write SGI files (but will give an error otherwise) XTRAFLAGS => '-imagename iris', =item FORMAT explicitly select the format you want to use. Required if wpic cannot figure out the desired format from the file name extension. Supported types are currently TIFF,GIF,SGI,PNM,JPEG,PS,RAST(Sun Raster),IFF,PCX, e.g. FORMAT => 'PCX', =item COLOR you want black and white (value B), other possible value is B which will write a dithered black&white image from the input data, data conversion will be done appropriately, e.g. COLOR => 'bw', =item LUT This is a palette image and the value of this key should be a pdl containing an RGB lookup table (3,x), e.g. LUT => $lut, =back Using the CONVERTER hint you can also build a pipe and perform several netpbm operations to get the special result you like. Using it this way the first converter/filecommand in the pipe should be specified with the CONVERTER hint and subsequent converters + flags in the FLAGS hint. This is because wpic tries to figure out the required format to be written by wpnm based on the first converter. Be careful when using the PBMBIN var as it will only be prepended to the converter. If more converters are in the FLAGS part specify the full path unless they are in your PATH anyway. Example: $im->wpic('test.ps',{CONVERTER => 'pgmtopbm', FLAGS => "-dither8 | pnmtops" }) Some of the options may appear silly at the moment and probably are. The situation will hopefully improve as people use the code and the need for different/modified options becomes clear. The general idea is to make the function perl compliant: easy things should be easy, complicated tasks possible. =cut my %wpicopts = map {($_ => undef)} qw/IFORM CONVERTER FLAGS FORMAT XTRAFLAGS COLOR LUT/; my $wpicopts = \%wpicopts; *wpic = \&PDL::wpic; sub PDL::wpic { barf 'Usage: wpic($pdl,$filename[,$hints]) ' . 'or $pdl->wpic($filename,[,$hints])' if $#_<1; my ($pdl,$file,$hints) = @_; my ($type, $cmd, $form,$iform,$iraw); $hints = {iparse($wpicopts, $hints)} if ref $hints; # figure out the right converter my ($conv, $flags, $format, $referral) = getconv($pdl,$file,$hints); if(defined($referral)) { if(ref ($referral->{'put'}) eq 'CODE') { return &{$referral->{'put'}}(@_); } else { barf "wpic: internal error with referral (format is $format)\n"; } } print "Using the command $conv with the flags $flags\n" if $PDL::IO::Pic::debug>10; if (defined($$hints{IFORM})) { $iform = $$hints{IFORM}; } else { # check if converter requires a particular intermediate format $iform = 'PPM' if $conv =~ /^\s*(ppm)|(cjpeg)/; $iform = 'PGM' if $conv =~ /^\s*pgm/; $iform = 'PBM' if $conv =~ /^\s*pbm/; $iform = 'PNM' if $conv =~ /^\s*(pnm)|(NONE)/; } # get final values for $iform and $pdl (check conversions, consistency,etc) ($pdl,$iform) = chkpdl($pdl,$iform,$hints,$format); print "using intermediate format $iform\n" if $PDL::IO::Pic::debug>10; $cmd = "|" . "$conv $flags >$file"; $cmd = ">" . $file if $conv =~ /^NONE/; print "built the command $cmd to write image\n" if $PDL::IO::Pic::debug>10; $iraw = 1 if (defined($$hints{IFORM}) && $$hints{IFORM} =~ /RAW/); $iraw = 0 if (defined($$hints{IFORM}) && $$hints{IFORM} =~ /ASCII/); local $SIG{PIPE}= sub {}; # Prevent crashing if converter dies wpnm($pdl, $cmd, $iform , $iraw); } =head2 rim =for usage Usage: $a = rim($file); or rim($a,$file); =for ref Read images in most formats, with improved RGB handling. You specify a filename and get back a PDL with the image data in it. Any PNM handled format or FITS will work. In the second form, $a is an existing PDL that gets loaded with the image data. If the image is in one of the standard RGB formats, then you get back data in (,,) format -- that is to say, the third dim contains the color information. That allows you to do simple indexing into the image without knowing whether it is color or not -- if present, the RGB information is silently threaded over. (Contrast L, which munges the information by putting the RGB index in the 0th dim, screwing up subsequent threading operations). If the image is in FITS format, then you get the data back in exactly the same order as in the file itself. Images with a ".Z" or ".gz" extension are assumed to be compressed with UNIX L<"compress"|compress> or L<"gzip"|gzip>, respecetively, and are automatically uncompressed before reading. OPTIONS The same as L, which is used as an engine: =over 3 =item FORMAT If you don't specify this then formats are autodetected. If you do specify it then only the specified interpreter is tried. For example, $a = rim("foo.gif",{FORMAT=>"JPEG"}) forces JPEG interpretation. =item XTRAFLAGS Contains extra command line flags for the pnm interpreter. For example, $a = rim("foo.jpg",{XTRAFLAGS=>"-nolut"}) prevents use of a lookup table in JPEG images. =back =cut use PDL::IO::Pic; sub rim { my(@args) = @_; my $out; ## Handle dest-PDL-first case if(@args >= 2 and (UNIVERSAL::isa($args[0],'PDL'))) { my $dest = shift @args; my $rpa = PDL->null; $out = rpic(@args); if($out->ndims == 3 && $out->dim(0) == 3 && !( defined($out->gethdr) && $out->gethdr->{SIMPLE} ) ) { $out = $out->reorder(1,2,0); } $dest .= $out; return $out; } # Handle no-first-PDL case $out = rpic(@args); if($out->ndims == 3 && $out->dim(0) == 3 && !( defined($out->gethdr) && $out->gethdr->{SIMPLE} ) ) { return $out->reorder(1,2,0); } $out; } =head2 wim =for ref Write a pdl to an image file with selected type (or using filename extensions) =for usage wim $pdl,$file; $pdl->wim("foo.gif",{LUT=>$lut}); Write out an image file. You can specify the format explicitly as an option, or the function will try to guess the correct image format from the filename extension, e.g. $pdl->wim("image.gif"); $pdl->wim("image.fits"); will write a gif and a FITS file. The data written out will be scaled to byte if the input if of type float/double. Input data that is of a signed integer type and contains negative numbers will be rejected. If you append C<.gz> or C<.Z> to the end of the file name, the final file will be automatically compresed with L<"gzip"|gzip> | L<"compress"|compress>, respectively. OPTIONS You can pass in a hash ref whose keys are options. The code uses the PDL::Options module so unique abbreviations are accepted. Accepted keys are the same as for L, which is used as an engine: =over 3 =item CONVERTER Names the converter program to be used by pbmplus (e.g. "ppmtogif" to output a gif file) =item FLAGS Flags that should be passed to the converter (replacing any default flag list) e.g. "-interlaced" to make an interlaced GIF =item IFORM Explicitly specifies the intermediate format (e.g. PGM, PPM, or PNM). =item XTRAFLAGS Flags that should be passed to the converter (in addition to any default flag list). =item FORMAT Explicitly specifies the output image format (allowing pbmplus to pick an output converter) =item COLOR Specifies color conversion (e.g. 'bw' converts to black-and-white; see L for details). =item LUT Use color-table information =back =cut *wim = \&PDL::wim; sub PDL::wim { my(@args) = @_; my($im) = $args[0]; $args[0] = $im->reorder(2,0,1) if( $im->ndims == 3 and $im->dim(2)==3 and !( ( $args[1] =~ m/\.fits$/i ) or ( ref $args[2] eq 'HASH' and $args[2]->{FORMAT} =~ m/fits/i ) ) ); wpic(@args); } =head2 wmpeg =for ref Write an image sequence (a (3,x,y,n) byte pdl) as an animation. =for usage $piddle->wmpeg('movie.mpg'); # $piddle is (3,x,y,nframes) byte Writes a stack of RGB images as a movie. While the format generated is nominally MPEG, the file extension is used to determine the video encoder type. E.g.: .mpg for MPEG-1 encoding .mp4 for MPEG-4 encoding And even: .gif for GIF animation (uncompressed) C requires a 4-D pdl of type B as input. The first dim B to be of size 3 since it will be interpreted as RGB pixel data. C returns 1 on success and undef on failure. =for example $anim->wmpeg("GreatAnimation.mpg") or die "can't create mpeg1 output"; $anim->wmpeg("GreatAnimation.mp4") or die "can't create mpeg4 output"; Some of the input data restrictions will have to be relaxed in the future but routine serves as a proof of principle at the moment. It uses the program ffmpeg to encode the frames into video. The arguments and parameters used for ffmpeg have not been tuned. This is a first implementation replacing mpeg_encode by ffmpeg. Currently, wmpeg doesn't allow modification of the parameters written through its calling interface. This will change in the future as needed. In the future it might be much nicer to implement a movie perl object that supplies methods for manipulating the image stack (insert, cut, append commands) and a final movie->make() call would invoke ffmpeg on the picture stack (which will only be held on disk). This should get around the problem of having to hold a huge amount of data in memory to be passed into wmpeg (when you are, e.g. writing a large animation from PDL3D rendered fly-throughs). Having said that, the actual storage requirements might not be so big in the future any more if you could pass 'virtual' transform pdls into wmpeg that will only be actually calculated when accessed by the wpic routines, you know what I mean... =cut *wmpeg = \&PDL::wmpeg; sub PDL::wmpeg { barf 'Usage: wmpeg($pdl,$filename) ' . 'or $pdl->wmpeg($filename)' if $#_ != 1; my ($pdl,$file) = @_; # return undef if no ffmpeg in path if (! inpath('ffmpeg')) { warn("wmpeg: ffmpeg not found in PATH"); return; } my @Dims = $pdl->dims; # too strict in general but alright for the moment # especially restriction to byte will have to be relaxed barf "input must be byte (3,x,y,z)" if (@Dims != 4) || ($Dims[0] != 3) || ($pdl->get_datatype != $PDL_B); my $nims = $Dims[3]; my $tmp = gettmpdir(); # get tmpdir for parameter file # see PDL-2.4.6 version for original code # check the pdl for correct dimensionality # write all the images as ppms and write the appropriate parameter file my ($i,$fname); # add blank cells to each image to fit with 16N x 16N mpeg standard # $frame is full frame, insert each image in as $inset my (@MDims) = (3,map(16*int(($_+15)/16),@Dims[1..2])); my ($frame) = zeroes(byte,@MDims); my ($inset) = $frame->slice(join(',', map(int(($MDims[$_]-$Dims[$_])/2).':'. int(($MDims[$_]+$Dims[$_])/2-1),0..2))); my $range = sprintf "[%d-%d]",0,$nims-1; local $SIG{PIPE} = 'IGNORE'; open MPEG, "| ffmpeg -f image2pipe -vcodec ppm -i - $file" or barf "spawning ffmpeg failed: $?"; binmode MPEG; # select ((select (MPEG), $| = 1)[0]); # may need for win32 my (@slices) = $pdl->dog; for ($i=0; $i<$nims; $i++) { local $PDL::debug = 1; print STDERR "Writing frame $i, " . $frame->slice(':,:,-1:0')->clump(2)->info . "\n"; $inset .= $slices[$i]; print MPEG "P6\n$MDims[1] $MDims[2]\n255\n"; pnmout($frame->slice(':,:,-1:0')->clump(2), 1, 0, 'PDL::IO::Pic::MPEG'); } # clean up close MPEG; # rm tmpdir and files if needed return 1; } 1; # Return OK status __DATA__ # SelfLoaded code sub piccan { my $class = shift; my $rw = (shift =~ /r/i) ? 'Rok' : 'Wok'; if ($#_ > -1) { my $format = shift; barf 'unknown format' unless defined($converter{$format}); return $converter{$format}->{$rw}; } else { my @formats = (); for (keys %converter) {push @formats, $_ if $converter{$_}->{$rw}} return @formats; } } sub getext { # changed to a more os independent way my $file = shift; my ($base,$dir,$ext) = fileparse($file,'\.[^.]*'); $ext = $1 if $ext =~ /^.([^;]*)/; # chop off VMS version numbers return $ext; } # try to figure out the format of a supposed image file from the extension # a couple of extensions are only checked when the optional parameter # $wmode is set (because those should have been identified by magic numbers # when reading) # todo: check completeness sub chkext { my ($ext,$wmode) = @_; $wmode = 0 unless defined $wmode; # there are not yet file formats which wouldn't have been identified # by magic no's if in reading mode if ($wmode) { return 'PNM' if $ext =~ /^(pbm)|(pgm)|(ppm)|(pnm)$/; return 'JPEG' if $ext =~ /^(jpg)|(jpeg)$/; return 'TIFF' if $ext =~ /^(tiff)|(tif)$/; return 'PCX' if $ext =~ /^pcx$/; return 'SGI' if $ext =~ /^rgb$/; return 'GIF' if $ext =~ /^gif$/; return 'RAST' if $ext =~ /^(r)|(rast)$/; return 'IFF' if $ext =~ /^(iff)|(ilbm)$/; return 'PS' if $ext =~ /^ps/; return 'FITS' if $ext =~ /^f(i?ts|it)$/; return 'PNG' if $ext =~ /^png$/i; } return 'UNKNOWN'; } # try to figure out the format of a supposed image file # from the magic numbers (numbers taken from magic in netpbm and # the file format routines in xv) # if no magics match try extension for non-magic file types # todo: make more complete sub chkform { my $file = shift; my ($format, $magic, $len, $ext) = ("","",0,""); open(IMG, $file) or barf "Can't open image file"; binmode IMG; # should first check if file is long enough $len = read(IMG, $magic,12); if (!defined($len) ||$len != 12) { barf "end of file when checking magic number"; close IMG; return 'UNKNOWN'; } close IMG; return 'PNM' if $magic =~ /^P[1-6]/; return 'GIF' if $magic =~ /(^GIF87a)|(^GIF89a)/; return 'TIFF' if $magic =~ /(^MM)|(^II)/; return 'JPEG' if $magic =~ /^(\377\330\377)/; return 'SGI' if $magic =~ /^(\001\332)|(\332\001)/; return 'RAST' if $magic =~ /^\131\246\152\225/; return 'IFF' if $magic =~ /ILBM$/; return 'PCX' if $magic =~ /^\012[\000-\005]/; return 'PS' if $magic =~ /%!\s*PS/; return 'FITS' if $magic =~ /^SIMPLE \=/; return 'PNG' if $magic =~ /^.PNG\r/; return chkext(getext($file)); # then try extensions } # helper proc for wpic # process hints for direct converter control and try to guess from extension # otherwise sub getconv { my ($pdl,$file,$hints) = @_; return ($$hints{CONVERTER},$$hints{FLAGS}) if defined($$hints{CONVERTER}); # somebody knows what he is doing my $type = ""; if (defined($$hints{'FORMAT'})) { $type = $$hints{'FORMAT'}; barf "unsupported (output) image format" unless (exists($converter{$type}) && $converter{$type}->{'put'} !~ /NA/); } else { $type = chkext(getext($file),1); if ($type =~ /UNKNOWN/) { barf "can't figure out desired file type, using PNM" ; $type = 'PNM'; } } my $conv = $converter{$type}->{'put'}; # the datatype check is only a dirty fix for the ppmquant problem with # types > byte # a ppmquant is anyway only warranted when $isrgb!!! $conv = $converter{$type}->{Prefilt}.$conv if defined($converter{$type}->{Prefilt}); my $flags = $converter{$type}->{FLAGS}; $flags = "$Dflags" unless defined($flags); $flags .= " $$hints{XTRAFLAGS}" if defined($$hints{XTRAFLAGS}); if (defined($$hints{'COLOR'}) && $$hints{'COLOR'} =~ /bwdither/) { $flags = " | $conv $flags"; $conv = "pgmtopbm -floyd"; } my($referral) = $converter{$type}->{referral}; return ($conv, $flags, $type, $referral); } # helper proc for wpic # if a certain type of pnm is required check data and make compliant if possible # else if intermediate format is pnm or ppm figure out the appropriate format # from the pdl sub chkpdl { my ($pdl, $iform, $hints, $format) = @_; if ($pdl->get_datatype >= $PDL_L || $pdl->get_datatype == $PDL_S || (!$converter{$format}->{ushortok} && $pdl->get_datatype == $PDL_US)) { print "scaling data to type byte...\n" if $PDL::IO::Pic::debug; $pdl = bytescl($pdl,-255); } my ($isrgb,$form) = (0,""); my @Dims = $pdl->dims; $isrgb = 1 if ($#Dims >= 2) && ($Dims[0] == 3); barf "expecting 2D or 3D-RGB-interlaced data as input" unless ($isrgb || ($#Dims == 1)); $$hints{'COLOR'} = "" unless defined($$hints{'COLOR'}); if ($iform =~ /P[NP]M/) { # figure out the format from the data $form = 'PPM' if $isrgb; $form = 'PGM' if ($#Dims == 1) || ($$hints{'COLOR'} =~ /bwdither/i); $form = 'PBM' if ($$hints{'COLOR'} =~ /bw/i); $iform = $form; } # this is the place for data conversions if ($isrgb && ($iform =~ 'P[B,G]M')) { print "wpic: converting to grayscale...\n"; $pdl = rgbtogr($pdl); # colour to grayscale } if (defined $$hints{LUT}) { # make LUT images into RGB barf "luts only with non RGB data" if $isrgb; print "starting palette->RGB conversion...\n" if $PDL::IO::Pic::debug; $pdl = interlrgb($pdl,$$hints{LUT}); $iform = 'PPM'; # and tell everyone we are now RGB print "finished conversion\n" if $PDL::IO::Pic::debug; } return ($pdl, $iform); } # delegate setting the temporary directory to the config file # (so that it can either be OS-independent or at least # easily controlled by the user). # sub gettmpdir { my $tmpdir = $PDL::Config{TEMPDIR} || die "TEMPDIR not found in %PDL::Config"; barf "can't locate a temp dir called $tmpdir" unless -d $tmpdir; return $tmpdir; } =head1 BUGS Currently only a random selection of converters/formats provided by pbmplus/netpbm is supported. It is hoped that the more important formats are covered. Other formats can be added as needed. Please send patches to the author. =head1 AUTHOR Copyright (C) 1996,1997 Christian Soeller All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut PDL-2.018/IO/Pnm/pnm.pd0000644060175006010010000004036213036512175012564 0ustar chmNone# REPLACE FOLLOWING BY # # use PDL::PP qw/PDL::Experiment PDL::Experiment Experiment/; # # when using not in this package. pp_add_exported('',"rpnm wpnm"); pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::IO::Pnm -- pnm format I/O for PDL =head1 SYNOPSIS use PDL::IO::Pnm; $im = wpnm $pdl, $file, $format[, $raw]; rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; =head1 DESCRIPTION pnm I/O for PDL. =cut use PDL::Core qw/howbig convert/; use PDL::Types; use PDL::Basic; # for max/min use PDL::IO::Misc; use Carp; use File::Temp qw( tempfile ); # return the upper limit of data values an integer PDL data type # can hold sub dmax { my $type = shift; my $sz = 8*howbig($type); $sz-- if ($type == $PDL_S || $type == $PDL_L); # signed types return ((1 << $sz)-1); } # output any errors that have accumulated sub show_err { my ($file,$showflag) = @_; my $err; $showflag = 1 unless defined $showflag; if (-s "$file") { open(INPUT,$file) or barf "Can't open error file"; if ($showerr) { while () { print STDERR "converter: $_"; }} else { $err = join('',); } } close INPUT; unlink $file; return $err unless $showflag; } # barf after showing any accumulated errors sub rbarf { my $err = show_err(shift, 0); $err = '' unless defined $err; barf @_,"converter error: $err"; } # carp after showing any accumulated errors sub rcarp { show_err(shift); carp @_; } EOD pp_addpm({At=>Bot},<<'EOD'); # the rest of FUNCTIONS section =head2 rpnm =for ref Read a pnm (portable bitmap/pixmap, pbm/ppm) file into a piddle. =for usage Usage: $im = rpnm $file; Reads a file in pnm format (ascii or raw) into a pdl (magic numbers P1-P6). Based on the input format it returns pdls with arrays of size (width,height) if binary or grey value data (pbm and pgm) or (3,width,height) if rgb data (ppm). This also means for a palette image that the distinction between an image and its lookup table is lost which can be a problem in cases (but can hardly be avoided when using netpbm/pbmplus). Datatype is dependent on the maximum grey/color-component value (for raw and binary formats always PDL_B). rpnm tries to read chopped files by zero padding the missing data (well it currently doesn't, it barfs; I'll probably fix it when it becomes a problem for me ;). You can also read directly into an existing pdl that has to have the right size(!). This can come in handy when you want to read a sequence of images into a datacube. For details about the formats see appropriate manpages that come with the netpbm/pbmplus packages. =for example $stack = zeroes(byte,3,500,300,4); rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; reads an rgb image (that had better be of size (500,300)) into the first plane of a 3D RGB datacube (=4D pdl datacube). You can also do inplace transpose/inversion that way. =cut sub rpnm {PDL->rpnm(@_)} sub PDL::rpnm { barf 'Usage: $im = rpnm($file) or $im = $pdl->rpnm($file)' if $#_<0 || $#_>2; my ($pdl,$file,$maybe) = @_; if (ref($file)) { # $file is really a pdl in this case $pdl = $file; $file = $maybe; } else { $pdl = $pdl->initialize; } my ($errfh, $efile) = tempfile(); # catch STDERR open(SAVEERR, ">&STDERR"); open(STDERR, ">$efile") || barf "Can't redirect stderr"; my $succeed = open(PNM, $file); # redirection now in effect for child # close(STDERR); open(STDERR, ">&PDL::IO::Pnm::SAVEERR"); rbarf $efile,"Can't open pnm file '$file'" unless $succeed; binmode PNM; read(PNM,(my $magic),2); rbarf $efile, "Oops, this is not a PNM file" unless $magic =~ /P[1-6]/; print "reading pnm file with magic $magic\n" if $PDL::debug>1; my ($isrgb,$israw,$params) = (0,0,3); $israw = 1 if $magic =~ /P[4-6]/; $isrgb = 1 if $magic =~ /P[3,6]/; if ($magic =~ /P[1,4]/) { # PBM data $params = 2; $dims[2] = 1; } # get the header information my ($line, $pgot, @dims) = ("",0,0,0,0); while (($pgot<$params) && ($line=)) { $line =~ s/#.*$//; next if $line =~ /^\s*$/; # just white space while ($line !~ /^\s*$/ && $pgot < $params) { if ($line =~ /\s*(\S+)(.*)$/) { $dims[$pgot++] = $1; $line = $2; } else { rbarf $efile, "no valid header info in pnm";} } } my $type = $PDL_B; do { TYPES: { my $pdlt; foreach $pdlt ($PDL_B,$PDL_US,$PDL_L){ if ($dims[2] <= dmax($pdlt)) { $type = $pdlt; last TYPES; } } rbarf $efile, "rraw: data from ascii pnm file out of range"; } }; # the file ended prematurely rbarf $efile, "no valid header info in pnm" if $pgot < $params; rbarf $efile, "Dimensions must be > 0" if ($dims[0] <= 0) || ($dims[1] <= 0); my @Dims = @dims[0,1]; $Dims[0] *= 3 if $isrgb; if ($pdl->getndims==1 && $pdl->getdim(0)==0 && $isrgb) { #input pdl is null local $PDL::debug = 0; # shut up $pdl = $pdl->zeroes(PDL::Type->new($type),3,@dims[0,1]); } my $npdl = $isrgb ? $pdl->clump(2) : $pdl; if ($israw) { pnminraw (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $magic eq "P4", 'PDL::IO::Pnm::PNM'); } else { my $form = $1 if $magic =~ /P([1-3])/; pnminascii (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $form, 'PDL::IO::Pnm::PNM'); } print("loaded pnm file, $dims[0]x$dims[1], gmax: $dims[2]", $isrgb ? ", RGB data":"", $israw ? ", raw" : " ASCII"," data\n") if $PDL::debug; unlink($efile); # need to byte swap for little endian platforms unless ( isbigendian() ) { if ($israw ) { $pdl->bswap2 if $type==$PDL_US or $pdl->type == ushort; $pdl->bswap4 if $type==$PDL_L; # not likely, but supported anyway } } return $pdl; } =head2 wpnm =for ref Write a pnm (portable bitmap/pixmap, pbm/ppm) file into a file. =for usage Usage: $im = wpnm $pdl, $file, $format[, $raw]; Writes data in a pdl into pnm format (ascii or raw) (magic numbers P1-P6). The $format is required (normally produced by B) and routine just checks if data is compatible with that format. All conversions should already have been done. If possible, usage of B is preferred. Currently RAW format is chosen if compliant with range of input data. Explicit control of ASCII/RAW is possible through the optional $raw argument. If RAW is set to zero it will enforce ASCII mode. Enforcing RAW is somewhat meaningless as the routine will always try to write RAW format if the data range allows (but maybe it should reduce to a RAW supported type when RAW == 'RAW'?). For details about the formats consult appropriate manpages that come with the netpbm/pbmplus packages. =cut *wpnm = \&PDL::wpnm; sub PDL::wpnm { barf ('Usage: wpnm($pdl,$filename,$format[,$raw]) ' . 'or $pdl->wpnm($filename,$format[,$raw])') if $#_ < 2; my ($pdl,$file,$type,$raw) = @_; my ($israw,$max,$isrgb,$magic) = (0,255,0,""); # need to copy input arg since bswap[24] work inplace # might be better if the bswap calls detected if run in # void context my $swap_inplace = $pdl->is_inplace; barf "wpnm: unknown format '$type'" if $type !~ /P[P,G,B]M/; # check the data my @Dims = $pdl->dims; barf "wpnm: expecting 3D (3,w,h) input" if ($type =~ /PPM/) && (($#Dims != 2) || ($Dims[0] != 3)); barf "wpnm: expecting 2D (w,h) input" if ($type =~ /P[G,B]M/) && ($#Dims != 1); barf "wpnm: user should convert float and double data to appropriate type" if ($pdl->get_datatype == $PDL_F) || ($pdl->get_datatype == $PDL_D); barf "wpnm: expecting prescaled data" if (($pdl->get_datatype != $PDL_B) || ($pdl->get_datatype != $PDL_US)) && ($pdl->min < 0); # check for raw format $israw = 1 if (($pdl->get_datatype == $PDL_B) || ($pdl->get_datatype == $PDL_US) || ($type =~ /PBM/)); $israw = 0 if (defined($raw) && !$raw); $magic = $israw ? "P4" : "P1" if $type =~ /PBM/; $magic = $israw ? "P5" : "P2" if $type =~ /PGM/; $magic = $israw ? "P6" : "P3" if $type =~ /PPM/; $isrgb = 1 if $magic =~ /P[3,6]/; # catch STDERR and sigpipe my ($errfh, $efile) = tempfile(); local $SIG{"PIPE"} = sub { show_err($efile); die "Bad write to pipe $? $!"; }; my $pref = ($file !~ /^\s*[|>]/) ? ">" : ""; # test for plain file name open(SAVEERR, ">&STDERR"); open(STDERR, ">$efile") || barf "Can't redirect stderr"; my $succeed = open(PNM, $pref . $file); # close(STDERR); open(STDERR, ">&PDL::IO::Pnm::SAVEERR"); rbarf $efile, "Can't open pnm file" unless $succeed; binmode PNM; $max =$pdl->max; print "writing ". ($israw ? "raw" : "ascii") . "format with magic $magic\n" if $PDL::debug; # write header print PNM "$magic\n"; print PNM "$Dims[-2] $Dims[-1]\n"; if ($type !~ /PBM/) { # fix maxval for raw output formats my $outmax = 0; if ($max < 256) { $outmax = "255"; } elsif ($max < 65536) { $outmax = "65535"; } else { $outmax = $max; }; print PNM "$outmax\n" unless $type =~ /PBM/; }; # if rgb clump first two dims together my $out = ($isrgb ? $pdl->slice(':,:,-1:0')->clump(2) : $pdl->slice(':,-1:0')); # handle byte swap issues for little endian platforms unless ( isbigendian() ) { if ($israw ) { # make copy if needed $out = $out->copy unless $swap_inplace; if ( (255 < $max) and ($max < 65536)) { $out->bswap2; } elsif ($max >= 65536) { $out->bswap4; } } } pnmout($out,$israw,$type eq "PBM",'PDL::IO::Pnm::PNM'); # check if our child returned an error (in case of a pipe) if (!(close PNM)) { my $err = show_err($efile,0); barf "wpnm: pbmconverter error: $err"; } unlink($efile); } ;# Exit with OK status 1; =head1 BUGS The stderr of the converters is redirected to a file. The filename is currently generated in a probably non-portable way. A method that avoids a file (and is portable) would be preferred. C currently relies on the fact that the header is separated from the image data by a newline. This is not required by the p[bgp]m formats (in fact any whitespace is allowed) but most of the pnm writers seem to comply with that. Truncated files are currently treated ungracefully (C just barfs). =head1 AUTHOR Copyright (C) 1996,1997 Christian Soeller All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut ############################## END PM CODE ################################ EOD pp_def('pnminraw', Pars => 'type(); byte+ [o] im(m,n)', OtherPars => 'int ms => m; int ns => n; int isbin; char* fd', GenericTypes => [B,U,L], Code => 'int ms, ns, i,j,k,bit,llen; PerlIO *fp; IO *io; PDL_Byte *buf, *bp; $GENERIC() *gbp; io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO)); if (!io || !(fp = IoIFP(io))) barf("Can\'t figure out FP"); ms = $SIZE(m); ns = $SIZE(n); llen = ($COMP(isbin) ? ((ms+7) / 8) : (ms * sizeof($GENERIC()))); /* allocate a buffer of length llen */ if ((buf = (PDL_Byte*) malloc(llen*sizeof(PDL_Byte))) == NULL) barf("Error getting mem for line buffer"); threadloop %{ /* with top to bottom inversion */ for (i=ns-1; i>= 0; i--) { if (PerlIO_read(fp,buf,llen) != llen) barf("Error reading pnm file"); if ($COMP(isbin)) /* unpack buffer */ for (j=0,bp=buf,bit=0; ji,m=>j) = (k&0x80) ? 0 : 1; k = k << 1; } else { gbp = ($GENERIC()*)buf; loop(m) %{ $im(n=>i,m=>m) = *(gbp++); %} } } %}', Doc => ' =for ref Read in a raw pnm file. read a raw pnm file. The C argument is only there to determine the type of the operation when creating C or trigger the appropriate type conversion (maybe we want a byte+ here so that C follows I the type of C). =cut ' ); pp_addhdr(<<'EOH'); #define SWALLOWLINE(fp) while ((s = PerlIO_getc(fp)) != '\n' && s != EOF) #define PBM 1 #define PGM 2 #define PPM 3 int getint(PerlIO *fp, PDL_Long *ip); /* process one input line from an ascii pnm file * and store data into a pdl data component * returns number of elements read * returns -1 if garbage was encountered */ /* get the next number from the input string * return values: len : number of characters read * 0 : end of string or skip rest of string because comment * -1 : found garbage */ #define TRAILING_WHITESPACE_CHECK(s) \ if (s!=' ' && s!='\t' && s!='\r' && s!='\n' && s!=',') return -1 int getint(PerlIO *fp, PDL_Long *ip) { PDL_Long i = 0; int nread = 0; int s = PerlIO_getc(fp); if (s == EOF) return 0; while (1) { if (s == EOF) return 0; /* signal end of line */ if (s == '#') SWALLOWLINE(fp); if (s >='0' && s <='9') break; if (s!=' ' && s!='\t' && s!='\r' && s!='\n' && s!=',') return -1; /* garbage */ s = PerlIO_getc(fp); /* else skip whitespace */ } /* parse number */ while (1) { i = (i*10) + (s - '0'); nread++; if ((s = PerlIO_getc(fp)) == EOF) break; /* we could loose that */ if (s<'0' || s>'9') break; } *ip = i; TRAILING_WHITESPACE_CHECK(s); return nread; } EOH pp_def( 'pnminascii', Pars => 'type(); byte+ [o] im(m,n)', OtherPars => 'int ms => m; int ns => n; int format; char* fd', GenericTypes => [B,U,S,L], Code => q? int ms, ns, s, i; PerlIO *fp; IO *io; io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO)); if (!io || !(fp = IoIFP(io))) barf("Can\'t figure out FP"); ms = $SIZE(m); ns = $SIZE(n); switch ($COMP(format)) { case PBM: threadloop %{ /* with top to bottom inversion */ for (i=ns-1; i>= 0; i--) { loop(m) %{ while ((s = PerlIO_getc(fp)) != EOF) { switch (s) { case '#': /* comment, skip rest of line */ SWALLOWLINE(fp); break; case '0': case '1': /* invert on the fly */ $im(n=>i,m=>m) = 1 - (s - '0'); goto $TBUSL(B,U,S,L)next; break; case ' ': case '\t': case '\r': case '\n': case ',': /* skip whitespace */ break; default: /* garbage */ barf("found garbage, aborting"); /* for now */ break; } } $TBUSL(B,U,S,L)next: ; %} } %} break; case PGM: case PPM: threadloop %{ /* with top to bottom inversion */ PDL_Long j; for (i=ns-1; i>= 0; i--) { loop(m) %{ if (getint(fp,&j) <= 0) barf("found garbage, aborting"); /* for now */ $im(n=>i,m=>m) = j; %} } %} break; default: barf("unknown PNM format"); break; } /* end switch */ ?, Doc => ' =for ref Read in an ascii pnm file. =cut ' ); # write a line of data supporting threading ! pp_def( 'pnmout', Pars => 'a(m);', 'NoPthread' => 1, # Pthreading doesn't make sense for an IO function OtherPars => "int israw; int isbin; char *fd", GenericTypes => [B,U,S,L], Code => 'PerlIO *fp; IO *io; io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO)); if (!io || !(fp = IoIFP(io))) barf("Can\'t figure out FP"); if ($COMP(israw)) { if ($COMP(isbin)) { threadloop %{ int k=0, bit=0; loop(m) %{ k = (k << 1) | ($a() < 1); bit++; if (bit==8) { PerlIO_putc(fp,k); bit = k = 0; } %} if (bit) { k = k << (8-bit); PerlIO_putc(fp,k); } %} } else { int len = $SIZE(m) * sizeof($GENERIC()); threadloop %{ if (PerlIO_write(fp,$P(a),len) != len) barf("Error writing pnm file"); %} } } else { int len=0; threadloop %{ loop(m) %{ PerlIO_printf(fp,"%3d ",$COMP(isbin) ? ($a() < 1) :$a()); len +=4; if (len>58) { PerlIO_printf(fp,"\n"); len=0; } %} if (len<=58) PerlIO_printf(fp,"\n"); %} } ', Doc => ' =for ref Write a line of pnm data. This function is implemented this way so that threading works naturally. =cut '); pp_done(); PDL-2.018/IO/Storable/0000755060175006010010000000000013110402046012445 5ustar chmNonePDL-2.018/IO/Storable/Makefile.PL0000644060175006010010000000060012562522364014433 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["storable.pd", qw(Storable PDL::IO::Storable)]); my %hash = pdlpp_stdargs_int(@pack); # $hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. $hash{'VERSION'} = '0.5'; # Add genpp rule undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/IO/Storable/storable.pd0000644060175006010010000002453612562522364014637 0ustar chmNonepp_addpm << 'EOPM'; =head1 NAME PDL::IO::Storable - helper functions to make PDL usable with Storable =head1 SYNOPSIS use Storable; use PDL::IO::Storable; $hash = { 'foo' => 42, 'bar' => zeroes(23,45), }; store $hash, 'perlhash.dat'; =head1 DESCRIPTION C implements object persistence for Perl data structures that can contain arbitrary Perl objects. This module implements the relevant methods to be able to store and retrieve piddles via Storable. =head1 FUNCTIONS =cut EOPM pp_addhdr << 'EOH'; EOH pp_addxs << 'EOXS'; MODULE = PDL::Storable PACKAGE = PDL void make_null(sv) SV *sv CODE: SV *newref, *dat; PDL_Indx fake[1] = {0}; STRLEN n_a; /* we basically mimick pdl_null but without letting * it give us a it->sv ! We have our own to which we * connect below */ pdl *it = PDL->pdlnew(); it->datatype = PDL_B; it->data = PDL->smalloc((STRLEN) (PDL->howbig(it->datatype))); dat = newSVpv(it->data,PDL->howbig(it->datatype)); it->data = SvPV(dat,n_a); it->datasv = dat; PDL->setdims(it, fake, 0); /* However, there are 0 dims in scalar */ it->nvals = 1; /* PDL->set(it->data, it->datatype, NULL, NULL, NULL, 0, 0, 0.0); */ /* a null piddle */ PDL->setdims(it,fake,1); it->state |= PDL_NOMYDIMS; /* connect pdl struct to this sv */ sv_setiv(SvRV(sv),PTR2IV(it)); it->sv = SvRV(sv); /* printf("it->sv = %d\n",it->sv); */ PDL->SetSV_PDL(sv,it); void swapEndian( to, elem_size ) SV* to int elem_size CODE: int i,j; STRLEN len; char* str = SvPV(to, len); for( i=0; i= 1.03 # pdlpack() serializes a piddle, while pdlunpack() unserializes it. Earlier # versions of PDL didn't control for endianness, type sizes and enumerated type # values; this made stored data unportable across different architectures and # PDL versions. This is no longer the case, but the reading code is still able # to read the old files. The old files have no meta-information in them so it's # impossible to read them correctly with 100% accuracy, but we try to make an # educated guess # # Old data format: # # int type # int ndims # int dims[ndims] # data # # Note that here all the sizes and endiannesses are the native. This is # un-portable. Furthermore, the "type" is an enum, and its values could change # between PDL versions. Here I assume that the old format input data is indeed # native, so the old data files have the same portability issues, but at least # things will remain working and broken in the same way they were before # # # New format: # # uint64 0xFFFF FFFF FFFF FFFF # meant to be different from the old-style data # char type[16] # ' '-padded, left-aligned type string such as 'PDL_LL' # uint32 sizeof(type) # little-endian # uint32 one # native-endian. Used to determine the endianness # uint64 ndims # little-endian # uint64 dims[ndims] # little-endian # data # # The header data is all little-endian here. The data is stored with native # endianness. On load it is checked, and a swap happens, if it is required sub pdlpack { my ($pdl) = @_; my $hdr = pack( 'c8A16VL', (-1) x 8, $pdl->type->symbol, PDL::Core::howbig( $pdl->get_datatype ), 1 ); # I'd like this to be simply # my $dimhdr = pack( 'Q<*', $pdl->getndims, $pdl->dims ) # but my pack() may not support Q, so I break it up manually # # if sizeof(int) == 4 here, then $_>>32 will not return 0 necessarily (this in # undefined). I thus manually make sure this is the case # my $noMSW = (PDL::Core::howbig($PDL::Types::PDL_IND) < 8) ? 1 : 0; my $dimhdr = pack( 'V*', map( { $_ & 0xFFFFFFFF, $noMSW ? 0 : ($_ >> 32) } ($pdl->getndims, $pdl->dims ) ) ); my $dref = $pdl->get_dataref; return $hdr . $dimhdr . $$dref; } sub pdlunpack { use Config (); my ($pdl,$pack) = @_; my ($type, $ndims); my @dims = (); my $do_swap = 0; # first I try to infer the type of this storable my $offset = 0; my @magicheader = unpack( "ll", substr( $pack, $offset ) ); $offset += 8; if( $magicheader[0] != -1 || $magicheader[1] != -1 ) { print "PDL::IO::Storable detected an old-style pdl\n" if $PDL::verbose; # old-style data. I leave the data sizes, endianness native, since I don't # know any better. This at least won't break anything. # # The "type" however needs attention. Most-recent old-format data had these # values for the type: # # enum { byte, # short, # unsigned short, # long, # long long, # float, # double } # # The $type I read from the file is assumed to be in this enum even though # PDL may have added other types in the middle of this enum. my @reftypes = ($PDL::Types::PDL_B, $PDL::Types::PDL_S, $PDL::Types::PDL_U, $PDL::Types::PDL_L, $PDL::Types::PDL_LL, $PDL::Types::PDL_F, $PDL::Types::PDL_D); my $stride = $Config::Config{intsize}; ($type,$ndims) = unpack 'i2', $pack; @dims = $ndims > 0 ? unpack 'i*', substr $pack, 2*$stride, $ndims*$stride : (); $offset = (2+$ndims)*$stride; if( $type < 0 || $type >= @reftypes ) { croak "Reading in old-style pdl with unknown type: $type. Giving up."; } $type = $reftypes[$type]; } else { print "PDL::IO::Storable detected a new-style pdl\n" if $PDL::verbose; # new-style data. I KNOW the data sizes, endianness and the type enum my ($typestring) = unpack( 'A16', substr( $pack, $offset ) ); $offset += 16; $type = eval( '$PDL::Types::' . $typestring ); if( $@ ) { croak "PDL::IO::Storable couldn't parse type string '$typestring'. Giving up"; } my ($sizeof) = unpack( 'V', substr( $pack, $offset ) ); $offset += 4; if( $sizeof != PDL::Core::howbig( $type ) ) { croak "PDL::IO::Storable sees mismatched data type sizes when reading data of type '$typestring'\n" . "Stored data has sizeof = $sizeof, while here it is " . PDL::Core::howbig( $type ) . ".\n" . "Giving up"; } # check the endianness, if the "1" I read is interpreted as "1" on my # machine then the endiannesses match, and I can just read the data my ($one) = unpack( 'L', substr( $pack, $offset ) ); $offset += 4; if( $one == 1 ) { print "PDL::IO::Storable detected matching endianness\n" if $PDL::verbose; } else { print "PDL::IO::Storable detected non-matching endianness. Correcting data on load\n" if $PDL::verbose; # mismatched endianness. Let's make sure it's a big/little issue, not # something weird. If mismatched, the '00000001' should be seen as # '01000000' if( $one != 0x01000000 ) { croak "PDL::IO::Storable sees confused endianness. A '1' was read as '$one'.\n" . "This is neither matching nor swapped endianness. I don't know what's going on,\n" . "so I'm giving up." } # all righty. Everything's fine, but I need to swap all the data $do_swap = 1; } # mostly this acts like unpack('Q<'...), but works even if my unpack() # doesn't support 'Q'. This also makes sure that my PDL_Indx is large enough # to read this piddle sub unpack64bit { my ($count, $pack, $offset) = @_; return map { my ($lsw, $msw) = unpack('VV', substr($$pack, $$offset)); $$offset += 8; croak( "PDL::IO::Storable tried reading a file with dimensions that don't fit into 32 bits.\n" . "However here PDL_Indx can't store a number so large. Giving up." ) if( PDL::Core::howbig($PDL::Types::PDL_IND) < 8 && $msw != 0 ); (($msw << 32) | $lsw) } (1..$count); } ($ndims) = unpack64bit( 1, \$pack, \$offset ); @dims = unpack64bit( $ndims, \$pack, \$offset ) if $ndims > 0; } print "thawing PDL, Dims: [",join(',',@dims),"]\n" if $PDL::verbose; $pdl->make_null; # make this a real piddle -- this is the tricky bit! $pdl->set_datatype($type); $pdl->setdims([@dims]); my $dref = $pdl->get_dataref; $$dref = substr $pack, $offset; if( $do_swap && PDL::Core::howbig( $type ) != 1 ) { swapEndian( $$dref, PDL::Core::howbig( $type ) ); } $pdl->upd_data; return $pdl; } sub STORABLE_freeze { my ($self, $cloning) = @_; # return if $cloning; # Regular default serialization return UNIVERSAL::isa($self, "HASH") ? ("",{%$self}) # hash ref -> Storable : (pdlpack $self); # pack the piddle into a long string } sub STORABLE_thaw { my ($pdl,$cloning,$serial,$hashref) = @_; # print "in STORABLE_thaw\n"; # return if $cloning; my $class = ref $pdl; if (defined $hashref) { croak "serial data with hashref!" unless !defined $serial || $serial eq ""; for (keys %$hashref) { $pdl->{$_} = $hashref->{$_} } } else { # all the magic is happening in pdlunpack $pdl->pdlunpack($serial); # unpack our serial into this sv } } # have these as PDL methods =head2 store =for ref store a piddle using L =for example $a = random 12,10; $a->store('myfile'); =cut =head2 freeze =for ref freeze a piddle using L =for example $a = random 12,10; $frozen = $a->freeze; =cut sub store { require Storable; Storable::store(@_) } sub freeze { require Storable; Storable::freeze(@_) } } =head1 AUTHOR Copyright (C) 2013 Dima Kogan Copyright (C) 2002 Christian Soeller All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOPM pp_done; PDL-2.018/Known_problems0000644060175006010010000001051413110400176013310 0ustar chmNoneThe following issues have been reported with this version of PDL: - For perls with long double or greater for NVTYPE, there is an unavoidable loss of precision in converting to/from the PDL_Double values. This may effect the results of calculations. A warning is output every "use PDL;" - A bug in the perl Nepbm interface code prevents reading or writing image files with whitespace in the filename. - GLUT readline support in perldl with the -glut option not yet implemented for win32. Work in progress. - A change in perl-5.14 on how the 'x' operator works affects PDL's overload of that operator for matrix multiplication. This can affect code using parentheses to group. An example that shows the problem is code like: f( ($pdl0 * $pdl1) x $pdl2 ) which now gives an error. The fix is to force the element-wise operation in parentheses to be treated in scalar context rather than list context. E.g., f( scalar($p0 * $p1) x $p2 ); - The current Ctrl-C logic in the PDL shells (pdl2 and perldl) doesn't work the same with the perl's new "safe signals". A workaround to the problem is to set the PERL_SIGNALS environment variable to "unsafe". See sf.net feature request #3308168 for details and any future status. - The Perl debugger for perls 5.10.1 through 5.14.x has a "feature" leading to false fails for lvalue subroutines when run under the debugger. If you need to debug such code with an affected perl version, the work around is to use an intermediate temporary variable assignment as in: $piddle->slice('0:10') .= 100; # original slice code ($tmp = $piddle->slice('0:10')) .= 100; # work around perl -d "feature" - Multiline q'' constructs are broken in the Devel::REPL versions 1.003012 and 1.003013 so you'll need to use perldl or avoid splitting quoted strings across lines. A fix is being investigated. - The demo 3d and 3d2 windows do not close (can not be closed) after the demo finishes. You need to exit the perldl shell to have the window close. - When you close a TriD graphics window with the frame widget the whole process exits including the perldl shell. - Extremely verbose but not particularly helpful text output from the configure-build-test process. - Directory completion in the interactive PDL shells (perldl and pdl2) using Term::ReadLine::Perl adds a space after each directory expansion. To continue to complete, one must delete the space before typing again. The problem has been reported as a Term::ReadLine::Perl bug. - The following SourceForge bugs are outstanding at time of the PDL-2.018 release: 435 PDL-LinearAlgebra-0.12 undefined reference to dggsvd_ + sggsvd_ 420 PDL-2.016 fails to build on ASperl solaris 32bit or 64bit platforms 418 warp2d and fitwarp2d polynomial fitting doesn't work as expected 412 16bit TIFF image IO not exact in PDL::IO::Pic 411 relax reshape() constraints 410 perl scalar NVs to float/#double types confusing 405 PDL::Bad - adding locf() function 397 PDL::FFT not 64bit integer safe 392 Inline Pdlpp doesn't work in clean build tree 391 Operators called in the form "explicit call with trailing 0" give syntax error 384 pdldoc.db is getting invalid paths to files on cygwin 382 plplot-5.11.0 comes with libplplot.a but missing libplplotd.a 381 rpic/rim fail to read files with whitespace in the filename 364 type promotion in whistogram is based upon the index, not the weight 354 filter demo list by actually available 339 PDL::Complex support is inconsistent and incomplete 334 Test coverage is incomplete 330 NiceSlice can get confused by comments to cause compilation errors 324 PDL re-install wipes out non-core docs 322 PDL::Demos system needs overhaul 308 propagate badflag with .= 274 'help funname' fails to show multiple function names 254 online docs don't link to functions in other PDL modules 238 NiceSlice affects code where it should not 210 default PDL build output too long 147 closing TriD window kills perldl shell For more information on these and other PDL issues, and for submissions of patches (bug patches are always welcome!), see the PDL mailing lists. Links to archive list discussions and how to register for the mailing lists can be found at http://pdl.perl.org/?page=mailing-lists . PDL-2.018/Lib/0000755060175006010010000000000013110402046011071 5ustar chmNonePDL-2.018/Lib/CallExt/0000755060175006010010000000000013110402046012425 5ustar chmNonePDL-2.018/Lib/CallExt/CallExt.pm0000644060175006010010000001634712562522364014352 0ustar chmNone package PDL::CallExt; @EXPORT_OK = qw( callext callext_cc ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); @EXPORT = @EXPORT_OK; use Config; use PDL::Core; use PDL::Exporter; use DynaLoader; use Carp; @ISA = qw( PDL::Exporter DynaLoader ); bootstrap PDL::CallExt; =head1 NAME PDL::CallExt - call functions in external shared libraries =head1 SYNOPSIS use PDL::CallExt; callext('file.so', 'foofunc', $x, $y); # pass piddles to foofunc() % perl -MPDL::CallExt -e callext_cc file.c =head1 DESCRIPTION callext() loads in a shareable object (i.e. compiled code) using Perl's dynamic loader, calls the named function and passes a list of piddle arguments to it. It provides a reasonably portable way of doing this, including compiling the code with the right flags, though it requires simple perl and C wrapper routines to be written. You may prefer to use PP, which is much more portable. See L. You should definitely use the latter for a 'proper' PDL module, or if you run in to the limitations of this module. =head1 API callext_cc() allows one to compile the shared objects using Perl's knowledge of compiler flags. The named function (e.g. 'foofunc') must take a list of piddle structures as arguments, there is now way of doing portable general argument construction hence this limitation. In detail the code in the original file.c would look like this: #include "pdlsimple.h" /* Declare simple piddle structs - note this .h file contains NO perl/PDL dependencies so can be used standalone */ int foofunc(int nargs, pdlsimple **args); /* foofunc prototype */ i.e. foofunc() takes an array of pointers to pdlsimple structs. The use is similar to that of C in UNIX C applications. pdlsimple.h defines a simple N-dimensional data structure which looks like this: struct pdlsimple { int datatype; /* whether byte/int/float etc. */ void *data; /* Generic pointer to the data block */ int nvals; /* Number of data values */ PDL_Long *dims; /* Array of data dimensions */ int ndims; /* Number of data dimensions */ }; (PDL_Long is always a 4 byte int and is defined in pdlsimple.h) This is a simplification of the internal representation of piddles in PDL which is more complicated because of threading, dataflow, etc. It will usually be found somewhere like /usr/local/lib/perl5/site_perl/PDL/pdlsimple.h Thus to actually use this to call real functions one would need to write a wrapper. e.g. to call a 2D image processing routine: void myimage_processer(double* image, int nx, int ny); int foofunc(int nargs, pdlsimple **args) { pdlsimple* image = pdlsimple[0]; myimage_processer( image->data, *(image->dims), *(image->dims+1) ); ... } Obviously a real wrapper would include more error and argument checking. This might be compiled (e.g. Linux): cc -shared -o mycode.so mycode.c In general Perl knows how to do this, so you should be able to get away with: perl -MPDL::CallExt -e callext_cc file.c callext_cc() is a function defined in PDL::CallExt to generate the correct compilation flags for shared objects. If their are problems you will need to refer to you C compiler manual to find out how to generate shared libraries. See t/callext.t in the distribution for a working example. It is up to the caller to ensure datatypes of piddles are correct - if not peculiar results or SEGVs will result. =head1 FUNCTIONS =head2 callext =for ref Call a function in an external library using Perl dynamic loading =for usage callext('file.so', 'foofunc', $x, $y); # pass piddles to foofunc() The file must be compiled with dynamic loading options (see C). See the module docs C for a description of the API. =head2 callext_cc =for ref Compile external C code for dynamic loading =for usage Usage: % perl -MPDL::CallExt -e callext_cc file.c -o file.so This works portably because when Perl has built in knowledge of how to do dynamic loading on the system on which it was installed. See the module docs C for a description of the API. =cut sub callext{ die "Usage: callext(\$file,\$symbol, \@pdl_args)" if scalar(@_)<2; my($file,$symbol, @pdl_args) = @_; my $libref = DynaLoader::dl_load_file($file); my $err = DynaLoader::dl_error(); barf $err if !defined $libref; my $symref = DynaLoader::dl_find_symbol($libref, $symbol); $err = DynaLoader::dl_error(); barf $err if !defined $symref; _callext_int($symref, @pdl_args); 1;} # Compile external C program correctly # # callext_cc # # The old version of this routine was taking unstructured arguments and # happily passed this though the C compiler. Unfortunately, on platforms # like HP-UX, we need to make separate cc and ld runs in order to create the # shared objects. # # The signature of the function was therefore changed starting at PDL 2.0. # It is now: # # ($src, $ccflags, $ldflags, $output) # # In its simplest invocation, it can be just $src, and the output will be # derived from the source file. Otherwise, $ccflags add extra C flags, $ldflags # adds extra ld flags, and $output specifies the final target output file name. # If left blank, it will be in the same directory where $src lied. # sub callext_cc { my @args = @_>0 ? @_ : @ARGV; my ($src, $ccflags, $ldflags, $output) = @args; my $cc_obj; ($cc_obj = $src) =~ s/\.c$/$Config{_o}/; my $ld_obj = $output; ($ld_obj = $cc_obj) =~ s/\.o$/\.$Config{dlext}/ unless defined $output; # Output flags for compiler depend on os. # -o on cc and gcc, or /Fo" " on MS Visual Studio # Need a start and end string my $do = ( $Config{cc} eq 'cl' ? '/Fo"' : '-o '); my $eo = ( $^O =~ /MSWin/i ? '"' : '' ); # Compiler command # Placing $ccflags *before* installsitearch/PDL/Core enables us to include # the blib 'pdlsimple.h' during 'make test'. my $cc_cmd = join(' ', map { $Config{$_} } qw(cc ccflags cccdlflags)) . qq{ $ccflags "-I$Config{installsitearch}/PDL/Core" -c $src $do$cc_obj$eo}; # The linker output flag is -o on cc and gcc, and -out: on MS Visual Studio my $o = ( $Config{cc} eq 'cl' ? '-out:' : '-o '); # Setup the LD command. Do not want the env var on Windows my $ld_cmd = ( $^O =~ /MSWin|android/i ? ' ' : 'LD_RUN_PATH="" '); my $libs = $^O =~ /MSWin/i ? $Config{libs} : ''; # used to be $Config{libs} but that bombs # on recent debian platforms $ld_cmd .= join(' ', map { $Config{$_} } qw(ld lddlflags)) . " $libs $ldflags $o$ld_obj $cc_obj"; # Run the command in two steps so that we can check status # of each and also so that we dont have to rely on ';' command # separator system $cc_cmd and croak "Error compiling $src ($cc_cmd)"; # Fix up ActiveState-built perl. Is this a reliable fix ? $ld_cmd =~ s/\-nodefaultlib//g if $Config{cc} eq 'cl'; system $ld_cmd and croak "Error linking $cc_obj ($ld_cmd)"; return 1; } =head1 AUTHORS Copyright (C) Karl Glazebrook 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # Exit with OK status 1; PDL-2.018/Lib/CallExt/CallExt.xs0000644060175006010010000000347112562522364014362 0ustar chmNone/* * We used to say "THIS FILE WAS GENERATED BY PDL::PP! Do not modify!" * but it has been hand-modified since then. */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "pdl.h" #include "pdlcore.h" #include "pdlsimple.h" static Core* PDL; /* Structure hold core C functions */ SV* CoreSV; /* Get's pointer to perl var holding core structure */ /* * Call an external C routine loaded dynamically - pass PDL args list * * Not sure whether should be 'ENABLE' or 'DISABLE' for the PROTOTYPES * argument below. We only seem to need the line to stop perl from * complaining about the line being missing during build time anyway. */ MODULE = PDL::CallExt PACKAGE = PDL::CallExt PROTOTYPES: DISABLE void _callext_int(...) PPCODE: int (*symref)(int npdl, pdlsimple **x); int npdl = items-1; pdlsimple **x; pdl *t; int i; symref = (int(*)(int, pdlsimple**)) INT2PTR(void*,SvIV(ST(0))); New( 42, x, npdl, pdlsimple* ); /* Ptr array */ for(i=0; iSvPDLV(ST(i+1)); PDL->make_physical(t); PDL->make_physdims(t); New(42, x[i], 1, pdlsimple); /* Each ptr */ x[i]->datatype = t->datatype; x[i]->data = t->data; x[i]->nvals = t->nvals; x[i]->dims = t->dims; x[i]->ndims = t->ndims; } i = (*symref)(npdl, x); if (i==0) barf("Error calling external routine"); for(i=0; i{libs}; my $mallocinc = $PDL::Config{MALLOCDBG}->{include}; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::CallExt', 'VERSION_FROM' => '../../Basic/Core/Version.pm', 'INC' => "-I../../Basic/Core $mallocinc", 'LIBS' => [$malloclib], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Lib/Compression/0000755060175006010010000000000013110402045013371 5ustar chmNonePDL-2.018/Lib/Compression/compression.pd0000644060175006010010000001403112562522364016277 0ustar chmNonepp_addhdr(' #include "ricecomp.c" '); pp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::Compression - compression utilities =head1 DESCRIPTION These routines generally accept some data as a PDL and compress it into a smaller PDL. Algorithms typically work on a single dimension and thread over other dimensions, producing a threaded table of compressed values if more than one dimension is fed in. The Rice algorithm, in particular, is designed to be identical to the RICE_1 algorithm used in internal FITS-file compression (see PDL::IO::FITS). =head1 SYNOPSIS use PDL::Compression ($b,$asize) = $a->rice_compress(); $c = $b->rice_expand($asize); =cut EOD pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHORS Copyright (C) 2010 Craig DeForest. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The Rice compression library is derived from the similar library in the CFITSIO 3.24 release, and is licensed under yet more more lenient terms than PDL itself; that notice is present in the file "ricecomp.c". =head1 BUGS =over 3 =item * Currently headers are ignored. =item * Currently there is only one compression algorithm. =back =head1 TODO =over 3 =item * Add object encapsulation =item * Add test suite =back =cut EOD pp_addpm(<<'EOD'); =head1 METHODS =cut EOD pp_def( "rice_compress", HandleBad => 0, Pars => 'in(n); [o]out(m); int[o]len(); lbuf(n)', OtherPars => "int blocksize", # in OtherPars to avoid autopromotion GenericTypes =>['B','S','US','L'], Doc => <<'EOD', =for ref Squishes an input PDL along the 0 dimension by Rice compression. In scalar context, you get back only the compressed PDL; in list context, you also get back ancillary information that is required to uncompress the data with rice_uncompress. Multidimensional data are threaded over - each row is compressed separately, and the returned PDL is squished to the maximum compressed size of any row. If any of the streams could not be compressed (the algorithm produced longer output), the corresponding length is set to -1 and the row is treated as if it had length 0. Rice compression only works on integer data types -- if you have floating point data you must first quantize them. The underlying algorithm is identical to the Rice compressor used in CFITSIO (and is used by PDL::IO::FITS to load and save compressed FITS images). The optional blocksize indicates how many samples are to be compressed as a unit; it defaults to 32. How it works: Rice compression is a subset of Golomb compression, and works on data sets where variation between adjacent samples is typically small compared to the dynamic range of each sample. In this implementation (originally written by Richard White and contributed to CFITSIO in 1999), the data are divided into blocks of samples (by default 32 samples per block). Each block has a running difference applied, and the difference is bit-folded to make it positive definite. High order bits of the difference stream are discarded, and replaced with a unary representation; low order bits are preserved. Unary representation is very efficient for small numbers, but large jumps could give rise to ludicrously large bins in a plain Golomb code; such large jumps ("high entropy" samples) are simply recorded directly in the output stream. Working on astronomical or solar image data, typical compression ratios of 2-3 are achieved. =for usage $out = $pdl->rice_compress($blocksize); ($out, $len, $blocksize, $dim0) = $pdl->rice_compress; $new = $out->rice_expand; =cut EOD PMCode => <<'EOD', sub PDL::rice_compress { my $in = shift; my $blocksize = shift || 32; ## Reject floating-point inputs if( $in->type != byte && $in->type != short && $in->type != ushort && $in->type != long ) { die("rice_compress: input needs to have type byte, short, ushort, or long, not ".($in->type)."\n"); } # output buffer starts the same size; truncate at the end. my ($out) = zeroes($in); # line buffer is here to make sure we don't get fouled up by transpositions my ($lbuf) = zeroes($in->type, $in->dim(0)); # lengths go here my ($len) = zeroes(long, $in->slice("(0)")->dims); &PDL::_rice_compress_int( $in, $out, $len, $lbuf, $blocksize ); $l = $len->max; $out = $out->slice("0:".($l-1))->sever; if(wantarray) { return ($out, $in->dim(0), $blocksize, $len); } else { return $out; } } EOD Code => <<'EOD', // Copy current row into the row buffer (to ensure // contiguous location in memory) loop(n) %{ $lbuf() = $in(); %} $len() = 1 + ( rcomp( &($lbuf(n=>0)), sizeof($lbuf(n=>0)), $SIZE(n), (unsigned char *)(&($out(m=>0))), $SIZE(m) * sizeof($out(m=>0)), $COMP(blocksize) ) - 1 ) / sizeof($out(m=>0)); EOD ); pp_def( "rice_expand", HandleBad=>0, Pars=>'in(n); [o]out(m); lbuf(n)', OtherPars=>'int blocksize', GenericTypes=>['B','S','US','L'], Doc=><<'EOD', =for ref Unsquishes a PDL that has been squished by rice_expand. =for usage ($out, $len, $blocksize, $dim0) = $pdl->rice_compress; $copy = $out->rice_expand($dim0, $blocksize); =cut EOD PMCode => <<'EOD', sub PDL::rice_expand { my $squished = shift; my $dim0 =shift; my $blocksize = shift || 32; # Allocate output array my $out = zeroes( $squished->slice("(0),*$dim0") ); # Allocate row buffer to avoid weird memory edge case my $lbuf = zeroes($squished->type, $squished->dim(0)); &PDL::_rice_expand_int( $squished, $out, $lbuf, $blocksize ); return $out; } EOD Code=><<'EOD', loop(n) %{ $lbuf() = $in(); %} rdecomp( (unsigned char *)(&($lbuf(n=>0))), $SIZE(n) * sizeof($lbuf(n=>0)), &($out(m=>0)), sizeof($out(m=>0)), $SIZE(m), $COMP(blocksize) ); EOD ); pp_done(); PDL-2.018/Lib/Compression/Makefile.PL0000644060175006010010000000060712562522364015367 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["compression.pd", qw(Compression PDL::Compression)]); my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} = "" unless exists $hash{OBJECT}; $hash{OBJECT} .= "ricecomp"; # Add genpp rule undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile( pdlpp_stdargs_int(@pack) ); PDL-2.018/Lib/Compression/ricecomp.c0000644060175006010010000004563512562522364015374 0ustar chmNone/********************************************************************** * A general purpose limited-entropy Rice compressor library * * The Rice algorithm is described by Rice, R.F., Yeh, P.-S., and * Miller, W. H. 1993, in Proc. of the 9th AIAA Computing in Aerospace * Conference, AIAA-93-45411-CP. Rice algorithms in general are simplified * Golomb codes that are useful for coding data with certain statistical * properties (generally, that differences between samples are typically * smaller than the coded dynamic range). This code compresses blocks * of samples (typically 16 or 32 samples at a time) that are stored * in normal 2's complement signed integer form, with a settable number * of 8-bit bytes per sample. * * Strict Rice coding gives rise * (in principle) to extremely large symbols in the worst high-entropy * case, so this library includes a block-level switch * * Assumptions: int is 32 bits ("long int"); short is 16 bits, byte is 8 bits. * * HISTORICAL NOTE: * * This compression library is modified from the CFITSIO library, * which is distributed by the U.S. government under the above * Free-compatible license. The code was originally written by * Richard White at the STScI and contributed to CFITSIO in July 1999. * The code has been further modified (Craig DeForest) to work in a * more general-purpose way than just within CFITSIO. * * * LICENSING & COPYRIGHT: * * Portions of this code are copyright (c) U.S. Government; the * modifications are copyright (c) Craig DeForest. The entire library * (including modifications) is licensed under the following terms * (inherited from CFITSIO v. 3.24): * * Permission to freely use, copy, modify, and distribute this software * and its documentation without fee is hereby granted, provided that this * copyright notice and disclaimer of warranty appears in all copies. * * DISCLAIMER: * * THE SOFTWARE IS PROVIDED 'AS IS' WITHOUT ANY WARRANTY OF ANY KIND, * EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT LIMITED * TO, ANY WARRANTY THAT THE SOFTWARE WILL CONFORM TO SPECIFICATIONS, * ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR * PURPOSE, AND FREEDOM FROM INFRINGEMENT, AND ANY WARRANTY THAT THE * DOCUMENTATION WILL CONFORM TO THE SOFTWARE, OR ANY WARRANTY THAT * THE SOFTWARE WILL BE ERROR FREE. IN NO EVENT SHALL NASA BE LIABLE * FOR ANY DAMAGES, INCLUDING, BUT NOT LIMITED TO, DIRECT, INDIRECT, * SPECIAL OR CONSEQUENTIAL DAMAGES, ARISING OUT OF, RESULTING FROM, * OR IN ANY WAY CONNECTED WITH THIS SOFTWARE, WHETHER OR NOT BASED * UPON WARRANTY, CONTRACT, TORT , OR OTHERWISE, WHETHER OR NOT INJURY * WAS SUSTAINED BY PERSONS OR PROPERTY OR OTHERWISE, AND WHETHER OR * NOT LOSS WAS SUSTAINED FROM, OR AROSE OUT OF THE RESULTS OF, OR USE * OF, THE SOFTWARE OR SERVICES PROVIDED HEREUNDER. * */ #include #include #include typedef unsigned char Buffer_t; typedef struct { int bitbuffer; /* bit buffer */ int bits_to_go; /* bits to go in buffer */ Buffer_t *start; /* start of buffer */ Buffer_t *current; /* current position in buffer */ Buffer_t *end; /* end of buffer */ } Buffer; #define putcbuf(c,mf) ((*(mf->current)++ = c), 0) static void start_outputing_bits(Buffer *buffer); static int done_outputing_bits(Buffer *buffer); static int output_nbits(Buffer *buffer, int bits, int n); /********************************************************************** * rcomp * * Usage: * bytes = rcomp( a, sampsiz, nx, buf, buflen, nblock ) * * a is a pointer to the input buffer, which contains signed integer * data to be encoded, either as bytes, shorts, or longs. * * sampsiz tells the sample size in bytes (1, 2, or 4) * * nx is the number of input samples to encode. * * buf is a pointer to the output buffer, which must be predeclared. * * clen is the size of the output buffer, in bytes. * * nblock is the coding block size to use, in samples (typ. 16 or 32) * * * The data are encoded (and hopefully compressed) into the output buffer, * and the length of the encoded data is returned. In case of failure * (e.g. buffer too small) -1 is returned. * * The CFITSIO code has this broken out into multiple routines for * different data types, but I (CED) have recombined them: the * overhead of using a couple of switch() statements to combine them * is believed (by me) to be negligible on modern architectures: the * process is close to memory-bound, and branch prediction on high end * microprocessors makes the type switches take 0 cycles anyway on * most iterations. * */ int rcomp(void *a_v, /* input array */ int bsize, /* sample size (in bytes) */ int nx, /* number of input pixels */ unsigned char *c, /* output buffer */ int clen, /* max length of output */ int nblock) /* coding block size */ { Buffer bufmem, *buffer = &bufmem; int *a = (int *)a_v; int i, j, thisblock; int lastpix, nextpix, pdiff; int v, fs, fsmask, top, fsmax, fsbits, bbits; int lbitbuffer, lbits_to_go; unsigned int psum; double pixelsum, dpsum; unsigned int *diff; // Blocksize is picked so that boundaries lie on 64-bit word edges for all data types if(nblock & 0x7 ) { fprintf(stderr,"rcomp: nblock must be divisible by 4 (is %d)\n",nblock); fflush(stderr); return(-1); } /* Magic numbers from fits_rcomp in CFITSIO; these have to match the ones in * rdecomp, below */ switch(bsize) { case 1: // byte fsbits = 3; fsmax = 6; break; case 2: // int fsbits = 4; fsmax = 14; break; case 4: // long fsbits = 5; fsmax = 25; break; default: fprintf(stderr,"rcomp: bsize must be 1, 2, or 4 bytes"); fflush(stderr); return(-1); } bbits = 1<start = c; buffer->current = c; buffer->end = c+clen; buffer->bits_to_go = 8; /* * array for differences mapped to non-negative values * Treat as an array of longs so it works in all cases * */ diff = (unsigned int *) malloc(nblock*sizeof(unsigned int)); if (diff == (unsigned int *) NULL) { fprintf(stderr,"rcomp: insufficient memory (allocating %d ints for internal buffer)",nblock); fflush(stderr); return(-1); } /* * Code in blocks of nblock pixels */ start_outputing_bits(buffer); /* write out first sample to the first bsize bytes of the buffer */ { int a0; int z; a0 = a[0]; z = output_nbits(buffer, a0, bsize * 8); if (z) { // no error message - buffer overruns are silent free(diff); return(-1); } } /* the first difference will always be zero */ switch(bsize) { case 1: lastpix = *((char *)a); break; case 2: lastpix = *((short *)a); break; case 4: lastpix = *((int *)a); break; default: break; // never happens (would be caught by first switch) } thisblock = nblock; for (i=0; i> 1; for (fs = 0; psum>0; fs++) psum >>= 1; /* * write the codes * fsbits ID bits used to indicate split level */ if (fs >= fsmax) { /* Special high entropy case when FS >= fsmax * Just write pixel difference values directly, no Rice coding at all. */ if (output_nbits(buffer, fsmax+1, fsbits) ) { // no error message - buffer overrun is silent. free(diff); return(-1); } for (j=0; jbitbuffer; lbits_to_go = buffer->bits_to_go; for (j=0; j> fs; /* * top is coded by top zeros + 1 */ if (lbits_to_go >= top+1) { lbitbuffer <<= top+1; lbitbuffer |= 1; lbits_to_go -= top+1; } else { lbitbuffer <<= lbits_to_go; putcbuf(lbitbuffer & 0xff,buffer); for (top -= lbits_to_go; top>=8; top -= 8) { putcbuf(0, buffer); } lbitbuffer = 1; lbits_to_go = 7-top; } /* * bottom FS bits are written without coding * code is output_nbits, moved into this routine to reduce overheads * This code potentially breaks if FS>24, so I am limiting * FS to 24 by choice of FSMAX above. */ if (fs > 0) { lbitbuffer <<= fs; lbitbuffer |= v & fsmask; lbits_to_go -= fs; while (lbits_to_go <= 0) { putcbuf((lbitbuffer>>(-lbits_to_go)) & 0xff,buffer); lbits_to_go += 8; } } } /* check if overflowed output buffer */ if (buffer->current > buffer->end) { free(diff); return(-1); } buffer->bitbuffer = lbitbuffer; buffer->bits_to_go = lbits_to_go; } } done_outputing_bits(buffer); free(diff); /* * return number of bytes used */ return(buffer->current - buffer->start); } /*---------------------------------------------------------------------------*/ /* bit_output.c * * Bit output routines * Procedures return zero on success, EOF on end-of-buffer * * Programmer: R. White Date: 20 July 1998 */ /* Initialize for bit output */ static void start_outputing_bits(Buffer *buffer) { /* * Buffer is empty to start with */ buffer->bitbuffer = 0; buffer->bits_to_go = 8; } /*---------------------------------------------------------------------------*/ /* Output N bits (N must be <= 32) */ static int output_nbits(Buffer *buffer, int bits, int n) { /* local copies */ int lbitbuffer; int lbits_to_go; /* AND mask for the right-most n bits */ static unsigned int mask[33] = {0, 0x1, 0x3, 0x7, 0xf, 0x1f, 0x3f, 0x7f, 0xff, 0x1ff, 0x3ff, 0x7ff, 0xfff, 0x1fff, 0x3fff, 0x7fff, 0xffff, 0x1ffff, 0x3ffff, 0x7ffff, 0xfffff, 0x1fffff, 0x3fffff, 0x7fffff, 0xffffff, 0x1ffffff, 0x3ffffff, 0x7ffffff, 0xfffffff, 0x1fffffff, 0x3fffffff, 0x7fffffff, 0xffffffff}; /* * insert bits at end of bitbuffer */ lbitbuffer = buffer->bitbuffer; lbits_to_go = buffer->bits_to_go; if (lbits_to_go+n > 32) { /* * special case for large n: put out the top lbits_to_go bits first * note that 0 < lbits_to_go <= 8 */ lbitbuffer <<= lbits_to_go; /* lbitbuffer |= (bits>>(n-lbits_to_go)) & ((1<>(n-lbits_to_go)) & *(mask+lbits_to_go); if(buffer->current >= buffer->end - 1) return 1; putcbuf(lbitbuffer & 0xff,buffer); n -= lbits_to_go; lbits_to_go = 8; } lbitbuffer <<= n; /* lbitbuffer |= ( bits & ((1<current >= buffer->end) return 1; putcbuf((lbitbuffer>>(-lbits_to_go)) & 0xff,buffer); lbits_to_go += 8; } buffer->bitbuffer = lbitbuffer; buffer->bits_to_go = lbits_to_go; if(buffer->bits_to_go < 8 && buffer->current >= buffer->end -2) return 1; return(0); } /*---------------------------------------------------------------------------*/ /* Flush out the last bits */ static int done_outputing_bits(Buffer *buffer) { if(buffer->bits_to_go < 8) { putcbuf(buffer->bitbuffer<bits_to_go,buffer); } return(0); } /********************************************************************** * rdecomp * * Usage: * errflag = rdecomp(a, clen, outbuf, sampsiz, nx, nblock) * * a is a pointer to the input buffer, which contains rice-compressed * data (e.g. from rcomp, above). * * clen is the length of the input buffer, in bytes. * * outbuf is a pointer to the output buffer, which should be * a pre-allocated array of chars, shorts, or longs according to * sampsiz. * * sampsiz tells the sample size in bytes (1, 2, or 4) * * nx tells the number of samples in the output buffer (which are * all expected to be present in the compressed stream). * * nblock is the block size, in samples, for compression. * * * The data are decoded into the output buffer. On normal completion * 0 is returned. */ int rdecomp (unsigned char *c, /* input buffer */ int clen, /* length of input (bytes) */ void *array, /* output array */ int bsize, /* bsize - bytes per pix of output */ int nx, /* number of output pixels */ int nblock) /* coding block size (in pixels) */ { int i, k, imax; int nbits, nzero, fs; unsigned char *cend, bytevalue; unsigned int b, diff, lastpix; int fsmax, fsbits, bbits; static int *nonzero_count = (int *)NULL; /* * From bsize derive: * FSBITS = # bits required to store FS * FSMAX = maximum value for FS * BBITS = bits/pixel for direct coding * * (These magic numbers have to match the ones in rcomp above.) */ switch (bsize) { case 1: fsbits = 3; fsmax = 6; break; case 2: fsbits = 4; fsmax = 14; break; case 4: fsbits = 5; fsmax = 25; break; default: fprintf(stderr,"rdecomp: bsize must be 1, 2, or 4 bytes"); fflush(stderr); return 1; } bbits = 1<=0; ) { for ( ; i>=k; i--) nonzero_count[i] = nzero; k = k/2; nzero--; } } /* * Decode in blocks of nblock pixels */ /* first bytes of input buffer contain the value of the first */ /* integer value, without any encoding */ cend = c + clen; lastpix = 0; switch(bsize) { case 4: bytevalue = c[0]; lastpix = lastpix | (bytevalue<<24); bytevalue = c[1]; lastpix = lastpix | (bytevalue<<16); bytevalue = c[2]; lastpix = lastpix | (bytevalue<<8); bytevalue = c[3]; lastpix = lastpix | bytevalue; c+=4; break; case 2: bytevalue = c[0]; lastpix = lastpix | (bytevalue<<8); bytevalue = c[1]; lastpix = lastpix | bytevalue; c+=2; break; case 1: lastpix = c[0]; c++; break; default: // never happens break; } b = *c++; /* bit buffer */ nbits = 8; /* number of bits remaining in b */ for (i = 0; i> nbits) - 1; b &= (1< nx) imax = nx; if (fs<0) { /* low-entropy case, all zero differences */ for ( ; i= 0; k -= 8) { b = *c++; diff |= b<0) { b = *c++; diff |= b>>(-k); b &= (1<>1; } else { diff = ~(diff>>1); } switch(bsize) { case 1: ((char *)array)[i] = diff + lastpix; lastpix = ((char *)array)[i]; break; case 2: ((short *)array)[i] = diff + lastpix; lastpix = ((short *)array)[i]; break; case 4: ((int *)array)[i] = diff + lastpix; lastpix = ((int *)array)[i]; break; default: // never happens break; } } } else { /* normal case, Rice coding */ for ( ; i>nbits); b &= (1<>1; } else { diff = ~(diff>>1); } switch(bsize) { case 1: ((char *)array)[i] = diff + lastpix; lastpix = ((char *)array)[i]; break; case 2: ((short *)array)[i] = diff + lastpix; lastpix = ((short *)array)[i]; break; case 4: ((int *)array)[i] = diff + lastpix; lastpix = ((int *)array)[i]; break; default: // never happens break; } } } if (c > cend) { fprintf(stderr,"rdecomp: decompression error: hit end of compressed byte stream\n"); fflush(stderr); return 1; } } return 0; } PDL-2.018/Lib/DiskCache.pm0000644060175006010010000002610713036512175013267 0ustar chmNone=head1 NAME PDL::DiskCache -- Non-memory-resident array object =head1 SYNOPSIS NON-OO: use PDL::DiskCache; tie @a,'PDL::DiskCache', \@files, \%options; imag $a[3]; OO: use PDL::DiskCache; $a = diskcache(\@files,\%options); imag $a->[3]; or use PDL::DiskCache; $a = new PDL::DiskCache(\@files,\%options); imag $a->[4]; =over 3 =item \@files an array ref containing a list of file names =item \%options a hash ref containing options for the PDL::DiskCache object (see "TIEARRAY" below for details) =back =head1 DESCRIPTION A PDL::DiskCache object is a perl L<"tied array"|perltie> that is useful for operations where you have to look at a large collection of PDLs one or a few at a time (such as tracking features through an image sequence). You can write prototype code that uses a perl list of a few PDLs, then scale up to to millions of PDLs simply by handing the prototype code a DiskCache tied array instead of a native perl array. The individual PDLs are stored on disk and a few of them are swapped into memory on a FIFO basis. You can set whether the data are read-only or writeable. By default, PDL::DiskCache uses FITS files to represent the PDLs, but you can use any sort of file at all -- the read/write routines are the only place where it examines the underlying data, and you can specify the routines to use at construction time (or, of course, subclass PDL::DiskCache). Items are swapped out on a FIFO basis, so if you have 10 slots and an expression with 10 items in it then you're OK (but you probably want more slots than that); but if you use more items in an expression than there are slots, thrashing will occur! The hash ref interface is kept for historical reasons; you can access the sync() and purge() method calls directly from the returned array ref. =head1 Shortcomings & caveats There's no file locking, so you could really hose yourself by having two of these things going at once on the same files. Since this is a tied array, things like Dumper traverse it transparently. That is sort-of good but also sort-of dangerous. You wouldn't want to PDL::Dumper::sdump() a large PDL::DiskCache, for example -- that would defeat the purpose of using a PDL::DiskCache in the first place. =head1 Author, license, no warranty Copyright 2001, Craig DeForest This code may be distributed under the same terms as Perl itself (license available at L). Copying, reverse engineering, distribution, and modification are explicitly allowed so long as this notice is preserved intact and modified versions are clearly marked as such. If you modify the code and it's useful, please send a copy of the modified version to cdeforest@solar.stanford.edu. This package comes with NO WARRANTY. =head1 FUNCTIONS =cut ###################################################################### # Package initialization $PDL::DiskCache::VERSION = 1.1; use strict; use Carp; =head2 diskcache Object constructor. =for usage $a = diskcache(\@f,\%options); Options =over 3 =item See the TIEARRAY options,below. =back =cut sub diskcache { my($f,$opt) = @_; return PDL::DiskCache::new('PDL::DiskCache',$f,$opt); } sub PDL::DiskCache::new { my($class,$f,$opt) = @_; my($a)=[]; my($b) = tie @{$a},$class,$f,$opt; if($opt->{bless}) { $a = bless($a,$class); } if(wantarray) { return ($a,bless($b,$class)); } else { return $a; } } *PDL::DiskCache::diskcache = *diskcache; =head2 TIEARRAY =for ref Tied-array constructor; invoked by perl during object construction. =for usage TIEARRAY(class,\@f,\%options) Options =over 3 =item ro (default 0) If set, treat the files as read-only (modifications to the tied array will only persist until the changed elements are swapped out) =item rw (default 1) If set, allow reading and writing to the files. Because there's currently no way to determine reliably whether a PDL has been modified, rw files are always written to disk when they're swapped out -- this causes a slight performance hit. =item mem (default 20) Number of files to be cached in memory at once. =item read (default \&rfits) A function ref pointing to code that will read list objects from disk. The function must have the same syntax as rfits: $object = rfits(filename). =item write (default \&wfits) A function ref pointing to code that will write list objects to disk. The function must have the same syntax as wfits: func(object,filename). =item bless (default 0) If set to a nonzero value, then the array ref gets blessed into the DiskCache class for for easier access to the "purge" and "sync" methods. This means that you can say C<< $a->sync >> instead of the more complex C<< (%{tied @$a})->sync >>, but C will return "PDL::DiskCache" instead of "ARRAY", which could break some code. =item verbose (default 0) Get chatty. =back =cut sub PDL::DiskCache::TIEARRAY { my($class,$f,$opt) = @_; croak "PDL::DiskCache needs array ref as 2nd arg (did you pass an array instead?)\n" if(ref $f ne 'ARRAY'); my($new) = {files => $f # File list , n => scalar(@{$f}) # no. of el. , write => $opt->{write} || \&main::wfits # Write routine , read => $opt->{read} || \&main::rfits # Read routine , mem => $opt->{mem} || 20 # No. of mem slots , rw => (!($opt->{ro})) # rw or ro , fdex => [] # Current file stored in each slot, by slot , slot => [] # Current slot in which each file is stored , cache => [] # Actual cached stuff gets held here , opt => {} # Options stashed here for later reference , cache_next => 0 # Next cache slot to be used }; foreach $_(keys %{$opt}) { $new->{opt}->{$_} = $opt->{$_}; } return bless($new,$class); } =head2 purge Remove an item from the oldest slot in the cache, writing to disk as necessary. You also send in how many slots to purge (default 1; sending in -1 purges everything.) For most uses, a nice MODIFIED flag in the data structure could save some hassle here. But PDLs can get modified out from under us with slicing and .= -- so for now we always assume everything is tainted and must be written to disk. =cut sub PDL::DiskCache::purge { my($me,$n) = @_,1; $me = (tied @{$me}) if("$me" =~ m/^PDL\:\:DiskCache\=ARRAY/); $n = $me->{mem} if($n<0); print "purging $n items..." if($me->{opt}->{verbose}); my($dex) = $me->{cache_next}; local($_); for(1..$n) { if($me->{rw}) { print "writing $me->{files}->[$me->{fdex}->[$dex]]: " if($me->{opt}->{verbose}); eval {&{$me->{write}}($me->{cache}->[$dex], $me->{files}->[$me->{fdex}->[$dex]]); }; print "WARNING: PDL::DiskCache::purge: problems with write of ".$me->{files}->[$me->{fdex}->[$dex]].", item $me->{fdex}->[$dex] from slot $dex: `$@' (".$me->{opt}->{varname}.") \n" if($@); $@ = 0; print "ok.\n" if($me->{opt}->{verbose}); } print "Purging item $dex (file $me->{fdex}->[$dex])...\n" if($me->{opt}->{verbose}); undef $me->{slot}->[$me->{fdex}->[$dex]]; # Purge from slot location list undef $me->{fdex}->[$dex]; # Purge from slot fdex list undef $me->{cache}->[$dex]; # Purge from memory $dex++; $dex %= $me->{mem}; } print "...done with purge.\n" if($me->{opt}->{verbose}); } sub PDL::DiskCache::FETCH { my($me,$i) = @_; if($i < 0 || $i >= $me->{n}) { carp("PDL::DiskCache: Element $i is outside range of 0-",$me->{n}-1,"\n"); return undef; } if(defined $me->{slot}->[$i]) { print "Item $i is in the cache...\n" if ($me->{opt}->{verbose}); return ($me->{cache}->[$me->{slot}->[$i]]); } ### Got here -- we have to get the item from disk. print "Item $i ($me->{files}->[$i]) not present. Retrieving..." if($me->{opt}->{verbose}); if(defined($me->{fdex}->[$me->{cache_next}])) { print "cache full..." if($me->{opt}->{verbose}); $me->purge(1); } my($a) = $me->{cache_next}; $me->{cache}->[$a] = eval { &{$me->{read}}($me->{files}->[$i]) } ; undef $@; # Keep this from hanging anything else. print "result is ",(defined $me->{cache}->[$a] ? "" : "un")."defined.\n" if($me->{opt}->{verbose}); $me->{slot}->[$i] = $me->{cache_next}; $me->{fdex}->[$me->{cache_next}] = $i; $me->{cache_next}++; $me->{cache_next} %= $me->{mem}; $me->{cache}->[$a]; } sub PDL::DiskCache::STORE { my($me, $i, $val) = @_; if( $me->{slot}->[$i] ) { print "Storing index $i, in cache\n" if($me->{opt}->{verbose}); $me->sync($i); return $me->{cache}->[$me->{slot}->[$i]] = $val; } else { print "Storing index $i, not in cache\n" if($me->{opt}->{verbose}); if(defined ($me->{fdex}->[$me->{cache_next}])) { print "cache full..." if($me->{opt}->{verbose}); $me->purge(1); } my($a) = $me->{cache_next}; $me->{slot}->[$i] = $a; $me->{fdex}->[$a] = $i; $me->{cache_next}++; $me->{cache_next} %= $me->{mem}; $me->sync($i); return $me->{cache}->[$a] = $val; } croak("This never happens"); } sub PDL::DiskCache::FETCHSIZE { my($me) = shift; $me->{n}; } sub PDL::DiskCache::STORESIZE { my($me,$newsize) = @_; if($newsize > $me->{n}) { croak("PDL::DiskCache: Can't augment array size (yet)!\n"); } for( my($i) = $newsize-1; $i<$me->{n}; $i++ ) { if(defined $me->{slot}->[$i]) { if($me->{rw}) { print "Writing $me->{files}->[$me->{fdex}->[$i]]\n" if($me->{opt}->{verbose}); eval {&{$me->{write}}($me->{cache}->[$me->{slot}->[$i]], $me->{files}->[$i]); }; $@ = 0; # Keep from hanging anything else } undef $me->{fdex}->[$me->{slot}->[$i]]; } } $#{$me->{slot}} = $newsize-1; $#{$me->{files}} = $newsize-1; $me->{n} = $newsize; } =head2 sync In a rw cache, flush items out to disk but retain them in the cache. Accepts a single scalar argument, which is the index number of a single item that should be written to disk. Passing (-1), or no argument, writes all items to disk, similar to purge(-1). For ro caches, this is a not-too-slow (but safe) no-op. =cut sub PDL::DiskCache::sync { my($me) = shift; $me = (tied @{$me}) if("$me" =~ m/^PDL\:\:DiskCache\=ARRAY/); my($syncn) = shift; $syncn = -1 unless defined $syncn; print "PDL::DiskCache::sync\n" if($me->{opt}->{verbose}); my @list = $syncn==-1 ? (0..$me->{mem}-1) : ($syncn); if($me->{rw}) { for(@list) { if(defined $me->{fdex}->[$_]) { print " writing $me->{files}->[$me->{fdex}->[$_]]...\n" if($me->{opt}->{verbose}); eval {&{$me->{write}}($me->{cache}->[$_], $me->{files}->[$me->{fdex}->[$_]]); }; $@ = 0; # keep from hanging anything else } } } } =head2 DESTROY This is the perl hook for object destruction. It just makes a call to "sync", to flush the cache out to disk. Destructor calls from perl don't happen at a guaranteed time, so be sure to call "sync" if you need to ensure that the files get flushed out, e.g. to use 'em somewhere else. =cut sub PDL::DiskCache::DESTROY { my($me) = shift; $me->sync; } # return true 1; PDL-2.018/Lib/FFT/0000755060175006010010000000000013110402046011510 5ustar chmNonePDL-2.018/Lib/FFT/fft.pd0000644060175006010010000003465013036512175012640 0ustar chmNone pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::FFT - FFTs for PDL =head1 DESCRIPTION !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! As of PDL-2.006_04, the direction of the FFT/IFFT has been reversed to match the usage in the FFTW library and the convention in use generally. !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FFTs for PDL. These work for arrays of any dimension, although ones with small prime factors are likely to be the quickest. The forward FFT is unnormalized while the inverse FFT is normalized so that the IFFT of the FFT returns the original values. For historical reasons, these routines work in-place and do not recognize the in-place flag. That should be fixed. =head1 SYNOPSIS use PDL::FFT qw/:Func/; fft($real, $imag); ifft($real, $imag); realfft($real); realifft($real); fftnd($real,$imag); ifftnd($real,$imag); $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); =head1 DATA TYPES The underlying C library upon which this module is based performs FFTs on both single precision and double precision floating point piddles. Performing FFTs on integer data types is not reliable. Consider the following FFT on piddles of type 'double': $r = pdl(0,1,0,1); $i = zeroes($r); fft($r,$i); print $r,$i; [2 0 -2 0] [0 0 0 0] But if $r and $i are unsigned short integers (ushorts): $r = pdl(ushort,0,1,0,1); $i = zeroes($r); fft($r,$i); print $r,$i; [2 0 65534 0] [0 0 0 0] This used to occur because L converts the ushort piddles to floats or doubles, performs the FFT on them, and then converts them back to ushort, causing the overflow where the amplitude of the frequency should be -2. Therefore, if you pass in a piddle of integer datatype (byte, short, ushort, long) to any of the routines in PDL::FFT, your data will be promoted to a double-precision piddle. If you pass in a float, the single-precision FFT will be performed. =head1 FREQUENCIES For even-sized input arrays, the frequencies are packed like normal for FFTs (where N is the size of the array and D is the physical step size between elements): 0, 1/ND, 2/ND, ..., (N/2-1)/ND, 1/2D, -(N/2-1)/ND, ..., -1/ND. which can easily be obtained (taking the Nyquist frequency to be positive) using C<< $kx = $real->xlinvals(-($N/2-1)/$N/$D,1/2/$D)->rotate(-($N/2 -1)); >> For odd-sized input arrays the Nyquist frequency is not directly acessible, and the frequencies are 0, 1/ND, 2/ND, ..., (N/2-0.5)/ND, -(N/2-0.5)/ND, ..., -1/ND. which can easily be obtained using C<< $kx = $real->xlinvals(-($N/2-0.5)/$N/$D,($N/2-0.5)/$N/$D)->rotate(-($N-1)/2); >> =head1 ALTERNATIVE FFT PACKAGES Various other modules - such as L and L - contain FFT routines. However, unlike PDL::FFT, these modules are optional, and so may not be installed. =cut EOD pp_addhdr(' int fftn (int ndim, const int dims[], double Re[], double Im[], int iSign, double scaling); int fftnf (int ndim, const int dims[], float Re[], float Im[], int iSign, float scaling); void fft_free(); '); pp_addxs('',' int fft_free() CODE: fft_free(); RETVAL = 1; OUTPUT: RETVAL '); pp_def('_fft', Pars => '[o,nc]real(n); [o,nc]imag(n);', 'NoPthread' => 1, # underlying fft code (fftn.c) isn't threadsafe GenericTypes => [F,D], Code => '$TFD(fftnf,fftn) ($SIZE(n), NULL , $P(real),$P(imag), -1, 1.);', Doc=>undef ); pp_def('_ifft', Pars => '[o,nc]real(n); [o,nc]imag(n);', 'NoPthread' => 1, # underlying fft code (fftn.c) isn't threadsafe GenericTypes => [F,D], Code => '$TFD(fftnf,fftn) ($SIZE(n), NULL , $P(real),$P(imag), 1, -1.);', Doc=>undef ); pp_add_exported('',"fft ifft fftnd ifftnd fftconvolve realfft realifft kernctr"); pp_addpm(<<'EOD'); use Carp; use PDL::Core qw/:Func/; use PDL::Basic qw/:Func/; use PDL::Types; use PDL::ImageND qw/kernctr/; # moved to ImageND since FFTW uses it too END { # tidying up required after using fftn print "Freeing FFT space\n" if $PDL::verbose; fft_free(); } sub todecimal { my ($arg) = @_; $arg = $arg->double if (($arg->get_datatype != $PDL_F) && ($arg->get_datatype != $PDL_D)); $_[0] = $arg; 1;} =head2 fft() =for ref Complex 1-D FFT of the "real" and "imag" arrays [inplace]. =for sig Signature: ([o,nc]real(n); [o,nc]imag(n)) =for usage fft($real,$imag); =cut *fft = \&PDL::fft; sub PDL::fft { # Convert the first argument to decimal and check for trouble. eval { todecimal($_[0]); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($_[1]); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) piddle?' if ($message =~ /undefined value/); barf($message); } _fft($_[0],$_[1]); } =head2 ifft() =for ref Complex inverse 1-D FFT of the "real" and "imag" arrays [inplace]. =for sig Signature: ([o,nc]real(n); [o,nc]imag(n)) =for usage ifft($real,$imag); =cut *ifft = \&PDL::ifft; sub PDL::ifft { # Convert the first argument to decimal and check for trouble. eval { todecimal($_[0]); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($_[1]); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) piddle?' if ($message =~ /undefined value/); barf($message); } _ifft($_[0],$_[1]); } =head2 realfft() =for ref One-dimensional FFT of real function [inplace]. The real part of the transform ends up in the first half of the array and the imaginary part of the transform ends up in the second half of the array. =for usage realfft($real); =cut *realfft = \&PDL::realfft; sub PDL::realfft { barf("Usage: realfft(real(*)") if $#_ != 0; my ($a) = @_; todecimal($a); # FIX: could eliminate $b my ($b) = 0*$a; fft($a,$b); my ($n) = int((($a->dims)[0]-1)/2); my($t); ($t=$a->slice("-$n:-1")) .= $b->slice("1:$n"); undef; } =head2 realifft() =for ref Inverse of one-dimensional realfft routine [inplace]. =for usage realifft($real); =cut *realifft = \&PDL::realifft; sub PDL::realifft { use PDL::Ufunc 'max'; barf("Usage: realifft(xfm(*)") if $#_ != 0; my ($a) = @_; todecimal($a); my ($n) = int((($a->dims)[0]-1)/2); my($t); # FIX: could eliminate $b my ($b) = 0*$a; ($t=$b->slice("1:$n")) .= $a->slice("-$n:-1"); ($t=$a->slice("-$n:-1")) .= $a->slice("$n:1"); ($t=$b->slice("-$n:-1")) .= -$b->slice("$n:1"); ifft($a,$b); # Sanity check -- shouldn't happen carp "Bad inverse transform in realifft" if max(abs($b)) > 1e-6*max(abs($a)); undef; } =head2 fftnd() =for ref N-dimensional FFT over all pdl dims of input (inplace) =for example fftnd($real,$imag); =cut *fftnd = \&PDL::fftnd; sub PDL::fftnd { barf "Must have real and imaginary parts for fftnd" if $#_ != 1; my ($r,$i) = @_; my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for fft" if ($n != $i->getndims); $n--; todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; foreach (0..$n) { fft($r,$i); $r = $r->mv(0,$n); $i = $i->mv(0,$n); } $_[0] = $r; $_[1] = $i; undef; } =head2 ifftnd() =for ref N-dimensional inverse FFT over all pdl dims of input (inplace) =for example ifftnd($real,$imag); =cut *ifftnd = \&PDL::ifftnd; sub PDL::ifftnd { barf "Must have real and imaginary parts for ifftnd" if $#_ != 1; my ($r,$i) = @_; my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for ifft" if ($n != $i->getndims); todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; $n--; foreach (0..$n) { ifft($r,$i); $r = $r->mv(0,$n); $i = $i->mv(0,$n); } $_[0] = $r; $_[1] = $i; undef; } EOD # This version uses the fft routines' internal row/column swapping. # Doing this instead through PDL seems quicker at the moment. if (0) { pp_def('fftnd', Pars => 'int dims(n); [o,nc]real(m); [o,nc]imag(m);', GenericTypes => [F,D], PMCode => ' sub PDL::fftnd{ barf("Usage: fftnd(real(*), imag(*)") if $#_ != 1; my($a,$b) = @_; my(@dimsa) = $a->dims; my(@dimsb) = $b->dims; my($dimsa) = long \@dimsa; foreach(@dimsa) { barf "Real and imaginary arrays must have same dimensions" if ($_ != shift @dimsb); } &PDL::_fftnd_int($dimsa, $a->clump(-1), $b->clump(-1)); } ', Code => ' int *dima, ns=$SIZE(n), j; dima = (int *) malloc(ns*sizeof(int)); if (!dima) barf("fftnd: Out of memory for dimension array"); for (j=0;jj); $TFD(fftnf,fftn)(ns, dima, $P(real),$P(imag), 1, 1.); free(dima); ', Doc=>'N-dimensional FFT [inplace].' ); pp_def('ifftnd', Pars => 'int dims(n); [o,nc]real(m); [o,nc]imag(m);', GenericTypes => [F,D], PMCode => ' sub PDL::ifftnd{ barf("Usage: ifftnd(real(*), imag(*)") if $#_ != 1; my($a,$b) = @_; my(@dimsa) = $a->dims; my(@dimsb) = $b->dims; my($dimsa) = long \@dimsa; foreach(@dimsa) { barf "Real and imaginary arrays must have same dimensions" if ($_ != shift @dimsb); } &PDL::_ifftnd_int($dimsa, $a->clump(-1), $b->clump(-1)); } ', Code => ' int *dima, ns=$SIZE(n), j; dima = (int *) malloc(ns*sizeof(int)); if (!dima) barf("ifftnd: Out of memory for dimension array"); for (j=0;jj); $TFD(fftnf,fftn)(ns, dima, $P(real),$P(imag), -1, -1.); free(dima); ', Doc=>'N-dimensional inverse FFT [inplace].' ); } pp_addpm(<<'EOD'); =head2 fftconvolve() =for ref N-dimensional convolution with periodic boundaries (FFT method) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); fftconvolve works inplace, and returns an error array in kernel as an accuracy check -- all the values in it should be negligible. See also L, which performs speed-optimized convolution with a variety of boundary conditions. The sizes of the image and the kernel must be the same. L centres a small kernel to emulate the behaviour of the direct convolution routines. The speed cross-over between using straight convolution (L) and these fft routines is for kernel sizes roughly 7x7. =cut *fftconvolve = \&PDL::fftconvolve; sub PDL::fftconvolve { barf "Must have image & kernel for fftconvolve" if $#_ != 1; my ($a, $k) = @_; my ($ar,$ai,$kr,$ki,$cr,$ci); $ar = $a->copy; $ai = $ar->zeros; fftnd($ar, $ai); $kr = $k->copy; $ki = $kr->zeroes; fftnd($kr,$ki); $cr = $ar->zeroes; $ci = $ai->zeroes; cmul($ar,$ai,$kr,$ki,$cr,$ci); ifftnd($cr,$ci); $_[0] = $cr; $_[1] = $ci; ($cr,$ci); } sub PDL::fftconvolve_inplace { barf "Must have image & kernel for fftconvolve" if $#_ != 1; my ($hr, $hi) = @_; my ($n) = $hr->getndims; todecimal($hr); # Convert to double unless already float or double todecimal($hi); # Convert to double unless already float or double # need the copy in case $r and $i point to same memory $hi = $hi->copy; $hr = $hr->copy; fftnd($hr,$hi); convmath($hr->clump(-1),$hi->clump(-1)); my ($str1, $str2, $tmp, $i); chop($str1 = '-1:1,' x $n); chop($str2 = '1:-1,' x $n); # FIX: do these inplace -- cuts the arithmetic by a factor 2 as well. ($tmp = $hr->slice($str2)) += $hr->slice($str1)->copy; ($tmp = $hi->slice($str2)) -= $hi->slice($str1)->copy; for ($i = 0; $i<$n; $i++) { chop ($str1 = ('(0),' x $i).'-1:1,'.('(0),'x($n-$i-1))); chop ($str2 = ('(0),' x $i).'1:-1,'.('(0),'x($n-$i-1))); ($tmp = $hr->slice($str2)) += $hr->slice($str1)->copy; ($tmp = $hi->slice($str2)) -= $hi->slice($str1)->copy; } $hr->clump(-1)->set(0,$hr->clump(-1)->at(0)*2); $hi->clump(-1)->set(0,0.); ifftnd($hr,$hi); $_[0] = $hr; $_[1] = $hi; ($hr,$hi); } EOD # convmath does local part of the maths necessary to handle a,b which # result from FFT of image & kernel in parallel. pp_def('convmath', Pars => '[o,nc]a(m); [o,nc]b(m);', Code => ' $GENERIC() t1, t2; loop(m) %{ t1 = $a(); t2 = $b(); $a() = t1*t2/2; $b() = (t2*t2-t1*t1)/4; %} ', # Doc => undef, Doc => 'Internal routine doing maths for convolution' ); pp_def('cmul', Pars => 'ar(); ai(); br(); bi(); [o]cr(); [o]ci();', Code => ' $GENERIC() ar, ai, br, bi; ar = $ar(); ai = $ai(); br = $br(); bi = $bi(); $cr() = ar*br-ai*bi; $ci() = ar*bi+ai*br; ', Doc => 'Complex multiplication' ); use Config; use strict; use warnings; #define the abs <-> datatype mapping my %ah = (B => '', U => '', S => 'abs', L => $Config{'intsize'}==4?'abs':($Config{'longsize'}==4?'labs':'abs'), N => $Config{'ivtype'}eq'long'?'labs':($Config{'ivtype'}eq'longlong'?'llabs':'abs'), Q => 'labs', F => 'fabsf', D => 'fabs' ); our $abs_string .= "types($_) %{" . $ah{$_} . '(br) > ' . $ah{$_} . "(bi)%}\n" foreach (keys %ah); pp_def('cdiv', Pars => 'ar(); ai(); br(); bi(); [o]cr(); [o]ci();', Code => ' $GENERIC() ar, ai, br, bi, tt, dn; ar = $ar(); ai = $ai(); br = $br(); bi = $bi(); if (' . $abs_string . ') { tt = bi/br; dn = br + tt*bi; $cr() = (ar+tt*ai)/dn; $ci() = (ai-tt*ar)/dn; } else { tt = br/bi; dn = br*tt + bi; $cr() = (ar*tt+ai)/dn; $ci() = (ai*tt-ar)/dn; } ', Doc => 'Complex division' ); pp_addpm(<<'ENDPM'); 1; # OK ENDPM pp_addpm(<<'EOD'); =head1 BUGS Where the source is marked `FIX', could re-implement using phase-shift factors on the transforms and some real-space bookkeeping, to save some temporary space and redundant transforms. =head1 AUTHOR This file copyright (C) 1997, 1998 R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.018/Lib/FFT/fftn.c0000644060175006010010000007236412562522364012645 0ustar chmNone/*--------------------------------*-C-*---------------------------------* * File: * fftn.c * * multivariate complex Fourier transform, computed in place * using mixed-radix Fast Fourier Transform algorithm. * * Fortran code by: * RC Singleton, Stanford Research Institute, Sept. 1968 * NIST Guide to Available Math Software. * Source for module FFT from package GO. * Retrieved from NETLIB on Wed Jul 5 11:50:07 1995. * translated by f2c (version 19950721) and with lots of cleanup * to make it resemble C by: * MJ Olesen, Queen's University at Kingston, 1995-97 */ /*{{{ Copyright: */ /* * Copyright(c)1995,97 Mark Olesen * Queen's Univ at Kingston (Canada) * * Permission to use, copy, modify, and distribute this software for * any purpose without fee is hereby granted, provided that this * entire notice is included in all copies of any software which is * or includes a copy or modification of this software and in all * copies of the supporting documentation for such software. * * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR * IMPLIED WARRANTY. IN PARTICULAR, NEITHER THE AUTHOR NOR QUEEN'S * UNIVERSITY AT KINGSTON MAKES ANY REPRESENTATION OR WARRANTY OF ANY * KIND CONCERNING THE MERCHANTABILITY OF THIS SOFTWARE OR ITS * FITNESS FOR ANY PARTICULAR PURPOSE. * * All of which is to say that you can do what you like with this * source code provided you don't try to sell it as your own and you * include an unaltered copy of this message (including the * copyright). * * It is also implicitly understood that bug fixes and improvements * should make their way back to the general Internet community so * that everyone benefits. *----------------------------------------------------------------------*/ /*}}}*/ /*{{{ notes: */ /* * Public: * fft_free * fftn / fftnf * (these are documented in the header file) * * Private: * fftradix / fftradixf * * ----------------------------------------------------------------------* * int fftradix (REAL Re[], REAL Im[], size_t nTotal, size_t nPass, * size_t nSpan, int iSign, size_t maxFactors, * size_t maxPerm); * * RE and IM hold the real and imaginary components of the data, and * return the resulting real and imaginary Fourier coefficients. * Multidimensional data *must* be allocated contiguously. There is * no limit on the number of dimensions. * * * Although there is no limit on the number of dimensions, fftradix() * must be called once for each dimension, but the calls may be in * any order. * * NTOTAL = the total number of complex data values * NPASS = the dimension of the current variable * NSPAN/NPASS = the spacing of consecutive data values while indexing * the current variable * ISIGN - see above documentation * * example: * tri-variate transform with Re[n1][n2][n3], Im[n1][n2][n3] * * fftradix (Re, Im, n1*n2*n3, n1, n1, 1, maxf, maxp); * fftradix (Re, Im, n1*n2*n3, n2, n1*n2, 1, maxf, maxp); * fftradix (Re, Im, n1*n2*n3, n3, n1*n2*n3, 1, maxf, maxp); * * single-variate transform, * NTOTAL = N = NSPAN = (number of complex data values), * * fftradix (Re, Im, n, n, n, 1, maxf, maxp); * * The data can also be stored in a single array with alternating * real and imaginary parts, the magnitude of ISIGN is changed to 2 * to give correct indexing increment, and data [0] and data [1] used * to pass the initial addresses for the sequences of real and * imaginary values, * * example: * REAL data [2*NTOTAL]; * fftradix (&data[0], &data[1], NTOTAL, nPass, nSpan, 2, maxf, maxp); * * for temporary allocation: * * MAXFACTORS >= the maximum prime factor of NPASS * MAXPERM >= the number of prime factors of NPASS. In addition, * if the square-free portion K of NPASS has two or more prime * factors, then MAXPERM >= (K-1) * * storage in FACTOR for a maximum of 15 prime factors of NPASS. if * NPASS has more than one square-free factor, the product of the * square-free factors must be <= 210 array storage for maximum prime * factor of 23 the following two constants should agree with the * array dimensions. * ----------------------------------------------------------------------*/ /*}}}*/ /*{{{ Revisions: */ /* * 26 July 95 John Beale * - added maxf and maxp as parameters to fftradix() * * 28 July 95 Mark Olesen * - cleaned-up the Fortran 66 goto spaghetti, only 3 labels remain. * * - added fft_free() to provide some measure of control over * allocation/deallocation. * * - added fftn() wrapper for multidimensional FFTs * * - use -DFFT_NOFLOAT or -DFFT_NODOUBLE to avoid compiling that * precision. Note suffix `f' on the function names indicates * float precision. * * - revised documentation * * 31 July 95 Mark Olesen * - added GNU Public License * - more cleanup * - define SUN_BROKEN_REALLOC to use malloc() instead of realloc() * on the first pass through, apparently needed for old libc * - removed #error directive in favour of some code that simply * won't compile (generate an error that way) * * 1 Aug 95 Mark Olesen * - define FFT_RADIX4 to only have radix 2, radix 4 transforms * - made fftradix /fftradixf () static scope, just use fftn() * instead. If you have good ideas about fixing the factors * in fftn() please do so. * * 8 Jan 95 mj olesen * - fixed typo's, including one that broke scaling for scaling by * total number of matrix elements or the square root of same * - removed unnecessary casts from allocations * * 10 Dec 96 mj olesen * - changes defines to compile *without* float support by default, * use -DFFT_FLOAT to enable. * - shifted some variables to local scope (better hints for optimizer) * - added Michael Steffens * Fortran 90 module * - made it simpler to pass dimensions for 1D FFT. * * 23 Feb 97 Mark Olesen * - removed the GNU Public License (see 21 July 1995 entry), * which should make it clear why I have the right to do so. * - Added copyright notice and submitted to netlib * - Moved documentation for the public functions to the header * files where is will always be available. * * 11 Nov 97 Robin Williams * - fixed all temporaries to double precision using REALFIX, * following suggestion from Scott Wurcer * ----------------------------------------------------------------------*/ /*}}}*/ #ifndef _FFTN_C #define _FFTN_C /* we use CPP to re-include this same file for double/float cases */ #if !defined (lint) && !defined (__FILE__) #error Your compiler is sick! /* define __FILE__ yourself (a string) eg, something like D__FILE__=\"fftn.c\" */ #endif #include #include #include #include "fftn.h" /*{{{ defines/constants */ #ifndef M_PI # define M_PI 3.14159265358979323846264338327950288 #endif #ifndef SIN60 # define SIN60 0.86602540378443865 /* sin(60 deg) */ # define COS72 0.30901699437494742 /* cos(72 deg) */ # define SIN72 0.95105651629515357 /* sin(72 deg) */ #endif /*}}}*/ /*{{{ static parameters - for memory management */ static size_t SpaceAlloced = 0; static size_t MaxPermAlloced = 0; /* temp space, (void *) since both float and double routines use it */ static void * Tmp0 = NULL; /* temp space for real part */ static void * Tmp1 = NULL; /* temp space for imaginary part */ static void * Tmp2 = NULL; /* temp space for Cosine values */ static void * Tmp3 = NULL; /* temp space for Sine values */ static int * Perm = NULL; /* Permutation vector */ #define NFACTOR 11 static int factor [NFACTOR]; /*}}}*/ /*{{{ fft_free() */ void fft_free (void) { SpaceAlloced = MaxPermAlloced = 0; if (Tmp0) { free (Tmp0); Tmp0 = NULL; } if (Tmp1) { free (Tmp1); Tmp1 = NULL; } if (Tmp2) { free (Tmp2); Tmp2 = NULL; } if (Tmp3) { free (Tmp3); Tmp3 = NULL; } if (Perm) { free (Perm); Perm = NULL; } } /*}}}*/ /* return the number of factors */ static int factorize (int nPass, int * kt) { int nFactor = 0; int j, jj; *kt = 0; /* determine the factors of n */ while ((nPass % 16) == 0) /* factors of 4 */ { factor [nFactor++] = 4; nPass /= 16; } j = 3; jj = 9; /* factors of 3, 5, 7, ... */ do { while ((nPass % jj) == 0) { factor [nFactor++] = j; nPass /= jj; } j += 2; jj = j * j; } while (jj <= nPass); if (nPass <= 4) { *kt = nFactor; factor [nFactor] = nPass; if (nPass != 1) nFactor++; } else { if (nPass - (nPass / 4 << 2) == 0) { factor [nFactor++] = 2; nPass /= 4; } *kt = nFactor; j = 2; do { if ((nPass % j) == 0) { factor [nFactor++] = j; nPass /= j; } j = ((j + 1) / 2 << 1) + 1; } while (j <= nPass); } if (*kt) { j = *kt; do factor [nFactor++] = factor [--j]; while (j); } return nFactor; } /* re-include this source file on the second pass through */ /*{{{ defines for re-including double precision */ #ifdef FFT_NODOUBLE # ifndef FFT_FLOAT # define FFT_FLOAT # endif #else # undef REALFIX # undef REAL # undef FFTN # undef FFTNS # undef FFTRADIX # undef FFTRADIXS /* defines for double */ # define REAL double # define REALFIX double # define FFTN fftn # define FFTNS "fftn" # define FFTRADIX fftradix # define FFTRADIXS "fftradix" /* double precision routine */ static int fftradix (double Re[], double Im[], size_t nTotal, size_t nPass, size_t nSpan, int isign, int maxFactors, int maxPerm); # include __FILE__ /* include this file again */ #endif /*}}}*/ /*{{{ defines for re-including float precision */ #ifdef FFT_FLOAT # undef REAL # undef REALFIX # undef FFTN # undef FFTNS # undef FFTRADIX # undef FFTRADIXS /* defines for float */ # define REAL float # define REALFIX double # define FFTN fftnf /* trailing 'f' for float */ # define FFTNS "fftnf" /* name for error message */ # define FFTRADIX fftradixf /* trailing 'f' for float */ # define FFTRADIXS "fftradixf" /* name for error message */ /* float precision routine */ static int fftradixf (float Re[], float Im[], size_t nTotal, size_t nPass, size_t nSpan, int isign, int maxFactors, int maxPerm); # include __FILE__ /* include this file again */ #endif /*}}}*/ #else /* _FFTN_C */ /* * use macros to access the Real/Imaginary parts so that it's possible * to substitute different macros if a complex struct is used */ #ifndef Re_Data # define Re_Data(i) Re[i] # define Im_Data(i) Im[i] #endif /* * */ int FFTN (int ndim, const int dims [], REAL Re [], REAL Im [], int iSign, REAL scaling) { size_t nTotal; int maxFactors, maxPerm; /* * tally the number of elements in the data array * and determine the number of dimensions */ nTotal = 1; if (ndim) { if (dims != NULL) { int i; /* number of dimensions was specified */ for (i = 0; i < ndim; i++) { if (dims [i] <= 0) goto Dimension_Error; nTotal *= dims [i]; } } else nTotal *= ndim; } else { int i; /* determine # of dimensions from zero-terminated list */ if (dims == NULL) goto Dimension_Error; for (ndim = i = 0; dims [i]; i++) { if (dims [i] <= 0) goto Dimension_Error; nTotal *= dims [i]; ndim++; } } /* determine maximum number of factors and permuations */ #if 1 /* * follow John Beale's example, just use the largest dimension and don't * worry about excess allocation. May be someone else will do it? */ if (dims != NULL) { int i; for (maxFactors = maxPerm = 1, i = 0; i < ndim; i++) { if (dims [i] > maxFactors) maxFactors = dims [i]; if (dims [i] > maxPerm) maxPerm = dims [i]; } } else { maxFactors = maxPerm = nTotal; } #else /* use the constants used in the original Fortran code */ maxFactors = 23; maxPerm = 209; #endif /* loop over the dimensions: */ if (dims != NULL) { size_t nSpan = 1; int i; for (i = 0; i < ndim; i++) { int ret; nSpan *= dims [i]; ret = FFTRADIX (Re, Im, nTotal, dims [i], nSpan, iSign, maxFactors, maxPerm); /* exit, clean-up already done */ if (ret) return ret; } } else { int ret; ret = FFTRADIX (Re, Im, nTotal, nTotal, nTotal, iSign, maxFactors, maxPerm); /* exit, clean-up already done */ if (ret) return ret; } /* Divide through by the normalizing constant: */ if (scaling && scaling != 1.0) { int i; if (iSign < 0) iSign = -iSign; if (scaling < 0.0) scaling = (scaling < -1.0) ? sqrt (nTotal) : nTotal; scaling = 1.0 / scaling; /* multiply is often faster */ for (i = 0; i < nTotal; i += iSign) { Re_Data (i) *= scaling; Im_Data (i) *= scaling; } } return 0; Dimension_Error: fprintf (stderr, "Error: " FFTNS "() - dimension error\n"); fft_free (); /* free-up memory */ return -1; } /*----------------------------------------------------------------------*/ /* * singleton's mixed radix routine * * could move allocation out to fftn(), but leave it here so that it's * possible to make this a standalone function */ static int FFTRADIX (REAL Re [], REAL Im [], size_t nTotal, size_t nPass, size_t nSpan, int iSign, int maxFactors, int maxPerm) { int ii, nFactor, kspan, ispan, inc; int j, jc, jf, jj, k, k1, k3, kk, kt, nn, ns, nt; REALFIX radf; REALFIX c1, c2, c3, cd; REALFIX s1, s2, s3, sd; REALFIX * Rtmp = NULL; /* temp space for real part*/ REALFIX * Itmp = NULL; /* temp space for imaginary part */ REALFIX * Cos = NULL; /* Cosine values */ REALFIX * Sin = NULL; /* Sine values */ #ifndef FFT_RADIX4 REALFIX s60 = SIN60; /* sin(60 deg) */ REALFIX s72 = SIN72; /* sin(72 deg) */ REALFIX c72 = COS72; /* cos(72 deg) */ #endif REALFIX pi2 = M_PI; /* use PI first, 2 PI later */ /* gcc complains about k3 being uninitialized, but I can't find out where * or why ... it looks okay to me. * * initialize to make gcc happy */ k3 = 0; /* gcc complains about c2, c3, s2,s3 being uninitialized, but they're * only used for the radix 4 case and only AFTER the (s1 == 0.0) pass * through the loop at which point they will have been calculated. * * initialize to make gcc happy */ c2 = c3 = s2 = s3 = 0.0; /* Parameter adjustments, was fortran so fix zero-offset */ Re--; Im--; if (nPass < 2) return 0; /* allocate storage */ if (SpaceAlloced < maxFactors * sizeof (REALFIX)) { #ifdef SUN_BROKEN_REALLOC if (!SpaceAlloced) /* first time */ { SpaceAlloced = maxFactors * sizeof (REALFIX); Tmp0 = malloc (SpaceAlloced); Tmp1 = malloc (SpaceAlloced); Tmp2 = malloc (SpaceAlloced); Tmp3 = malloc (SpaceAlloced); } else { #endif SpaceAlloced = maxFactors * sizeof (REALFIX); Tmp0 = realloc (Tmp0, SpaceAlloced); Tmp1 = realloc (Tmp1, SpaceAlloced); Tmp2 = realloc (Tmp2, SpaceAlloced); Tmp3 = realloc (Tmp3, SpaceAlloced); #ifdef SUN_BROKEN_REALLOC } #endif } else { /* allow full use of alloc'd space */ maxFactors = SpaceAlloced / sizeof (REALFIX); } if (MaxPermAlloced < maxPerm) { #ifdef SUN_BROKEN_REALLOC if (!MaxPermAlloced) /* first time */ Perm = malloc (maxPerm * sizeof(int)); else #endif Perm = realloc (Perm, maxPerm * sizeof(int)); MaxPermAlloced = maxPerm; } else { /* allow full use of alloc'd space */ maxPerm = MaxPermAlloced; } if (!Tmp0 || !Tmp1 || !Tmp2 || !Tmp3 || !Perm) goto Memory_Error; /* assign pointers */ Rtmp = (REALFIX *) Tmp0; Itmp = (REALFIX *) Tmp1; Cos = (REALFIX *) Tmp2; Sin = (REALFIX *) Tmp3; /* * Function Body */ inc = iSign; if (iSign < 0) { #ifndef FFT_RADIX4 s60 = -s60; s72 = -s72; #endif pi2 = -pi2; inc = -inc; /* absolute value */ } /* adjust for strange increments */ nt = inc * nTotal; ns = inc * nSpan; kspan = ns; nn = nt - inc; jc = ns / nPass; radf = pi2 * (double) jc; pi2 *= 2.0; /* use 2 PI from here on */ ii = 0; jf = 0; /* determine the factors of n */ nFactor = factorize (nPass, &kt); /* test that nFactors is in range */ if (nFactor > NFACTOR) { fprintf (stderr, "Error: " FFTRADIXS "() - exceeded number of factors\n"); goto Memory_Error; } /* compute fourier transform */ for (;;) { sd = radf / (double) kspan; cd = sin (sd); cd = 2.0 * cd * cd; sd = sin (sd + sd); kk = 1; ii++; switch (factor [ii - 1]) { case 2: /* transform for factor of 2 (including rotation factor) */ kspan /= 2; k1 = kspan + 2; do { do { REALFIX tmpr; REALFIX tmpi; int k2; k2 = kk + kspan; tmpr = Re_Data (k2); tmpi = Im_Data (k2); Re_Data (k2) = Re_Data (kk) - tmpr; Im_Data (k2) = Im_Data (kk) - tmpi; Re_Data (kk) += tmpr; Im_Data (kk) += tmpi; kk = k2 + kspan; } while (kk <= nn); kk -= nn; } while (kk <= jc); if (kk > kspan) goto Permute_Results; /* exit infinite loop */ do { int k2; c1 = 1.0 - cd; s1 = sd; do { REALFIX tmp; do { do { REALFIX tmpr; REALFIX tmpi; k2 = kk + kspan; tmpr = Re_Data (kk) - Re_Data (k2); tmpi = Im_Data (kk) - Im_Data (k2); Re_Data (kk) += Re_Data (k2); Im_Data (kk) += Im_Data (k2); Re_Data (k2) = c1 * tmpr - s1 * tmpi; Im_Data (k2) = s1 * tmpr + c1 * tmpi; kk = k2 + kspan; } while (kk < nt); k2 = kk - nt; c1 = -c1; kk = k1 - k2; } while (kk > k2); tmp = c1 - (cd * c1 + sd * s1); s1 = sd * c1 - cd * s1 + s1; c1 = 2.0 - (tmp * tmp + s1 * s1); s1 *= c1; c1 *= tmp; kk += jc; } while (kk < k2); k1 += (inc + inc); kk = (k1 - kspan) / 2 + jc; } while (kk <= jc + jc); break; case 4: /* transform for factor of 4 */ ispan = kspan; kspan /= 4; do { c1 = 1.0; s1 = 0.0; do { do { REALFIX ajm, ajp, akm, akp; REALFIX bjm, bjp, bkm, bkp; int k2; k1 = kk + kspan; k2 = k1 + kspan; k3 = k2 + kspan; akp = Re_Data (kk) + Re_Data (k2); akm = Re_Data (kk) - Re_Data (k2); ajp = Re_Data (k1) + Re_Data (k3); ajm = Re_Data (k1) - Re_Data (k3); bkp = Im_Data (kk) + Im_Data (k2); bkm = Im_Data (kk) - Im_Data (k2); bjp = Im_Data (k1) + Im_Data (k3); bjm = Im_Data (k1) - Im_Data (k3); Re_Data (kk) = akp + ajp; Im_Data (kk) = bkp + bjp; ajp = akp - ajp; bjp = bkp - bjp; if (iSign < 0) { akp = akm + bjm; bkp = bkm - ajm; akm -= bjm; bkm += ajm; } else { akp = akm - bjm; bkp = bkm + ajm; akm += bjm; bkm -= ajm; } /* avoid useless multiplies */ if (s1 == 0.0) { Re_Data (k1) = akp; Re_Data (k2) = ajp; Re_Data (k3) = akm; Im_Data (k1) = bkp; Im_Data (k2) = bjp; Im_Data (k3) = bkm; } else { Re_Data (k1) = akp * c1 - bkp * s1; Re_Data (k2) = ajp * c2 - bjp * s2; Re_Data (k3) = akm * c3 - bkm * s3; Im_Data (k1) = akp * s1 + bkp * c1; Im_Data (k2) = ajp * s2 + bjp * c2; Im_Data (k3) = akm * s3 + bkm * c3; } kk = k3 + kspan; } while (kk <= nt); c2 = c1 - (cd * c1 + sd * s1); s1 = sd * c1 - cd * s1 + s1; c1 = 2.0 - (c2 * c2 + s1 * s1); s1 *= c1; c1 *= c2; /* values of c2, c3, s2, s3 that will get used next time */ c2 = c1 * c1 - s1 * s1; s2 = 2.0 * c1 * s1; c3 = c2 * c1 - s2 * s1; s3 = c2 * s1 + s2 * c1; kk = kk - nt + jc; } while (kk <= kspan); kk = kk - kspan + inc; } while (kk <= jc); if (kspan == jc) goto Permute_Results; /* exit infinite loop */ break; default: /* transform for odd factors */ #ifdef FFT_RADIX4 fprintf (stderr, "Error: " FFTRADIXS "(): compiled for radix 2/4 only\n"); fft_free (); /* free-up memory */ return -1; break; #else /* FFT_RADIX4 */ ispan = kspan; k = factor [ii - 1]; kspan /= factor [ii - 1]; switch (factor [ii - 1]) { case 3: /* transform for factor of 3 (optional code) */ do { do { REALFIX aj, tmpr; REALFIX bj, tmpi; int k2; k1 = kk + kspan; k2 = k1 + kspan; tmpr = Re_Data (kk); tmpi = Im_Data (kk); aj = Re_Data (k1) + Re_Data (k2); bj = Im_Data (k1) + Im_Data (k2); Re_Data (kk) = tmpr + aj; Im_Data (kk) = tmpi + bj; tmpr -= 0.5 * aj; tmpi -= 0.5 * bj; aj = (Re_Data (k1) - Re_Data (k2)) * s60; bj = (Im_Data (k1) - Im_Data (k2)) * s60; Re_Data (k1) = tmpr - bj; Re_Data (k2) = tmpr + bj; Im_Data (k1) = tmpi + aj; Im_Data (k2) = tmpi - aj; kk = k2 + kspan; } while (kk < nn); kk -= nn; } while (kk <= kspan); break; case 5: /* transform for factor of 5 (optional code) */ c2 = c72 * c72 - s72 * s72; s2 = 2.0 * c72 * s72; do { do { REALFIX aa, aj, ak, ajm, ajp, akm, akp; REALFIX bb, bj, bk, bjm, bjp, bkm, bkp; int k2, k4; k1 = kk + kspan; k2 = k1 + kspan; k3 = k2 + kspan; k4 = k3 + kspan; akp = Re_Data (k1) + Re_Data (k4); akm = Re_Data (k1) - Re_Data (k4); bkp = Im_Data (k1) + Im_Data (k4); bkm = Im_Data (k1) - Im_Data (k4); ajp = Re_Data (k2) + Re_Data (k3); ajm = Re_Data (k2) - Re_Data (k3); bjp = Im_Data (k2) + Im_Data (k3); bjm = Im_Data (k2) - Im_Data (k3); aa = Re_Data (kk); bb = Im_Data (kk); Re_Data (kk) = aa + akp + ajp; Im_Data (kk) = bb + bkp + bjp; ak = akp * c72 + ajp * c2 + aa; bk = bkp * c72 + bjp * c2 + bb; aj = akm * s72 + ajm * s2; bj = bkm * s72 + bjm * s2; Re_Data (k1) = ak - bj; Re_Data (k4) = ak + bj; Im_Data (k1) = bk + aj; Im_Data (k4) = bk - aj; ak = akp * c2 + ajp * c72 + aa; bk = bkp * c2 + bjp * c72 + bb; aj = akm * s2 - ajm * s72; bj = bkm * s2 - bjm * s72; Re_Data (k2) = ak - bj; Re_Data (k3) = ak + bj; Im_Data (k2) = bk + aj; Im_Data (k3) = bk - aj; kk = k4 + kspan; } while (kk < nn); kk -= nn; } while (kk <= kspan); break; default: k = factor [ii - 1]; if (jf != k) { jf = k; s1 = pi2 / (double) jf; c1 = cos (s1); s1 = sin (s1); if (jf > maxFactors) goto Memory_Error; Cos [jf - 1] = 1.0; Sin [jf - 1] = 0.0; j = 1; do { Cos [j - 1] = Cos [k - 1] * c1 + Sin [k - 1] * s1; Sin [j - 1] = Cos [k - 1] * s1 - Sin [k - 1] * c1; k--; Cos [k - 1] = Cos [j - 1]; Sin [k - 1] = -Sin [j - 1]; j++; } while (j < k); } do { do { REALFIX aa, ak; REALFIX bb, bk; int k2; aa = ak = Re_Data (kk); bb = bk = Im_Data (kk); k1 = kk; k2 = kk + ispan; j = 1; k1 += kspan; do { k2 -= kspan; Rtmp [j] = Re_Data (k1) + Re_Data (k2); ak += Rtmp [j]; Itmp [j] = Im_Data (k1) + Im_Data (k2); bk += Itmp [j]; j++; Rtmp [j] = Re_Data (k1) - Re_Data (k2); Itmp [j] = Im_Data (k1) - Im_Data (k2); j++; k1 += kspan; } while (k1 < k2); Re_Data (kk) = ak; Im_Data (kk) = bk; k1 = kk; k2 = kk + ispan; j = 1; do { REALFIX aj = 0.0; REALFIX bj = 0.0; k1 += kspan; k2 -= kspan; jj = j; ak = aa; bk = bb; k = 1; do { ak += Rtmp [k] * Cos [jj - 1]; bk += Itmp [k] * Cos [jj - 1]; k++; aj += Rtmp [k] * Sin [jj - 1]; bj += Itmp [k] * Sin [jj - 1]; k++; jj += j; if (jj > jf) jj -= jf; } while (k < jf); k = jf - j; Re_Data (k1) = ak - bj; Im_Data (k1) = bk + aj; Re_Data (k2) = ak + bj; Im_Data (k2) = bk - aj; j++; } while (j < k); kk += ispan; } while (kk <= nn); kk -= nn; } while (kk <= kspan); break; } /* multiply by rotation factor (except for factors of 2 and 4) */ if (ii == nFactor) goto Permute_Results; /* exit infinite loop */ kk = jc + 1; do { c2 = 1.0 - cd; s1 = sd; do { c1 = c2; s2 = s1; kk += kspan; do { REALFIX tmp; do { REALFIX ak; ak = Re_Data (kk); Re_Data (kk) = c2 * ak - s2 * Im_Data (kk); Im_Data (kk) = s2 * ak + c2 * Im_Data (kk); kk += ispan; } while (kk <= nt); tmp = s1 * s2; s2 = s1 * c2 + c1 * s2; c2 = c1 * c2 - tmp; kk = kk - nt + kspan; } while (kk <= ispan); c2 = c1 - (cd * c1 + sd * s1); s1 += sd * c1 - cd * s1; c1 = 2.0 - (c2 * c2 + s1 * s1); s1 *= c1; c2 *= c1; kk = kk - ispan + jc; } while (kk <= kspan); kk = kk - kspan + jc + inc; } while (kk <= jc + jc); break; #endif /* FFT_RADIX4 */ } } /* permute the results to normal order -- done in two stages */ /* permutation for square factors of n */ Permute_Results: Perm [0] = ns; if (kt) { int k2; k = kt + kt + 1; if (k > nFactor) k--; Perm [k] = jc; j = 1; do { Perm [j] = Perm [j - 1] / factor [j - 1]; Perm [k - 1] = Perm [k] * factor [j - 1]; j++; k--; } while (j < k); k3 = Perm [k]; kspan = Perm [1]; kk = jc + 1; k2 = kspan + 1; j = 1; if (nPass != nTotal) { /* permutation for multivariate transform */ Permute_Multi: do { do { k = kk + jc; do { /* swap * Re_Data (kk) <> Re_Data (k2) * Im_Data (kk) <> Im_Data (k2) */ REALFIX tmp; tmp = Re_Data (kk); Re_Data (kk) = Re_Data (k2); Re_Data (k2) = tmp; tmp = Im_Data (kk); Im_Data (kk) = Im_Data (k2); Im_Data (k2) = tmp; kk += inc; k2 += inc; } while (kk < k); kk += (ns - jc); k2 += (ns - jc); } while (kk < nt); k2 = k2 - nt + kspan; kk = kk - nt + jc; } while (k2 < ns); do { do { k2 -= Perm [j - 1]; j++; k2 = Perm [j] + k2; } while (k2 > Perm [j - 1]); j = 1; do { if (kk < k2) goto Permute_Multi; kk += jc; k2 += kspan; } while (k2 < ns); } while (kk < ns); } else { /* permutation for single-variate transform (optional code) */ Permute_Single: do { /* swap * Re_Data (kk) <> Re_Data (k2) * Im_Data (kk) <> Im_Data (k2) */ REALFIX t; t = Re_Data (kk); Re_Data (kk) = Re_Data (k2); Re_Data (k2) = t; t = Im_Data (kk); Im_Data (kk) = Im_Data (k2); Im_Data (k2) = t; kk += inc; k2 += kspan; } while (k2 < ns); do { do { k2 -= Perm [j - 1]; j++; k2 = Perm [j] + k2; } while (k2 > Perm [j - 1]); j = 1; do { if (kk < k2) goto Permute_Single; kk += inc; k2 += kspan; } while (k2 < ns); } while (kk < ns); } jc = k3; } if ((kt << 1) + 1 >= nFactor) return 0; ispan = Perm [kt]; /* permutation for square-free factors of n */ j = nFactor - kt; factor [j] = 1; do { factor [j - 1] *= factor [j]; j--; } while (j != kt); nn = factor [kt] - 1; kt++; if (nn > maxPerm) goto Memory_Error; j = jj = 0; for (;;) { int k2; k = kt + 1; k2 = factor [kt - 1]; kk = factor [k - 1]; j++; if (j > nn) break; /* exit infinite loop */ jj += kk; while (jj >= k2) { jj -= k2; k2 = kk; kk = factor [k++]; jj += kk; } Perm [j - 1] = jj; } /* determine the permutation cycles of length greater than 1 */ j = 0; for (;;) { do { kk = Perm [j++]; } while (kk < 0); if (kk != j) { do { k = kk; kk = Perm [k - 1]; Perm [k - 1] = -kk; } while (kk != j); k3 = kk; } else { Perm [j - 1] = -j; if (j == nn) break; /* exit infinite loop */ } } maxFactors *= inc; /* reorder a and b, following the permutation cycles */ for (;;) { j = k3 + 1; nt -= ispan; ii = nt - inc + 1; if (nt < 0) break; /* exit infinite loop */ do { do { j--; } while (Perm [j - 1] < 0); jj = jc; do { int k2; if (jj < maxFactors) kspan = jj; else kspan = maxFactors; jj -= kspan; k = Perm [j - 1]; kk = jc * k + ii + jj; k1 = kk + kspan; k2 = 0; do { Rtmp [k2] = Re_Data (k1); Itmp [k2] = Im_Data (k1); k2++; k1 -= inc; } while (k1 != kk); do { k1 = kk + kspan; k2 = k1 - jc * (k + Perm [k - 1]); k = -Perm [k - 1]; do { Re_Data (k1) = Re_Data (k2); Im_Data (k1) = Im_Data (k2); k1 -= inc; k2 -= inc; } while (k1 != kk); kk = k2; } while (k != j); k1 = kk + kspan; k2 = 0; do { Re_Data (k1) = Rtmp [k2]; Im_Data (k1) = Itmp [k2]; k2++; k1 -= inc; } while (k1 != kk); } while (jj); } while (j != 1); } return 0; /* exit point here */ /* alloc or other problem, do some clean-up */ Memory_Error: fprintf (stderr, "Error: " FFTRADIXS "() - insufficient memory.\n"); fft_free (); /* free-up memory */ return -1; } #endif /* _FFTN_C */ /*----------------------- end-of-file (C source) -----------------------*/ PDL-2.018/Lib/FFT/fftn.h0000644060175006010010000001014012562522364012632 0ustar chmNone/*--------------------------------*-C-*---------------------------------* * File: * fftn.h * * Singleton's multivariate complex Fourier transform, computed in * place using mixed-radix Fast Fourier Transform algorithm. * * Called here `fftn' since it does a radix-n FFT on n-dimensional data * * Copyright(c)1995,97 Mark Olesen * Queen's Univ at Kingston (Canada) * * Permission to use, copy, modify, and distribute this software for * any purpose without fee is hereby granted, provided that this * entire notice is included in all copies of any software which is * or includes a copy or modification of this software and in all * copies of the supporting documentation for such software. * * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR * IMPLIED WARRANTY. IN PARTICULAR, NEITHER THE AUTHOR NOR QUEEN'S * UNIVERSITY AT KINGSTON MAKES ANY REPRESENTATION OR WARRANTY OF ANY * KIND CONCERNING THE MERCHANTABILITY OF THIS SOFTWARE OR ITS * FITNESS FOR ANY PARTICULAR PURPOSE. * * All of which is to say that you can do what you like with this * source code provided you don't try to sell it as your own and you * include an unaltered copy of this message (including the * copyright). * * It is also implicitly understood that bug fixes and improvements * should make their way back to the general Internet community so * that everyone benefits. * * Brief overview of parameters: * ---------------------------------------------------------------------* * Re[]: real value array * Im[]: imaginary value array * nTotal: total number of complex values * nPass: number of elements involved in this pass of transform * nSpan: nspan/nPass = number of bytes to increment pointer * in Re[] and Im[] * isign: exponent: +1 = forward -1 = reverse * scaling: normalizing constant by which the final result is DIVIDED * scaling == -1, normalize by total dimension of the transform * scaling < -1, normalize by the square-root of the total dimension * * * Slightly more detailed information: * ----------------------------------------------------------------------* * void fft_free (void); * * free-up allocated temporary storage after finished all the Fourier * transforms. * * ----------------------------------------------------------------------* * * int fftn (int ndim, const int dims[], REAL Re[], REAL Im[], * int iSign, double scaling); * * NDIM = the total number dimensions * DIMS = a vector of array sizes * if NDIM is zero then DIMS must be zero-terminated * * RE and IM hold the real and imaginary components of the data, and * return the resulting real and imaginary Fourier coefficients. * Multidimensional data *must* be allocated contiguously. There is * no limit on the number of dimensions. * * ISIGN = the sign of the complex exponential * (ie, forward or inverse FFT) * the magnitude of ISIGN (normally 1) is used to determine * the correct indexing increment (see below). * * SCALING = normalizing constant by which the final result is DIVIDED * if SCALING == -1, normalize by total dimension of the transform * if SCALING < -1, normalize by the square-root of the total dimension * * example: * tri-variate transform with Re[n3][n2][n1], Im[n3][n2][n1] * * int dims[3] = {n1,n2,n3} * fftn (3, dims, Re, Im, 1, scaling); * * or, using a null terminated dimension list * int dims[4] = {n1,n2,n3,0} * fftn (0, dims, Re, Im, 1, scaling); * ----------------------------------------------------------------------*/ #ifndef _FFTN_H #define _FFTN_H #ifdef __cplusplus extern "C" { #endif extern void fft_free (void); /* double precision routine */ extern int fftn (int /* ndim */, const int /* dims */[], double /* Re */[], double /* Im */[], int /* isign */, double /* scaling */); /* float precision routine */ extern int fftnf (int /* ndim */, const int /* dims */[], float /* Re */[], float /* Im */[], int /* isign */, float /* scaling */); #ifdef __cplusplus } #endif #endif /* _FFTN_H */ /*----------------------- end-of-file (C header) -----------------------*/ PDL-2.018/Lib/FFT/Makefile.PL0000644060175006010010000000054512562522364013506 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["fft.pd", qw(FFT PDL::FFT)]); my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} .= ' fftn.o'; $hash{DEFINE} .= ' -DFFT_FLOAT'; $hash{LIBS} = ['-lm'] unless $^O =~ /MSWin/; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/Filter/0000755060175006010010000000000013110402046012316 5ustar chmNonePDL-2.018/Lib/Filter/Linear.pm0000644060175006010010000000414112562522364014106 0ustar chmNone=head1 NAME PDL::Filter::Linear - linear filtering for PDL =head1 SYNOPSIS $a = new PDL::Filter::Linear( {Weights => $v, Point => 10}); $b = new PDL::Filter::Gaussian(15,2); # 15 points, 2 std devn. ($pred,$corrslic) = $a->predict($dat); =head1 DESCRIPTION A wrapper for generic linear filters. Just for convenience. This should in the future use DataPresenter. Also, this class should at some point learn to do FFT whenever it is useful. =cut package PDL::Filter::Linear; use PDL; use PDL::Basic; use PDL::Slices; use PDL::Primitive; use strict; sub new($$) { my($type,$pars) = @_; my $this = bless {},$type; barf("Must specify weights\n") unless defined $pars->{Weights}; $this->{Weights} = delete $pars->{Weights}; $this->{Point} = defined $pars->{Point} ? $pars->{Point} : 0; $this; } sub predict($$) { my($this,$data) = @_; my $ldata = $data->lags(0,1,$this->{Weights}->getdim(0)); inner($ldata->xchg(0,1),$this->{Weights}, (my $pred = PDL->null)); return wantarray ? ($pred,$ldata->slice(":,($this->{Point})")) : $pred ; } package PDL::Filter::Gaussian; use PDL; use PDL::Basic; use PDL::Slices; use PDL::Primitive; use strict; @PDL::Filter::Gaussian::ISA = qw/PDL::Filter::Linear/; sub new($$) { my($type,$npoints,$sigma) = @_; my $cent = int($npoints/2); my $x = ((PDL->zeroes($npoints )->xvals) - $cent)->float; my $y = exp(-($x**2)/(2*$sigma**2)); # Normalize to unit total $y /= sum($y); return PDL::Filter::Linear::new($type,{Weights => $y, Point => $cent}); } # Savitzky-Golay (see Numerical Recipes) package PDL::Filter::SavGol; use PDL; use PDL::Basic; use PDL::Slices; use PDL::Primitive; use strict; @PDL::Filter::Gaussian::ISA = qw/PDL::Filter::Linear/; # XXX Doesn't work sub new($$) { my($type,$deg,$nleft,$nright) = @_; my $npoints = $nright + $nleft + 1; my $x = ((PDL->zeroes($npoints )->xvals) - $nleft)->float; my $mat1 = ((PDL->zeroes($npoints,$deg+1)->xvals))->float; for(0..$deg-1) { (my $tmp = $mat1->slice(":,($_)")) .= ($x ** $_); } my $y; # Normalize to unit total return PDL::Filter::Linear::new($type,{Weights => $y, Point => $nleft}); } PDL-2.018/Lib/Filter/LinPred.pm0000644060175006010010000001545612562522364014244 0ustar chmNone=head1 NAME PDL::Filter::LinPred - Linear predictive filtering =head1 SYNOPSIS $a = new PDL::Filter::LinPred( {NLags => 10, LagInterval => 2, LagsBehind => 2, Data => $dat}); ($pd,$corrslic) = $a->predict($dat); =head1 DESCRIPTION A filter by doing linear prediction: tries to predict the next value in a data stream as accurately as possible. The filtered data is the predicted value. The parameters are =over 8 =item NLags Number of time lags used for prediction =item LagInterval How many points each lag should be =item LagsBehind If, for some strange reason, you wish to predict not the next but the one after that (i.e. usually f(t) is predicted from f(t-1) and f(t-2) etc., but with LagsBehind => 2, f(t) is predicted from f(t-2) and f(t-3)). =item Data The input data, which may contain other dimensions past the first (time). The extraneous dimensions are assumed to represent epochs so the data is just concatenated. =item AutoCovar As an alternative to B, you can just give the temporal autocorrelation function. =item Smooth Don't do prediction or filtering but smoothing. =back The method B gives a prediction for some data plus a corresponding slice of the data, if evaluated in list context. This slice is given so that you may, if you wish, easily plot them atop each other. The rest of the documentation is under lazy evaluation. =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Filter::LinSmooth; use PDL; use PDL::Basic; use PDL::Slatec; use PDL::Slices; use PDL::Primitive; use strict; @PDL::Filter::LinSmooth::ISA = qw/PDL::Filter::LinPred/; sub _ntotlags { my($this) = @_; return 2 * ( $this->{NLags} + $this->{LagsBehind} ); } # nlags == 3, lagsbehind == 1 -> totlags = 7 # # Symautocor: 6543210123456 # -> lags(nlags) -> # # 43210123456 # 54321012345 # 65432101234 # SMOOTH sub _mk_mat { my($this) = @_; local $PDL::Debug = 1; my $n = $this->{LagsBehind}; my $nl = $this->{NLags}; my $nl1 = $nl-1; my $auc = $this->{AutoCor}; my $autocov = PDL::float PDL->zeroes($nl*2,$nl*2); $this->{AutoCov} = $autocov; my $sal = $this->{SymAutoCor}->px->lags(0,1,$this->{NLags})->px; print "L,LB: $nl,$n\n"; my ($tmp,$tmp2); PDL::Graphics::PG::imag ($sal->copy); # First, the 2 diagonal slices ($tmp = $autocov->slice("$nl:-1,$nl:-1")->px) .= ($tmp2 = $autocov->slice("0:".($nl-1).",0:".($nl-1))->px) .= $sal->slice(($this->{NLags}+2*$this->{LagsBehind}-1).":". (-1-($this->{NLags}+2*$this->{LagsBehind}+1)))->px; # Then, the off-diagonal slices ($tmp = $autocov->slice("-1:$nl,$nl1:0")) .= ($tmp2 = $autocov->slice("0:$nl1,$nl:-1")) .= $sal->slice("0:$nl1"); # Invert it my $autocinv = inv($autocov); # print "$autocinv,$auc,$n\n"; $auc->slice("$n:-1"); $this->{AutoSliceUsed} = PDL->zeroes(2*$nl)->float; ($tmp = $this->{AutoSliceUsed}->slice("0:$nl1")) .= $auc->slice(($n+$nl-1).":$n"); ($tmp = $this->{AutoSliceUsed}->slice("-1:$nl")) .= $auc->slice(($n+$nl-1).":$n"); inner($autocinv->xchg(0,1),$this->{AutoSliceUsed},(my $tdw=PDL->null)); $this->{AutoCov} = $autocov; $this->{AutoCovInv} = $autocinv; $this->{Weights} = $tdw; } sub predict ($$) { my($this,$data) = @_; my $nl = $this->{NLags}; my $nl1 = $nl - 1; my $ldata = $data->lags(0,$this->{LagInterval},$this->{NTotLags}+1); print "PREDICT, weights: $this->{Weights}\n"; inner($ldata->xchg(0,1)->slice("-$nl:-1"), $this->{Weights}->slice("-$nl:-1"), (my $pred1=PDL->null)); inner($ldata->xchg(0,1)->slice("0:$nl1"), $this->{Weights}->slice("0:$nl1"), (my $pred2=PDL->null)); my $pred = $pred1 + $pred2; return wantarray ? ($pred,$ldata->slice(":,(".($nl+$this->{LagsBehind}).")"), $pred1, $pred2) : $pred ; } package PDL::Filter::LinPred; use PDL; use PDL::Basic; use PDL::Slatec; use PDL::Slices; use PDL::Primitive; use strict; sub _ntotlags { my($this) = @_; return $this->{NLags} + $this->{LagsBehind} + 1; } # Create the autocovariance matrix in Toeplitz form # FILTER sub _mk_mat { my($this) = @_; local $PDL::Debug = 1; my $n = $this->{LagsBehind}; my $nl = $this->{NLags}; my $nl1 = $nl-1; my $auc = $this->{AutoCor}; print "AUTOCOR: $auc\n"; my $sal = $this->{SymAutoCor}->lags(0,1,$this->{NLags})->px; my $autocov = $sal->slice(($this->{LagsBehind}-1).":".(-1-($this->{LagsBehind}+1))) ->copy()->px; $this->{AutoCov} = $autocov; $| = 1; print "AUTOCOV: \n\n\n"; $autocov->dump; print "FOOBAR\n"; # Invert it my $autocinv = inv($autocov); $this->{AutoSliceUsed} = $auc->slice("$n:-1"); inner($autocinv->xchg(0,1),$this->{AutoSliceUsed},(my $tdw=PDL->null)); $this->{AutoCov} = $autocov; $this->{AutoCovInv} = $autocinv; $this->{Weights} = $tdw; } sub chkdefault ($$) { my ($var,$def); return $def if !ref $var && $var == 0; return defined $var ? $var : $def; } sub new ($$) { my($type,$pars) = @_; my $this = bless {},$type; $this->{NLags} = chkdefault(delete $pars->{NLags}, 2); $this->{LagInterval} = chkdefault(delete $pars->{LagInterval}, 1); $this->{LagsBehind} = chkdefault(delete $pars->{LagsBehind}, 1); $this->{Smooth} = (delete $pars->{Smooth}); $this->{NDeleted} = $this->{LagInterval} * ($this->{NLags} + $this->{LagsBehind}) - 1; $this->{NTotLags} = $this->_ntotlags(); (my $data = delete $pars->{Data}) ; my ($auc,$auc1); if(defined $data) { my $atmp; my $n = $this->{NTotLags}; my $da = avg($data); # Compute autocovariance my $ldata = $data->lags(0,$this->{LagInterval},$n); # XXX This takes too much space.. define a special function. inner($ldata->slice(":,0"),$ldata, ($atmp=PDL->null)); sumover($atmp->xchg(0,1),($auc=PDL->null)); $auc /= $ldata->getdim(0) * $data->getdim(1); $auc -= $da ** 2; # print "AUC: $auc\n"; } elsif(defined ($auc1 = delete $pars->{AutoCovar})) { if($this->{LagInterval} != 1) { $auc = $auc1->slice("0:$this->{LagInterval}:-1"); } else { $auc = $auc1; } } else { barf "Nothing to compute autocovariance from!"; } $this->{AutoCor} = $auc; my $n = $this->{NTotLags}; $this->{SymAutoCor} = (PDL->zeroes($n * 2 - 1)->float); my $tmp; ($tmp = $this->{SymAutoCor}->slice("0:".($n-2))) .= $auc->slice("-1:1"); ($tmp = $this->{SymAutoCor}->slice(($n-1).":-1")) .= $auc->slice("0:-1"); $this->_mk_mat(); $this; } sub predict ($$) { my($this,$data) = @_; my $ldata = $data->lags(0,$this->{LagInterval},$this->{NTotLags}); print "PREDICT, weights: $this->{Weights}\n"; inner($ldata->xchg(0,1)->slice("$this->{LagsBehind}:-1"), $this->{Weights}, (my $pred=PDL->null)); return wantarray ? ($pred,$ldata->slice(":,(0)")) : $pred ; } PDL-2.018/Lib/Filter/Makefile.PL0000644060175006010010000000074312562522364014314 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'PDL::Filter', VERSION_FROM => '../../Basic/Core/Version.pm', PM => { map {($_ => '$(INST_LIBDIR)/Filter/'.$_)} grep { !defined $PDL::Config{WITH_SLATEC} || $PDL::Config{WITH_SLATEC}==1 || !($_ eq 'LinPred.pm') } <*.pm> }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Lib/Fit/0000755060175006010010000000000013110402046011613 5ustar chmNonePDL-2.018/Lib/Fit/Gaussian/0000755060175006010010000000000013110402046013365 5ustar chmNonePDL-2.018/Lib/Fit/Gaussian/gauss.c0000644060175006010010000002550712562522364014704 0ustar chmNone/*LINTLIBRARY*/ /* gauss.c This code provides gaussian fitting routines. Copyright (C) 1997 Karl Glazebrook and Alison Offer Real code Note it is not clear to me that this code is fully debugged. The reason I say that is because I tried using the linear eqn solving routines called elsewhere and they were giving erroneous results. So steal from this code with caution! However it does give good fits to reasonable looking gaussians and tests show correct parameters. KGB 29/Oct/2002 */ #include #include #define NPAR 3 #define MAXITER 1000 /* Malloc 2D ptr array e.g. a[nx][ny] */ static double **malloc2D (int nx, int ny) { int i; double **p; p = (double**) malloc( nx*sizeof(double*) ); /* 1D array of ptrs p[i] */ if (p==NULL) return NULL; for (i=0;i1) { for (irow=1; irow<=icol-1; irow++) { sum = x[irow-1][icol-1]; for (isum=1; isum<=irow-1; isum++) sum -= x[irow-1][isum-1]*x[isum-1][irow-1]; x[irow-1][icol-1] = sum; } } /* L - matrix plus diagonal element of U matrix */ xmax = 0; ipivot = icol; for (irow=icol; irow<=n; irow++) { sum = x[irow-1][icol-1]; if (icol>1) { for(isum=1; isum<=icol-1; isum++) sum -= x[irow-1][isum-1] * x[isum-1][icol-1]; } if (fabs(sum)>xmax) { xmax = sum; ipivot = irow; } x[irow-1][icol-1] = sum; } /* if xmax is very small replace by epsilon to avoid dividing by zero */ if (fabs(xmax)j][j] is L-matrix (diagonal elements are unity) iorder is the permutation of the rows b is the input vector, d is the solution vector */ static void lineq (int n, int ndim, double x[NPAR][NPAR], double b[NPAR], double d[NPAR], int iorder[NPAR]) { int i,isum; double sum; /* solving X.b = d ==> (L.U).b = d or L.(U.b) = d first re-order the vector */ for (i=1; i<=n; i++) d[i-1] = b[iorder[i-1]-1]; /* first find (U.b) */ for(i=2; i<=n; i++) { sum = d[i-1]; for (isum=1; isum<=i-1; isum++) sum -= x[i-1][isum-1] * d[isum-1]; d[i-1] = sum; } /* Now fill out d (solution of X.b) by back substitution */ d[n-1] /= x[n-1][n-1]; for (i=n-1; i>=1; i--){ sum = d[i-1]; for (isum=i+1; isum<=n; isum++) sum -= x[i-1][isum-1] * d[isum-1]; d[i-1] = sum / x[i-1][i-1]; } } /* ======================================================================== My C version of Alison's subroutine to fit a non-linear functions using the Levenberg-Marquardt algorithm input: npoints = number of data points npar = number of parameters in fit par = initial estimates of parameters sigma = errors on data (sigma^2) output: par = output parameters r = residuals (y(i) - yfit(i)) a = estimated covariance matrix of std errs in fitted params. */ static int marquardt (int npoints, int npar, double*x, double *y, double* sig, double par[NPAR], double* r, double a[NPAR][NPAR]) { int i,k, done, decrease, niter; int iorder[NPAR]; double *yfit, **d, **d2, tmp; double par2[NPAR], delta[NPAR], b[NPAR], aprime[NPAR][NPAR]; double lambda, chisq, chisq2, eps=0.001, lamfac=2.0; /* Memory allocation */ yfit = (double*) malloc( npoints*sizeof(double)); if (yfit==NULL) return(1); d = malloc2D( npoints, NPAR); if (d==NULL) { free(yfit); return(1); } d2 = malloc2D( npoints, NPAR); if (d2==NULL) { free(yfit); free2D(d,npoints,NPAR); return(1); } /* Not enough points */ if (npoints < npar) { free(yfit); free2D(d,npoints,NPAR); free2D(d2,npoints,NPAR); return(2); } lambda = 0.001; done = 0; decrease = 0; niter = 1; /* Get the value for the initial fit and the value of the derivatives for the current estimate of the parameters */ funct(npoints, npar, x, yfit, d, par); /* Calculate chi^2 */ chisq = 0; for (k=0; kMAXITER) { free(yfit); free2D(d,npoints,NPAR); free2D(d2,npoints,NPAR); return(3); } } /* Success!!! - compute residual and covariance matrix then return first calculating inverse of aprime */ for (i=0; iTop},<<'EOD'); =head1 NAME PDL::Fit::Gaussian - routines for fitting gaussians =head1 DESCRIPTION This module contains some custom gaussian fitting routines. These were developed in collaboration with Alison Offer, they do a reasonably robust job and are quite useful. Gaussian fitting is something I do a lot of, so I figured it was worth putting in my special code. Note it is not clear to me that this code is fully debugged. The reason I say that is because I tried using the internal linear eqn solving C routines called elsewhere and they were giving erroneous results. So steal from this code with caution! However it does give good fits to reasonable looking gaussians and tests show correct parameters. KGB 29/Oct/2002 =head1 SYNOPSIS use PDL; use PDL::Fit::Gaussian; ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); ($pk, $fwhm, $back, $err, $fit) = fitgauss1dr($r, $data); =head1 FUNCTIONS =head2 fitgauss1d =for ref Fit 1D Gassian to data piddle =for example ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); =for usage ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); =for signature xval(n); data(n); [o]xcentre();[o]peak_ht(); [o]fwhm(); [o]background();int [o]err(); [o]datafit(n); [t]sig(n); [t]xtmp(n); [t]ytmp(n); [t]yytmp(n); [t]rtmp(n); Fits a 1D Gaussian robustly free parameters are the centre, peak height, FWHM. The background is NOT fit, because I find this is generally unreliable, rather a median is determined in the 'outer' 10% of pixels (i.e. those at the start/end of the data piddle). The initial estimate of the FWHM is the length of the piddle/3, so it might fail if the piddle is too long. (This is non-robust anyway). Most data does just fine and this is a good default gaussian fitter. SEE ALSO: fitgauss1dr() for fitting radial gaussians =head2 fitgauss1dr =for ref Fit 1D Gassian to radial data piddle =for example ($pk, $fwhm2, $back, $err, $fit) = fitgauss1dr($r, $data); =for usage ($pk, $fwhm2, $back, $err, $fit) = fitgauss1dr($r, $data); =for signature xval(n); data(n); [o]peak_ht(); [o]fwhm(); [o]background();int [o]err(); [o]datafit(n); [t]sig(n); [t]xtmp(n); [t]ytmp(n); [t]yytmp(n); [t]rtmp(n); Fits a 1D radial Gaussian robustly free parameters are the peak height, FWHM. Centre is assumed to be X=0 (i.e. start of piddle). The background is NOT fit, because I find this is generally unreliable, rather a median is determined in the 'outer' 10% of pixels (i.e. those at the end of the data piddle). The initial estimate of the FWHM is the length of the piddle/3, so it might fail if the piddle is too long. (This is non-robust anyway). Most data does just fine and this is a good default gaussian fitter. SEE ALSO: fitgauss1d() to fit centre as well. =cut EOD pp_addhdr(' #include "gauss.c" '); for $name ('fitgauss1d','fitgauss1dr') { pp_def($name, Pars => 'xval(n); data(n); '.($name eq 'fitgauss1dr' ? '' : '[o]xcentre();'). '[o]peak_ht(); [o]fwhm(); [o]background();int [o]err(); [o]datafit(n); [t]sig(n); [t]ytmp(n); [t]yytmp(n); [t]rtmp(n);', GenericTypes => [D], Code => ' int i, nb; double ymax, xmax, xmin, val, xval, xcenguess, bkg, par[NPAR], a[NPAR][NPAR]; ymax = -1e-30; xmax = -1e-30; xmin = 1e30; $err() = 0; loop(n) %{ val = $data(); xval = $xval(); $ytmp() = val; $sig() = 1.0; /* Room for expansion */ if (val>ymax) /* Various max and mins */ ymax = val; if (xval>xmax) xmax = xval; if (xval 0.9*fabs(xmax-xmin) ) { $yytmp(n=>nb) = $ytmp(); nb++; } %} /* Estimate background and xcentroid */ bkg = 0; xcenguess = 0.0; if (nb>0) { lqsortD( $P(yytmp), 0, nb-1 ); i = (nb-1)/2; bkg = $yytmp( n=>i ); /* Median */ } val = 0.0; xcenguess = 0.0; loop(n) %{ $ytmp() -= bkg; xcenguess += $ytmp() * $xval(); val += $ytmp(); %} xcenguess /= val; par[2] = xcenguess; par[1] = ymax-bkg; par[0] = (xmax-xmin)/3; /* 1/3 of given box */ /* fprintf (stderr, "gauss...1 %f %f %f\n", par[0], par[1], par[2]); */ /* Do the fit */ '.($name eq 'fitgauss1dr' ? ' par[2] = 0.0; $err() = marquardt ($SIZE(n), 2, $P(xval), $P(ytmp), $P(sig), par, $P(rtmp), a); ' : ' $err() = marquardt ($SIZE(n), 3, $P(xval), $P(ytmp), $P(sig), par, $P(rtmp), a); $xcentre() = par[2]; ') .' $fwhm() = (fabs(par[0]))*2.0*sqrt(log(2.0)); /* Ret Values */ $peak_ht() = par[1]; $background() = bkg; loop(n) %{ val = ( (double) $xval() - par[2] ) / par[0]; $datafit() = par[1] * exp (- val * val) + bkg; %} ', Doc=>undef ); } pp_addpm(<<'ENDPM'); 1; # OK ENDPM pp_addpm(<<'EOD'); =head1 BUGS May not converge for weird data, still pretty good! =head1 AUTHOR This file copyright (C) 1999, Karl Glazebrook (kgb@aaoepp.aao.gov.au), Gaussian fitting code by Alison Offer (aro@aaocbn.aao.gov.au). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.018/Lib/Fit/Gaussian/Makefile.PL0000644060175006010010000000055012562522364015357 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["gaussian.pd", qw(Gaussian PDL::Fit::Gaussian)]); my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} .= ' '; $hash{DEFINE} .= ' '; $hash{LIBS} = ['-lm'] unless $^O =~ /MSWin/; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/Fit/Linfit.pm0000644060175006010010000000736612562522364013432 0ustar chmNone=head1 NAME PDL::Fit::Linfit - routines for fitting data with linear combinations of functions. =head1 DESCRIPTION This module contains routines to perform general curve-fits to a set (linear combination) of specified functions. Given a set of Data: (y0, y1, y2, y3, y4, y5, ...ynoPoints-1) The fit routine tries to model y as: y' = beta0*x0 + beta1*x1 + ... beta_noCoefs*x_noCoefs Where x0, x1, ... x_noCoefs, is a set of functions (curves) that the are combined linearly using the beta coefs to yield an approximation of the input data. The Sum-Sq error is reduced to a minimum in this curve fit. B =over 1 =item $data This is your data you are trying to fit. Size=n =item $functions 2D array. size (n, noCoefs). Row 0 is the evaluation of function x0 at all the points in y. Row 1 is the evaluation of of function x1 at all the points in y, ... etc. Example of $functions array Structure: $data is a set of 10 points that we are trying to model using the linear combination of 3 functions. $functions = ( [ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ], # Constant Term [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 ], # Linear Slope Term [ 0, 2, 4, 9, 16, 25, 36, 49, 64, 81] # quadradic term ) =back =head1 SYNOPSIS $yfit = linfit1d $data, $funcs =head1 FUNCTIONS =head2 linfit1d =for ref 1D Fit linear combination of supplied functions to data using min chi^2 (least squares). =for usage Usage: ($yfit, [$coeffs]) = linfit1d [$xdata], $data, $fitFuncs, [Options...] =for sig Signature: (xdata(n); ydata(n); $fitFuncs(n,order); [o]yfit(n); [o]coeffs(order)) Uses a standard matrix inversion method to do a least squares/min chi^2 fit to data. Returns the fitted data and optionally the coefficients. One can thread over extra dimensions to do multiple fits (except the order can not be threaded over - i.e. it must be one fixed set of fit functions C. The data is normalised internally to avoid overflows (using the mean of the abs value) which are common in large polynomial series but the returned fit, coeffs are in unnormalised units. =for example # Generate data from a set of functions $xvalues = sequence(100); $data = 3*$xvalues + 2*cos($xvalues) + 3*sin($xvalues*2); # Make the fit Functions $fitFuncs = cat $xvalues, cos($xvalues), sin($xvalues*2); # Now fit the data, Coefs should be the coefs in the linear combination # above: 3,2,3 ($yfit, $coeffs) = linfit1d $data,$fitFuncs; =for options Options: Weights Weights to use in fit, e.g. 1/$sigma**2 (default=1) =cut package PDL::Fit::Linfit; @EXPORT_OK = qw( linfit1d ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Basic; use PDL::Exporter; @ISA = qw( PDL::Exporter ); use PDL::Options ':Func'; use PDL::Slatec; # For matinv() sub PDL::linfit1d { my $opthash = ref($_[-1]) eq "HASH" ? pop(@_) : {} ; my %opt = parse( { Weights=>ones(1) }, $opthash ) ; barf "Usage: linfit1d incorrect args\n" if $#_<1 or $#_ > 3; my ($x, $y, $fitfuncs) = @_; if ($#_ == 1) { ($y, $fitfuncs) = @_; $x = $y->xvals; } my $wt = $opt{Weights}; # Internally normalise data my $ymean = (abs($y)->sum)/($y->nelem); $ymean = 1 if $ymean == 0; my $y2 = $y / $ymean; # Do the fit my $M = $fitfuncs->xchg(0,1); my $C = $M->xchg(0,1) x ($M * $wt->dummy(0)) ; my $Y = $M->xchg(0,1) x ($y2->dummy(0) * $wt->dummy(0)); # Fitted coefficients vector $a = matinv($C) x $Y; # Fitted data $yfit = ($M x $a)->clump(2); # Remove first dim=1 $yfit *= $ymean; # Un-normalise if (wantarray) { my $coeff = $a->clump(2); $coeff *= $ymean; # Un-normalise return ($yfit, $coeff); } else{ return $yfit; } } *linfit1d = \&PDL::linfit1d; 1; PDL-2.018/Lib/Fit/LM.pm0000644060175006010010000002264113036512175012502 0ustar chmNone=head1 NAME PDL::Fit::LM -- Levenberg-Marquardt fitting routine for PDL =head1 DESCRIPTION This module provides fitting functions for PDL. Currently, only Levenberg-Marquardt fitting is implemented. Other procedures should be added as required. For a fairly concise overview on fitting see Numerical Recipes, chapter 15 "Modeling of data". =head1 SYNOPSIS use PDL::Fit::LM; $ym = lmfit $x, $y, $sigma, \&expfunc, $initp, {Maxiter => 300}; =head1 FUNCTIONS =cut package PDL::Fit::LM; @EXPORT_OK = qw( lmfit tlmfit); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use PDL::Options; use PDL::Slatec; # for matrix inversion @ISA = qw( PDL::Exporter ); =head2 lmfit =for ref Levenberg-Marquardt fitting of a user supplied model function =for example ($ym,$finalp,$covar,$iters) = lmfit $x, $y, $sigma, \&expfunc, $initp, {Maxiter => 300, Eps => 1e-3}; where $x is the independent variable and $y the value of the dependent variable at each $x, $sigma is the estimate of the uncertainty (i.e., standard deviation) of $y at each data point, the fourth argument is a subroutine reference (see below), and $initp the initial values of the parameters to be adjusted. Options: =for options Maxiter: maximum number of iterations before giving up Eps: convergence criterion for fit; success when normalized change in chisquare smaller than Eps The user supplied sub routine reference should accept 4 arguments =over 4 =item * a vector of independent values $x =item * a vector of fitting parameters =item * a vector of dependent variables that will be assigned upon return =item * a matrix of partial derivatives with respect to the fitting parameters that will be assigned upon return =back As an example take this definition of a single exponential with 3 parameters (width, amplitude, offset): sub expdec { my ($x,$par,$ym,$dyda) = @_; my ($a,$b,$c) = map {$par->slice("($_)")} (0..2); my $arg = $x/$a; my $ex = exp($arg); $ym .= $b*$ex+$c; my (@dy) = map {$dyda->slice(",($_)")} (0..2); $dy[0] .= -$b*$ex*$arg/$a; $dy[1] .= $ex; $dy[2] .= 1; } Note usage of the C<.=> operator for assignment In scalar context returns a vector of the fitted dependent variable. In list context returns fitted y-values, vector of fitted parameters, an estimate of the covariance matrix (as an indicator of goodness of fit) and number of iterations performed. =cut sub PDL::lmfit { my ($x,$y,$sig,$func,$a,$opt) = @_; # not using $ia right now $opt = {iparse( { Maxiter => 200, Eps => 1e-4}, ifhref($opt))}; my ($maxiter,$eps) = map {$opt->{$_}} qw/Maxiter Eps/; # initialize some variables my ($isig2,$chisq) = (1/($sig*$sig),0); #$isig2="inverse of sigma squared" my ($ym,$al,$cov,$bet,$oldbet,$olda,$oldal,$ochisq,$di,$pivt,$info) = map {null} (0..10); my ($aldiag,$codiag); # the diagonals for later updating # this will break threading my $dyda = zeroes($x->type,$x->getdim(0),$a->getdim(0)); my $alv = zeroes($x->type,$x->getdim(0),$a->getdim(0),$a->getdim(0)); my ($iter,$lambda) = (0,0.001); do { if ($iter>0) { $cov .= $al; # local $PDL::debug = 1; $codiag .= $aldiag*(1+$lambda); gefa $cov, $pivt, $info; # gefa + gesl = solution by Gaussian elem. gesl $cov, $pivt, $bet, 0; # solution returned in $bet # lusd($cov,$bet,$da); # print "changing by $da\n"; $a += $bet; # what we used to call $da is now $bet } &$func($x,$a,$ym,$dyda); $chisq = ($y-$ym)*($y-$ym); $chisq *= $isig2; $chisq = $chisq->sumover; # calculate chi^2 $dyda->xchg(0,1)->outer($dyda->xchg(0,1),$alv->mv(0,2)); $alv *= $isig2; $alv->sumover($al); # calculate alpha (($y-$ym)*$isig2*$dyda)->sumover($bet); # calculate beta if ($iter == 0) {$olda .= $a; $ochisq .= $chisq; $oldbet .= $bet; $oldal .= $al; $aldiag = $al->diagonal(0,1); $cov .= $al; $codiag = $cov->diagonal(0,1)} $di .= abs($chisq-$ochisq); # print "$iter: chisq, lambda, dlambda: $chisq, $lambda,",$di/$chisq,"\n"; if ($chisq < $ochisq) { $lambda *= 0.1; $ochisq .= $chisq; $olda .= $a; $oldbet .= $bet; $oldal .= $al; } else { $lambda *= 10; $chisq .= $ochisq; $a .= $olda; # go back to previous a $bet .= $oldbet; # and beta $al .= $oldal; # and alpha } } while ($iter++==0 || $iter < $maxiter && $di/$chisq > $eps); barf "iteration did not converge" if $iter >= $maxiter && $di/$chisq > $eps; # return inv $al as estimate of covariance matrix return wantarray ? ($ym,$a,matinv($al),$iter) : $ym; } *lmfit = \&PDL::lmfit; =pod An extended example script that uses lmfit is included below. This nice example was provided by John Gehman and should help you to master the initial hurdles. It can also be found in the F directory. use PDL; use PDL::Math; use PDL::Fit::LM; use strict; ### fit using pdl's lmfit (Marquardt-Levenberg non-linear least squares fitting) ### ### `lmfit' Syntax: ### ### ($ym,$finalp,$covar,$iters) ### = lmfit $x, $y, $sigma, \&fn, $initp, {Maxiter => 300, Eps => 1e-3}; ### ### Explanation of variables ### ### OUTPUT ### $ym = pdl of fitted values ### $finalp = pdl of parameters ### $covar = covariance matrix ### $iters = number of iterations actually used ### ### INPUT ### $x = x data ### $y = y data ### $sigma = piddle of y-uncertainties for each value of $y (can be set to scalar 1 for equal weighting) ### \&fn = reference to function provided by user (more on this below) ### $initp = initial values for floating parameters ### (needs to be explicitly set prior to use of lmfit) ### Maxiter = maximum iterations ### Eps = convergence criterion (maximum normalized change in Chi Sq.) ### Example: # make up experimental data: my $xdata = pdl sequence 5; my $ydata = pdl [1.1,1.9,3.05,4,4.9]; # set initial prameters in a pdl (order in accord with fit function below) my $initp = pdl [0,1]; # Weight all y data equally (else specify different uncertainties in a pdl) my $sigma = 1; # Use lmfit. Fourth input argument is reference to user-defined # subroutine ( here \&linefit ) detailed below. my ($yf,$pf,$cf,$if) = lmfit $xdata, $ydata, $sigma, \&linefit, $initp; # Note output print "\nXDATA\n$xdata\nY DATA\n$ydata\n\nY DATA FIT\n$yf\n\n"; print "Slope and Intercept\n$pf\n\nCOVARIANCE MATRIX\n$cf\n\n"; print "NUMBER ITERATIONS\n$if\n\n"; # simple example of user defined fit function. Guidelines included on # how to write your own function subroutine. sub linefit { # leave this line as is my ($x,$par,$ym,$dyda) = @_; # $m and $b are fit parameters, internal to this function # call them whatever make sense to you, but replace (0..1) # with (0..x) where x is equal to your number of fit parameters # minus 1 my ($m,$b) = map { $par->slice("($_)") } (0..1); # Write function with dependent variable $ym, # independent variable $x, and fit parameters as specified above. # Use the .= (dot equals) assignment operator to express the equality # (not just a plain equals) $ym .= $m * $x + $b; # Edit only the (0..1) part to (0..x) as above my (@dy) = map {$dyda -> slice(",($_)") } (0..1); # Partial derivative of the function with respect to first # fit parameter ($m in this case). Again, note .= assignment # operator (not just "equals") $dy[0] .= $x; # Partial derivative of the function with respect to next # fit parameter ($b in this case) $dy[1] .= 1; # Add $dy[ ] .= () lines as necessary to supply # partial derivatives for all floating parameters. } =cut # the OtherPar is the sub routine ref =head2 tlmfit =for ref threaded version of Levenberg-Marquardt fitting routine mfit =for example tlmfit $x, $y, float(1)->dummy(0), $na, float(200), float(1e-4), $ym=null, $afit=null, \&expdec; =for sig Signature: tlmfit(x(n);y(n);sigma(n);initp(m);iter();eps();[o] ym(n);[o] finalp(m); OtherPar => subref) a threaded version of C by using perl threading. Direct threading in C seemed difficult since we have an if condition in the iteration. In principle that can be worked around by using C but .... Send a threaded C version if you work it out! Since we are using perl threading here speed is not really great but it is just convenient to have a threaded version for many applications (no explicit for-loops required, etc). Suffers from some of the current limitations of perl level threading. =cut thread_define 'tlmfit(x(n);y(n);sigma(n);initp(m);iter();eps();[o] ym(n);[o] finalp(m)), NOtherPars => 1', over { $_[7] .= $_[3]; # copy our parameter guess into the output $_[6] .= PDL::lmfit $_[0],$_[1],$_[2],$_[8],$_[7],{Maxiter => $_[4], Eps => $_[5]}; }; 1; =head1 BUGS Not known yet. =head1 AUTHOR This file copyright (C) 1999, Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. There is no warranty. You are allowed to redistribute this software documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut # return true 1; PDL-2.018/Lib/Fit/Makefile.PL0000644060175006010010000000074012562522364013606 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Fit', VERSION_FROM => '../../Basic/Core/Version.pm', DIR => [ qw/Gaussian/ ], PM => { map {($_ => '$(INST_LIBDIR)/Fit/'.$_)} grep { !defined $PDL::Config{WITH_SLATEC} || $PDL::Config{WITH_SLATEC}==1 || !($_ eq 'Linfit.pm' || $_ eq 'LM.pm') } <*.pm> }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Lib/Fit/Polynomial.pm0000644060175006010010000000720112562522364014314 0ustar chmNone=head1 NAME PDL::Fit::Polynomial - routines for fitting with polynomials =head1 DESCRIPTION This module contains routines for doing simple polynomial fits to data =head1 SYNOPSIS $yfit = fitpoly1d $data; =head1 FUNCTIONS =head2 fitpoly1d =for ref Fit 1D polynomials to data using min chi^2 (least squares) =for usage Usage: ($yfit, [$coeffs]) = fitpoly1d [$xdata], $data, $order, [Options...] =for sig Signature: (x(n); y(n); [o]yfit(n); [o]coeffs(order)) Uses a standard matrix inversion method to do a least squares/min chi^2 polynomial fit to data. Order=2 is a linear fit (two parameters). Returns the fitted data and optionally the coefficients. One can thread over extra dimensions to do multiple fits (except the order can not be threaded over - i.e. it must be one fixed scalar number like "4"). The data is normalised internally to avoid overflows (using the mean of the abs value) which are common in large polynomial series but the returned fit, coeffs are in unnormalised units. =for example $yfit = fitpoly1d $data,2; # Least-squares line fit ($yfit, $coeffs) = fitpoly1d $x, $y, 4; # Fit a cubic $fitimage = fitpoly1d $image,3 # Fit a quadratic to each row of an image $myfit = fitpoly1d $line, 2, {Weights => $w}; # Weighted fit =for options Options: Weights Weights to use in fit, e.g. 1/$sigma**2 (default=1) =cut package PDL::Fit::Polynomial; @EXPORT_OK = qw( fitpoly1d ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Basic; use PDL::Exporter; @ISA = qw( PDL::Exporter ); use PDL::Options ':Func'; # use PDL::Slatec; # For matinv() use PDL::MatrixOps; # for inv(), using this instead of call to Slatec routine sub PDL::fitpoly1d { my $opthash = ref($_[-1]) eq "HASH" ? pop(@_) : {} ; my %opt = parse( { Weights=>ones(1) }, $opthash ) ; barf "Usage: fitpoly1d incorrect args\n" if $#_<1 or $#_ > 2; my ($x, $y, $order) = @_; if ($#_ == 1) { ($y, $order) = @_; $x = $y->xvals; } my $wt = $opt{Weights}; # Internally normalise data # means for each 1D data set my $xmean = (abs($x)->average)->dummy(0); # dummy for correct threading my $ymean = (abs($y)->average)->dummy(0); (my $tmp = $ymean->where($ymean == 0)) .= 1 if any $ymean == 0; ($tmp = $xmean->where($xmean == 0)) .= 1 if any $xmean == 0; my $y2 = $y / $ymean; my $x2 = $x / $xmean; # Do the fit my $pow = sequence($order); my $M = $x2->dummy(0) ** $pow; my $C = $M->xchg(0,1) x ($M * $wt->dummy(0)) ; my $Y = $M->xchg(0,1) x ($y2->dummy(0) * $wt->dummy(0)); # Fitted coefficients vector ## $a = matinv($C) x $Y; ## print "matinv: \$C = $C, \$Y = $Y, \$a = $a\n"; $a = inv($C) x $Y; # use inv() instead of matinv() to avoid Slatec dependency ## print "inv: \$C = $C, \$Y = $Y, \$a = $a\n"; # Fitted data $yfit = ($M x $a)->clump(2); # Remove first dim=1 $yfit *= $ymean; # Un-normalise if (wantarray) { my $coeff = $a->clump(2); $coeff *= $ymean / ($xmean ** $pow); # Un-normalise return ($yfit, $coeff); } else{ return $yfit; } } *fitpoly1d = \&PDL::fitpoly1d; =head1 BUGS May not work too well for data with large dynamic range. =head1 SEE ALSO L =head1 AUTHOR This file copyright (C) 1999, Karl Glazebrook (kgb@aaoepp.aao.gov.au). All rights reserved. There is no warranty. You are allowed to redistribute this software documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut 1; PDL-2.018/Lib/Func.pm0000644060175006010010000005604513036512175012350 0ustar chmNone=encoding iso-8859-1 =head1 NAME PDL::Func - interpolation, integration, & gradient estimation (differentiation) of functions =head1 SYNOPSIS use PDL::Func; use PDL::Math; # somewhat pointless way to estimate cos and sin, # but is shows that you can thread if you want to # (and the library lets you) # my $obj = PDL::Func->init( Interpolate => "Hermite" ); # my $x = pdl( 0 .. 45 ) * 4 * 3.14159 / 180; my $y = cat( sin($x), cos($x) ); $obj->set( x => $x, y => $y, bc => "simple" ); # my $xi = pdl( 0.5, 1.5, 2.5 ); my $yi = $obj->interpolate( $xi ); # print "sin( $xi ) equals ", $yi->slice(':,(0)'), "\n"; sin( [0.5 1.5 2.5] ) equals [0.87759844 0.070737667 -0.80115622] # print "cos( $xi ) equals ", $yi->slice(':,(1)'), "\n"; cos( [0.5 1.5 2.5] ) equals [ 0.4794191 0.99768655 0.59846449] # print sin($xi), "\n", cos($xi), "\n"; [0.47942554 0.99749499 0.59847214] [0.87758256 0.070737202 -0.80114362] =head1 DESCRIPTION This module aims to contain useful functions. Honest. =head1 INTERPOLATION AND MORE This module aims to provide a relatively-uniform interface to the various interpolation methods available to PDL. The idea is that a different interpolation scheme can be used just by changing an attribute of a C object. Some interpolation schemes (as exemplified by the SLATEC library) also provide additional functionality, such as integration and gradient estimation. Throughout this documentation, C<$x> and C<$y> refer to the function to be interpolated whilst C<$xi> and C<$yi> are the interpolated values. The available types, or I, of interpolation are listed below. Also given are the valid attributes for each scheme: the flag value indicates whether it can be set (s), got (g), and if it is required (r) for the method to work. =over 4 =item Interpolate => Linear An extravagent way of calling the linear interpolation routine L. The valid attributes are: Attribute Flag Description x sgr x positions of data y sgr function values at x positions err g error flag =item Interpolate => Hermite Use the piecewice cubic Hermite interpolation routines from the SLATEC library. Only available if L is installed. The valid attributes are: Attribute Flag Description x sgr x positions of data y sgr function values at x positions bc sgr boundary conditions g g estimated gradient at x positions err g error flag Given the initial set of points C<(x,y)>, an estimate of the gradient is made at these points, using the given boundary conditions. The gradients are stored in the C attribute, accessible via: $gradient = $obj->get( 'g' ); However, as this gradient is only calculated 'at the last moment', C will only contain data I one of C, C, or C is used. =back =head2 Boundary conditions for the Hermite routines If your data is monotonic, and you are not too bothered about edge effects, then the default value of C of C is for you. Otherwise, take a look at the description of L and use a hash reference for the C attribute, with the following keys: =over 3 =item monotonic 0 if the interpolant is to be monotonic in each interval (so the gradient will be 0 at each switch point), otherwise the gradient is calculated using a 3-point difference formula at switch points. If E 0 then the interpolant is forced to lie close to the data, if E 0 no such control is imposed. Default = B<0>. =item start A perl list of one or two elements. The first element defines how the boundary condition for the start of the array is to be calculated; it has a range of C<-5 .. 5>, as given for the C parameter of L. The second element, only used if options 2, 1, -1, or 2 are chosen, contains the value of the C parameter. Default = B<[ 0 ]>. =item end As for C, but for the end of the data. =back An example would be $obj->set( bc => { start => [ 1, 0 ], end => [ 1, -1 ] } ) which sets the first derivative at the first point to 0, and at the last point to -1. =head2 Errors The C method provides a simple mechanism to check if the previous method was successful. If the function returns an error flag, then it is stored in the C attribute. To find out which routine was used, use the C method. =cut #' fool emacs package PDL::Func; use strict; use Carp; #################################################################### # # what modules are available ? # my %modules; BEGIN { eval "use PDL::Slatec"; $modules{slatec} = ($@ ? 0 : 1); } #################################################################### ## Public routines: =head1 FUNCTIONS =head2 init =for usage $obj = PDL::Func->init( Interpolate => "Hermite", x => $x, y => $y ); $obj = PDL::Func->init( { x => $x, y => $y } ); =for ref Create a PDL::Func object, which can interpolate, and possibly integrate and calculate gradients of a dataset. If not specified, the value of Interpolate is taken to be C, which means the interpolation is performed by L. A value of C uses piecewise cubic Hermite functions, which also allows the integral and gradient of the data to be estimated. Options can either be provided directly to the method, as in the first example, or within a hash reference, as shown in the second example. =cut # meaning of types: # required - required, if this attr is changed, we need to re-initialise # settable - can be changed with a init() or set() command # gettable - can be read with a get() command # # do we really need gettable? Not currently, that's for sure, # as everything is gettable my %attr = ( Default => { x => { required => 1, settable => 1, gettable => 1 }, y => { required => 1, settable => 1, gettable => 1 }, err => { gettable => 1 }, }, Linear => {}, Hermite => { bc => { settable => 1, gettable => 1, required => 1, default => "simple" }, g => { gettable => 1 }, }, ); sub init { my $this = shift; my $class = ref($this) || $this; # class structure my $self = { }; # make $self into an object bless $self, $class; # set up default attributes # my ( %opt ) = @_; $opt{Interpolate} = "Linear" unless exists $opt{Interpolate}; # set variables $self->set( %opt ); # return the object return $self; } # sub: init() ##################################################################### # $self->_init_attr( $interpolate ) # # set up the object for the given interpolation method # - uses the values stored in %attr to fill in the # fields in $self AFTER clearing the object # # NOTE: called by set() # sub _init_attr { my $self = shift; my $interpolate = shift; croak "ERROR: Unknown interpolation scheme <$interpolate>.\n" unless defined $attr{$interpolate}; # fall over if slatec library isn't present # and asking for Hermite interpolation croak "ERROR: Hermite interpolation is not available without PDL::Slatec.\n" if $interpolate eq "Interpolate" and $modules{slatec} == 0; # clear out the old data (if it's not the first time through) $self->{attributes} = {}; $self->{values} = {}; $self->{types} = { required => 0, settable => 0, gettable => 0 }; $self->{flags} = { scheme => $interpolate, status => 1, routine => "none", changed => 1 }; # set up default values my $ref = $attr{Default}; foreach my $attr ( keys %{$ref} ) { # set default values foreach my $type ( keys %{$self->{types}} ) { $self->{attributes}{$attr}{$type} = $self->{types}{$type}; } # change the values to those supplied foreach my $type ( keys %{$ref->{$attr}} ) { $self->{attributes}{$attr}{$type} = $ref->{$attr}{$type} if exists $self->{types}{$type}; } # set value to undef $self->{values}{$attr} = undef; } # now set up for the particular interpolation scheme $ref = $attr{$interpolate}; foreach my $attr ( keys %{$ref} ) { # set default values, if not known unless ( defined $self->{attributes}{$attr} ) { foreach my $type ( keys %{$self->{types}} ) { $self->{attributes}{$attr}{$type} = $self->{types}{$type}; } } # change the values to those supplied foreach my $type ( keys %{$ref->{$attr}} ) { next if $type eq "default"; $self->{attributes}{$attr}{$type} = $ref->{$attr}{$type} if exists $self->{types}{$type}; } # set value to default value/undef $self->{values}{$attr} = exists $ref->{$attr}{default} ? $ref->{$attr}{default} : undef; } } # sub: _init_attr() #################################################################### # call this at the start of each method that needs data # stored in the object. This function ensures that all required # attributes exist and, if necessary, re-initialises the object # - ie if the data has changed. # sub _check_attr { my $self = shift; return unless $self->{flags}{changed}; my @emsg; foreach my $name ( keys %{ $self->{attributes} } ) { if( $self->{attributes}{$name}{required} ) { push @emsg, $name unless defined($self->{values}{$name}); } } croak "ERROR - the following attributes must be supplied:\n [ @emsg ]\n" unless $#emsg == -1; $self->{flags}{routine} = "none"; $self->{flags}{status} = 1; $self->_initialise; $self->{flags}{changed} = 0; } # sub: _check_attr() #################################################################### # for a given scheme, it may be necessary to perform certain # operations before the main routine of a method is called. # It's done here. # # Due to lazy evaluation we try to do this as late as possible - # _initialise() should only be called by _check_attr() # [ at least at the moment ] # sub _initialise { my $self = shift; my $iflag = $self->scheme(); if ( $iflag eq "Hermite" ) { _init_hermite( $self ); } } # sub: _initialise() # something has changed, so we need to recalculate the gradient # - actually, some changes don't invalidate the gradient, # however, with the current design, it's impossible to know # this. (poor design) # sub _init_hermite { my $self = shift; # set up error flags $self->{flags}{status} = 0; $self->{flags}{routine} = "none"; # get values in one go my ( $x, $y, $bc ) = $self->_get_value( qw( x y bc ) ); # check 1st dimention of x and y are the same # ie allow the possibility of threading my $xdim = $x->getdim( 0 ); my $ydim = $y->getdim( 0 ); croak "ERROR: x and y piddles must have the same first dimension.\n" unless $xdim == $ydim; my ( $g, $ierr ); if ( ref($bc) eq "HASH" ) { my $monotonic = $bc->{monotonic} || 0; my $start = $bc->{start} || [ 0 ]; my $end = $bc->{end} || [ 0 ]; my $ic = $x->short( $start->[0], $end->[0] ); my $vc = $x->float( 0, 0 ); if ( $#$start == 1 ) { $vc->set( 0, $start->[1] ); } if ( $#$end == 1 ) { $vc->set( 1, $end->[1] ); } my $wk = $x->zeroes( $x->float, 2*$xdim ); croak "ERROR: Hermite interpolation is not available without PDL::Slatec.\n" if $modules{slatec} == 0; ( $g, $ierr ) = chic( $ic, $vc, $monotonic, $x, $y, $wk ); $self->{flags}{routine} = "chic"; } elsif ( $bc eq "simple" ) { # chim croak "ERROR: Hermite interpolation is not available without PDL::Slatec.\n" if $modules{slatec} == 0; ( $g, $ierr ) = chim( $x, $y ); $self->{flags}{routine} = "chim"; } else { # Unknown boundary condition croak "ERROR: unknown boundary condition <$bc>.\n"; # return; } $self->_set_value( g => $g, err => $ierr ); if ( all $ierr == 0 ) { # everything okay $self->{flags}{status} = 1; } elsif ( any $ierr < 0 ) { # a problem $self->{flags}{status} = 0; } else { # there were switches in monotonicity $self->{flags}{status} = -1; } } #################################################################### #################################################################### # a version of set that ignores the settable flag # and doesn't bother about the presence of an Interpolate # value. # # - for use by the class, not by the public # # it still ignores unknown attributes # sub _set_value { my $self = shift; my %attrs = ( @_ ); foreach my $attr ( keys %attrs ) { if ( exists($self->{values}{$attr}) ) { $self->{values}{$attr} = $attrs{$attr}; $self->{flags}{changed} = 1; } } } # sub: _set_value() # a version of get that ignores the gettable flag # - for use by the class, not by the public # # an unknown attribute returns an undef # sub _get_value { my $self = shift; my @ret; foreach my $name ( @_ ) { if ( exists $self->{values}{$name} ) { push @ret, $self->{values}{$name}; } else { push @ret, undef; } } return wantarray ? @ret : $ret[0]; } # sub: _get_value() #################################################################### =head2 set =for usage my $nset = $obj->set( x => $newx, y => $newy ); my $nset = $obj->set( { x => $newx, y => $newy } ); =for ref Set attributes for a PDL::Func object. The return value gives the number of the supplied attributes which were actually set. =cut sub set { my $self = shift; return if $#_ == -1; my $vref; if ( $#_ == 0 and ref($_[0]) eq "HASH" ) { $vref = shift; } else { my %vals = ( @_ ); $vref = \%vals; } # initialise attributes IFF Interpolate # is specified # $self->_init_attr( $vref->{Interpolate} ) if exists $vref->{Interpolate}; my $ctr = 0; foreach my $name ( keys %{$vref} ) { next if $name eq "Interpolate"; if ( exists $self->{attributes}{$name}{settable} ) { $self->{values}{$name} = $vref->{$name}; $ctr++; } } $self->{flags}{changed} = 1 if $ctr; $self->{flags}{status} = 1; return $ctr; } # sub: set() #################################################################### =head2 get =for usage my $x = $obj->get( x ); my ( $x, $y ) = $obj->get( qw( x y ) ); =for ref Get attributes from a PDL::Func object. Given a list of attribute names, return a list of their values; in scalar mode return a scalar value. If the supplied list contains an unknown attribute, C returns a value of C for that attribute. =cut sub get { my $self = shift; my @ret; foreach my $name ( @_ ) { if ( exists $self->{attributes}{$name}{gettable} ) { push @ret, $self->{values}{$name}; } else { push @ret, undef; } } return wantarray ? @ret : $ret[0]; } # sub: get() #################################################################### # # access to flags - have individual methods for these =head2 scheme =for usage my $scheme = $obj->scheme; =for ref Return the type of interpolation of a PDL::Func object. Returns either C or C. =cut sub scheme { return $_[0]->{flags}{scheme}; } =head2 status =for usage my $status = $obj->status; =for ref Returns the status of a PDL::Func object. This method provides a high-level indication of the success of the last method called (except for C which is ignored). Returns B<1> if everything is okay, B<0> if there has been a serious error, and B<-1> if there was a problem which was not serious. In the latter case, C<$obj-Eget("err")> may provide more information, depending on the particular scheme in use. =cut sub status { return $_[0]->{flags}{status}; } =head2 routine =for usage my $name = $obj->routine; =for ref Returns the name of the last routine called by a PDL::Func object. This is mainly useful for decoding the value stored in the C attribute. =cut sub routine { return $_[0]->{flags}{routine}; } =head2 attributes =for usage $obj->attributes; PDL::Func->attributes; =for ref Print out the flags for the attributes of a PDL::Func object. Useful in case the documentation is just too opaque! =for example PDL::Func->attributes; Flags Attribute SGR x SGR y G err =cut # note, can be called with the class, rather than just # an object. However, not of great use, as this will only # ever return the values for Interpolate => Linear # # to allow this, I've used a horrible hack - we actually # create an object and then print out the attributes from that # Ugh! # # It would have been useful if I'd stuck to sub-classes # for different schemes # sub attributes { my $self = shift; # ugh $self = $self->init unless ref($self); print "Flags Attribute\n"; while ( my ( $attr, $hashref ) = each %{$self->{attributes}} ) { my $flag = ""; $flag .= "S" if $hashref->{settable}; $flag .= "G" if $hashref->{gettable}; $flag .= "R" if $hashref->{required}; printf " %-3s %s\n", $flag, $attr; } return; } # sub: attributes() #################################################################### =head2 interpolate =for usage my $yi = $obj->interpolate( $xi ); =for ref Returns the interpolated function at a given set of points (PDL::Func). A status value of -1, as returned by the C method, means that some of the C<$xi> points lay outside the range of the data. The values for these points were calculated by extrapolation (the details depend on the scheme being used). =cut sub interpolate { my $self = shift; my $xi = shift; croak 'Usage: $obj->interpolate( $xi )' . "\n" unless defined $xi; # check everything is fine $self->_check_attr(); # get values in one go my ( $x, $y ) = $self->_get_value( qw( x y ) ); # farm off to routines my $iflag = $self->scheme; if ( $iflag eq "Linear" ) { return _interp_linear( $self, $xi, $x, $y ); } elsif ( $iflag eq "Hermite" ) { return _interp_hermite( $self, $xi, $x, $y ); } } # sub: interpolate() sub _interp_linear { my ( $self, $xi, $x, $y ) = ( @_ ); my ( $yi, $err ) = PDL::Primitive::interpolate( $xi, $x, $y ); $self->{flags}{status} = (any $err) ? -1 : 1; $self->_set_value( err => $err ); $self->{flags}{routine} = "interpolate"; return $yi; } # sub: _interp_linear() sub _interp_hermite { my ( $self, $xi, $x, $y ) = ( @_ ); # get gradient my $g = $self->_get_value( 'g' ); my ( $yi, $ierr ) = chfe( $x, $y, $g, 0, $xi ); $self->{flags}{routine} = "chfe"; $self->_set_value( err => $ierr ); if ( all $ierr == 0 ) { # everything okay $self->{flags}{status} = 1; } elsif ( all $ierr > 0 ) { # extrapolation was required $self->{flags}{status} = -1; } else { # a problem $self->{flags}{status} = 0; } return $yi; } # sub: _interp_linear() =head2 gradient =for usage my $gi = $obj->gradient( $xi ); my ( $yi, $gi ) = $obj->gradient( $xi ); =for ref Returns the derivative and, optionally, the interpolated function for the C scheme (PDL::Func). =cut sub gradient { my $self = shift; my $xi = shift; croak 'Usage: $obj->gradient( $xi )' . "\n" unless defined $xi; croak 'Error: can not call gradient for Interpolate => "Linear".' ."\n" unless $self->scheme eq "Hermite"; # check everything is fine $self->_check_attr(); # get values in one go my ( $x, $y, $g ) = $self->_get_value( qw( x y g ) ); my ( $yi, $gi, $ierr ) = chfd( $x, $y, $g, 0, $xi ); $self->{flags}{routine} = "chfd"; $self->_set_value( err => $ierr ); if ( all $ierr == 0 ) { # everything okay $self->{flags}{status} = 1; } elsif ( all $ierr > 0 ) { # extrapolation was required $self->{flags}{status} = -1; } else { # a problem $self->{flags}{status} = 0; } # note order of values return wantarray ? ( $yi, $gi ) : $gi; } # sub: gradient =head2 integrate =for usage my $ans = $obj->integrate( index => pdl( 2, 5 ) ); my $ans = $obj->integrate( x => pdl( 2.3, 4.5 ) ); =for ref Integrate the function stored in the PDL::Func object, if the scheme is C. The integration can either be between points of the original C array (C), or arbitrary x values (C). For both cases, a two element piddle should be given, to specify the start and end points of the integration. =over 7 =item index The values given refer to the indices of the points in the C array. =item x The array contains the actual values to integrate between. =back If the C method returns a value of -1, then one or both of the integration limits did not lie inside the C array. I with the result in such a case. =cut sub integrate { my $self = shift; croak 'Usage: $obj->integrate( $type => $limits )' . "\n" unless $#_ == 1; croak 'Error: can not call integrate for Interpolate => "Linear".' ."\n" unless $self->{flags}{scheme} eq "Hermite"; # check everything is fine $self->_check_attr(); $self->{flags}{status} = 0; $self->{flags}{routine} = "none"; my ( $type, $indices ) = ( @_ ); croak "Unknown type ($type) sent to integrate method.\n" unless $type eq "x" or $type eq "index"; my $fdim = $indices->getdim(0); croak "Indices must have a first dimension of 2, not $fdim.\n" unless $fdim == 2; my $lo = $indices->slice('(0)'); my $hi = $indices->slice('(1)'); my ( $x, $y, $g ) = $self->_get_value( qw( x y g ) ); my ( $ans, $ierr ); if ( $type eq "x" ) { ( $ans, $ierr ) = chia( $x, $y, $g, 0, $lo, $hi ); $self->{flags}{routine} = "chia"; if ( all $ierr == 0 ) { # everything okay $self->{flags}{status} = 1; } elsif ( any $ierr < 0 ) { # a problem $self->{flags}{status} = 0; } else { # out of range $self->{flags}->{status} = -1; } } else { ( $ans, $ierr ) = chid( $x, $y, $g, 0, $lo, $hi ); $self->{flags}->{routine} = "chid"; if ( all $ierr == 0 ) { # everything okay $self->{flags}{status} = 1; } elsif ( all $ierr != -4 ) { # a problem $self->{flags}{status} = 0; } else { # out of range (ierr == -4) $self->{flags}{status} = -1; } } $self->_set_value( err => $ierr ); return $ans; } # sub: integrate() #################################################################### =head1 TODO It should be relatively easy to provide an interface to other interpolation routines, such as those provided by the Gnu Scientific Library (GSL), or the B-spline routines in the SLATEC library. In the documentation, the methods are preceded by C to avoid clashes with functions such as C when using the C or C commands within I or I. =head1 HISTORY Amalgamated C and C to form C. Comments greatly appreciated on the current implementation, as it is not too sensible. Thanks to Robin Williams, Halldór Olafsson, and Vince McIntyre. =head1 AUTHOR Copyright (C) 2000,2001 Doug Burke (dburke@cfa.harvard.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. =cut #################################################################### # End with a true 1; PDL-2.018/Lib/GIS/0000755060175006010010000000000013110402045011512 5ustar chmNonePDL-2.018/Lib/GIS/Makefile.PL0000644060175006010010000000040612562522364013505 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Lib::GIS', VERSION_FROM => '../../Basic/Core/Version.pm', DIR => [ qw/ Proj / ], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Lib/GIS/Proj/0000755060175006010010000000000013110402046012425 5ustar chmNonePDL-2.018/Lib/GIS/Proj/include/0000755060175006010010000000000013110402046014050 5ustar chmNonePDL-2.018/Lib/GIS/Proj/include/projects.h0000644060175006010010000003532512562522364016102 0ustar chmNone/****************************************************************************** * $Id: projects.h 2121 2011-11-22 22:51:47Z warmerdam $ * * Project: PROJ.4 * Purpose: Primary (private) include file for PROJ.4 library. * Author: Gerald Evenden * ****************************************************************************** * Copyright (c) 2000, Frank Warmerdam * * Permission is hereby granted, free of charge, to any person obtaining a * copy of this software and associated documentation files (the "Software"), * to deal in the Software without restriction, including without limitation * the rights to use, copy, modify, merge, publish, distribute, sublicense, * and/or sell copies of the Software, and to permit persons to whom the * Software is furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included * in all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * DEALINGS IN THE SOFTWARE. *****************************************************************************/ /* General projections header file */ #ifndef PROJECTS_H #define PROJECTS_H #ifdef _MSC_VER # ifndef _CRT_SECURE_NO_DEPRECATE # define _CRT_SECURE_NO_DEPRECATE # endif # ifndef _CRT_NONSTDC_NO_DEPRECATE # define _CRT_NONSTDC_NO_DEPRECATE # endif #endif /* standard inclusions */ #include #include #include #include #ifdef __cplusplus #define C_NAMESPACE extern "C" #define C_NAMESPACE_VAR extern "C" extern "C" { #else #define C_NAMESPACE extern #define C_NAMESPACE_VAR #endif #ifndef NULL # define NULL 0 #endif #ifndef FALSE # define FALSE 0 #endif #ifndef TRUE # define TRUE 1 #endif #ifndef MAX # define MIN(a,b) ((ab) ? a : b) #endif #ifndef ABS # define ABS(x) ((x<0) ? (-1*(x)) : x) #endif /* maximum path/filename */ #ifndef MAX_PATH_FILENAME #define MAX_PATH_FILENAME 1024 #endif /* prototype hypot for systems where absent */ #ifndef _WIN32 extern double hypot(double, double); #endif #ifdef _WIN32_WCE # include # include # define rewind wceex_rewind # define getenv wceex_getenv # define strdup _strdup # define hypot _hypot #endif /* some useful constants */ #define HALFPI 1.5707963267948966 #define FORTPI 0.78539816339744833 #define PI 3.14159265358979323846 #define TWOPI 6.2831853071795864769 /* environment parameter name */ #ifndef PROJ_LIB #define PROJ_LIB "PROJ_LIB" #endif /* maximum tag id length for +init and default files */ #ifndef ID_TAG_MAX #define ID_TAG_MAX 50 #endif /* Use WIN32 as a standard windows 32 bit declaration */ #if defined(_WIN32) && !defined(WIN32) && !defined(_WIN32_WCE) # define WIN32 #endif #if defined(_WINDOWS) && !defined(WIN32) && !defined(_WIN32_WCE) # define WIN32 #endif /* directory delimiter for DOS support */ #ifdef WIN32 #define DIR_CHAR '\\' #else #define DIR_CHAR '/' #endif /* proj thread context */ typedef struct { int last_errno; int debug_level; void (*logger)(void *, int, const char *); void *app_data; } projCtx_t; /* datum_type values */ #define PJD_UNKNOWN 0 #define PJD_3PARAM 1 #define PJD_7PARAM 2 #define PJD_GRIDSHIFT 3 #define PJD_WGS84 4 /* WGS84 (or anything considered equivelent) */ /* library errors */ #define PJD_ERR_GEOCENTRIC -45 #define PJD_ERR_AXIS -47 #define PJD_ERR_GRID_AREA -48 #define USE_PROJUV typedef struct { double u, v; } projUV; typedef struct { double r, i; } COMPLEX; #ifndef PJ_LIB__ #define XY projUV #define LP projUV #else typedef struct { double x, y; } XY; typedef struct { double lam, phi; } LP; #endif typedef union { double f; int i; char *s; } PJ_VALUE; struct PJconsts; struct PJ_LIST { char *id; /* projection keyword */ struct PJconsts *(*proj)(struct PJconsts*);/* projection entry point */ char * const *descr; /* description text */ }; struct PJ_ELLPS { char *id; /* ellipse keyword name */ char *major; /* a= value */ char *ell; /* elliptical parameter */ char *name; /* comments */ }; struct PJ_UNITS { char *id; /* units keyword */ char *to_meter; /* multiply by value to get meters */ char *name; /* comments */ }; struct PJ_DATUMS { char *id; /* datum keyword */ char *defn; /* ie. "to_wgs84=..." */ char *ellipse_id; /* ie from ellipse table */ char *comments; /* EPSG code, etc */ }; struct PJ_PRIME_MERIDIANS { char *id; /* prime meridian keyword */ char *defn; /* offset from greenwich in DMS format. */ }; struct DERIVS { double x_l, x_p; /* derivatives of x for lambda-phi */ double y_l, y_p; /* derivatives of y for lambda-phi */ }; struct FACTORS { struct DERIVS der; double h, k; /* meridinal, parallel scales */ double omega, thetap; /* angular distortion, theta prime */ double conv; /* convergence */ double s; /* areal scale factor */ double a, b; /* max-min scale error */ int code; /* info as to analytics, see following */ }; #define IS_ANAL_XL_YL 01 /* derivatives of lon analytic */ #define IS_ANAL_XP_YP 02 /* derivatives of lat analytic */ #define IS_ANAL_HK 04 /* h and k analytic */ #define IS_ANAL_CONV 010 /* convergence analytic */ /* parameter list struct */ typedef struct ARG_list { struct ARG_list *next; char used; char param[1]; } paralist; /* base projection data structure */ typedef struct PJconsts { projCtx_t *ctx; XY (*fwd)(LP, struct PJconsts *); LP (*inv)(XY, struct PJconsts *); void (*spc)(LP, struct PJconsts *, struct FACTORS *); void (*pfree)(struct PJconsts *); const char *descr; paralist *params; /* parameter list */ int over; /* over-range flag */ int geoc; /* geocentric latitude flag */ int is_latlong; /* proj=latlong ... not really a projection at all */ int is_geocent; /* proj=geocent ... not really a projection at all */ double a, /* major axis or radius if es==0 */ a_orig, /* major axis before any +proj related adjustment */ es, /* e ^ 2 */ es_orig, /* es before any +proj related adjustment */ e, /* eccentricity */ ra, /* 1/A */ one_es, /* 1 - e^2 */ rone_es, /* 1/one_es */ lam0, phi0, /* central longitude, latitude */ x0, y0, /* easting and northing */ k0, /* general scaling factor */ to_meter, fr_meter; /* cartesian scaling */ int datum_type; /* PJD_UNKNOWN/3PARAM/7PARAM/GRIDSHIFT/WGS84 */ double datum_params[7]; struct _pj_gi **gridlist; int gridlist_count; int has_geoid_vgrids; struct _pj_gi **vgridlist_geoid; int vgridlist_geoid_count; double vto_meter, vfr_meter; double from_greenwich; /* prime meridian offset (in radians) */ double long_wrap_center; /* 0.0 for -180 to 180, actually in radians*/ int is_long_wrap_set; char axis[4]; #ifdef PROJ_PARMS__ PROJ_PARMS__ #endif /* end of optional extensions */ } PJ; /* public API */ #include "proj_api.h" /* Generate pj_list external or make list from include file */ #ifndef PJ_LIST_H extern struct PJ_LIST pj_list[]; #else #define PROJ_HEAD(id, name) \ struct PJconsts *pj_##id(struct PJconsts*); extern char * const pj_s_##id; #ifndef lint #define DO_PJ_LIST_ID #endif #include PJ_LIST_H #ifndef lint #undef DO_PJ_LIST_ID #endif #undef PROJ_HEAD #define PROJ_HEAD(id, name) {#id, pj_##id, &pj_s_##id}, struct PJ_LIST pj_list[] = { #include PJ_LIST_H {0, 0, 0}, }; #undef PROJ_HEAD #endif #ifndef PJ_ELLPS__ extern struct PJ_ELLPS pj_ellps[]; #endif #ifndef PJ_UNITS__ extern struct PJ_UNITS pj_units[]; #endif #ifndef PJ_DATUMS__ extern struct PJ_DATUMS pj_datums[]; extern struct PJ_PRIME_MERIDIANS pj_prime_meridians[]; #endif #ifdef PJ_LIB__ /* repeatative projection code */ #define PROJ_HEAD(id, name) static const char des_##id [] = name #define ENTRYA(name) \ C_NAMESPACE_VAR const char * const pj_s_##name = des_##name; \ C_NAMESPACE PJ *pj_##name(PJ *P) { if (!P) { \ if( (P = (PJ*) pj_malloc(sizeof(PJ))) != NULL) { \ memset( P, 0, sizeof(PJ) ); \ P->pfree = freeup; P->fwd = 0; P->inv = 0; \ P->spc = 0; P->descr = des_##name; #define ENTRYX } return P; } else { #define ENTRY0(name) ENTRYA(name) ENTRYX #define ENTRY1(name, a) ENTRYA(name) P->a = 0; ENTRYX #define ENTRY2(name, a, b) ENTRYA(name) P->a = 0; P->b = 0; ENTRYX #define ENDENTRY(p) } return (p); } #define E_ERROR(err) { pj_ctx_set_errno( P->ctx, err); freeup(P); return(0); } #define E_ERROR_0 { freeup(P); return(0); } #define F_ERROR { pj_ctx_set_errno( P->ctx, -20); return(xy); } #define I_ERROR { pj_ctx_set_errno( P->ctx, -20); return(lp); } #define FORWARD(name) static XY name(LP lp, PJ *P) { XY xy = {0.0,0.0} #define INVERSE(name) static LP name(XY xy, PJ *P) { LP lp = {0.0,0.0} #define FREEUP static void freeup(PJ *P) { #define SPECIAL(name) static void name(LP lp, PJ *P, struct FACTORS *fac) #endif #define MAX_TAB_ID 80 typedef struct { float lam, phi; } FLP; typedef struct { int lam, phi; } ILP; struct CTABLE { char id[MAX_TAB_ID]; /* ascii info */ LP ll; /* lower left corner coordinates */ LP del; /* size of cells */ ILP lim; /* limits of conversion matrix */ FLP *cvs; /* conversion matrix */ }; typedef struct _pj_gi { char *gridname; /* identifying name of grid, eg "conus" or ntv2_0.gsb */ char *filename; /* full path to filename */ const char *format; /* format of this grid, ie "ctable", "ntv1", "ntv2" or "missing". */ int grid_offset; /* offset in file, for delayed loading */ struct CTABLE *ct; struct _pj_gi *next; struct _pj_gi *child; } PJ_GRIDINFO; /* procedure prototypes */ double dmstor(const char *, char **); double dmstor_ctx(projCtx ctx, const char *, char **); void set_rtodms(int, int); char *rtodms(char *, double, int, int); double adjlon(double); double aacos(projCtx,double), aasin(projCtx,double), asqrt(double), aatan2(double, double); PJ_VALUE pj_param(projCtx ctx, paralist *, const char *); paralist *pj_mkparam(char *); int pj_ell_set(projCtx ctx, paralist *, double *, double *); int pj_datum_set(projCtx,paralist *, PJ *); int pj_prime_meridian_set(paralist *, PJ *); int pj_angular_units_set(paralist *, PJ *); paralist *pj_clone_paralist( const paralist* ); paralist*pj_search_initcache( const char *filekey ); void pj_insert_initcache( const char *filekey, const paralist *list); double *pj_enfn(double); double pj_mlfn(double, double, double, double *); double pj_inv_mlfn(projCtx, double, double, double *); double pj_qsfn(double, double, double); double pj_tsfn(double, double, double); double pj_msfn(double, double, double); double pj_phi2(projCtx, double, double); double pj_qsfn_(double, PJ *); double *pj_authset(double); double pj_authlat(double, double *); COMPLEX pj_zpoly1(COMPLEX, COMPLEX *, int); COMPLEX pj_zpolyd1(COMPLEX, COMPLEX *, int, COMPLEX *); FILE *pj_open_lib(projCtx, char *, char *); int pj_deriv(LP, double, PJ *, struct DERIVS *); int pj_factors(LP, PJ *, double, struct FACTORS *); struct PW_COEF {/* row coefficient structure */ int m; /* number of c coefficients (=0 for none) */ double *c; /* power coefficients */ }; /* Approximation structures and procedures */ typedef struct { /* Chebyshev or Power series structure */ projUV a, b; /* power series range for evaluation */ /* or Chebyshev argument shift/scaling */ struct PW_COEF *cu, *cv; int mu, mv; /* maximum cu and cv index (+1 for count) */ int power; /* != 0 if power series, else Chebyshev */ } Tseries; Tseries *mk_cheby(projUV, projUV, double, projUV *, projUV (*)(projUV), int, int, int); projUV bpseval(projUV, Tseries *); projUV bcheval(projUV, Tseries *); projUV biveval(projUV, Tseries *); void *vector1(int, int); void **vector2(int, int, int); void freev2(void **v, int nrows); int bchgen(projUV, projUV, int, int, projUV **, projUV(*)(projUV)); int bch2bps(projUV, projUV, projUV **, int, int); /* nadcon related protos */ LP nad_intr(LP, struct CTABLE *); LP nad_cvt(LP, int, struct CTABLE *); struct CTABLE *nad_init(projCtx ctx, char *); struct CTABLE *nad_ctable_init( projCtx ctx, FILE * fid ); int nad_ctable_load( projCtx ctx, struct CTABLE *, FILE * fid ); struct CTABLE *nad_ctable2_init( projCtx ctx, FILE * fid ); int nad_ctable2_load( projCtx ctx, struct CTABLE *, FILE * fid ); void nad_free(struct CTABLE *); /* higher level handling of datum grid shift files */ int pj_apply_vgridshift( PJ *defn, const char *listname, PJ_GRIDINFO ***gridlist_p, int *gridlist_count_p, int inverse, long point_count, int point_offset, double *x, double *y, double *z ); int pj_apply_gridshift_2( PJ *defn, int inverse, long point_count, int point_offset, double *x, double *y, double *z ); int pj_apply_gridshift_3( projCtx ctx, PJ_GRIDINFO **gridlist, int gridlist_count, int inverse, long point_count, int point_offset, double *x, double *y, double *z ); PJ_GRIDINFO **pj_gridlist_from_nadgrids( projCtx, const char *, int * ); void pj_deallocate_grids(); PJ_GRIDINFO *pj_gridinfo_init( projCtx, const char * ); int pj_gridinfo_load( projCtx, PJ_GRIDINFO * ); void pj_gridinfo_free( projCtx, PJ_GRIDINFO * ); void *proj_mdist_ini(double); double proj_mdist(double, double, double, const void *); double proj_inv_mdist(projCtx ctx, double, const void *); void *pj_gauss_ini(double, double, double *,double *); LP pj_gauss(projCtx, LP, const void *); LP pj_inv_gauss(projCtx, LP, const void *); extern char const pj_release[]; struct PJ_ELLPS *pj_get_ellps_ref( void ); struct PJ_DATUMS *pj_get_datums_ref( void ); struct PJ_UNITS *pj_get_units_ref( void ); struct PJ_LIST *pj_get_list_ref( void ); struct PJ_PRIME_MERIDIANS *pj_get_prime_meridians_ref( void ); #ifndef DISABLE_CVSID # if defined(__GNUC__) && __GNUC__ >= 4 # define PJ_CVSID(string) static char pj_cvsid[] __attribute__((used)) = string; # else # define PJ_CVSID(string) static char pj_cvsid[] = string; \ static char *cvsid_aw() { return( cvsid_aw() ? ((char *) NULL) : pj_cvsid ); } # endif #else # define PJ_CVSID(string) #endif #ifdef __cplusplus } #endif #endif /* end of basic projections header */ PDL-2.018/Lib/GIS/Proj/Makefile.PL0000644060175006010010000000336512562522364014426 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my $PJ_VERSION; my $donot; my $package_name = "PDL::GIS::Proj"; my $lib_name = "Proj"; my $config_flag = 'WITH_PROJ'; my $config_libs = 'PROJ_LIBS'; my $config_incs = 'PROJ_INC'; my $forcebuild=0; # Note: forcebuild not used if (defined $PDL::Config{$config_flag} && $PDL::Config{$config_flag}==0) { write_dummy_make("Will skip build of $package_name on this system"); $PDL::Config{$config_flag}=0; return; } require Alien::Proj4; # runtime not compile-time so return above will work my @inc = Alien::Proj4->default_inc; @inc = @{$PDL::Config{$config_incs}} if $PDL::Config{$config_incs} and @{$PDL::Config{$config_incs}}; push @inc, qw(include); Alien::Proj4->import($PDL::Config{$config_libs}, \@inc); if (defined $PDL::Config{$config_flag} && $PDL::Config{$config_flag}==1) { print "\n Will forcibly try and build $package_name on this system \n\n"; $forcebuild=1; } if (!$forcebuild && !Alien::Proj4->installed) { write_dummy_make( <libflags; my $incflags = Alien::Proj4->incflags; print "Building $package_name. Turn off $config_flag if there are any problems\n"; $PDL::Config{$config_flag}=1; my $ppfile = "Proj.pd"; my $package = [$ppfile, 'Proj', $package_name]; my %hash = pdlpp_stdargs($package); $hash{VERSION_FROM} = $ppfile; #$hash{TYPEMAPS} = [&PDL_TYPEMAP()]; $hash{LIBS} = [ $libflags ]; $hash{INC} = PDL_INCLUDE() . " $incflags"; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int( $package ); }; WriteMakefile(%hash); PDL-2.018/Lib/GIS/Proj/Proj.pd0000644060175006010010000004076013036512175013707 0ustar chmNone# # Proj.pd - PP def file for the Proj4->PDL interface. # # COPYRIGHT NOTICE: # # Copyright 2003 Judd Taylor, USF Institute for Marine Remote Sensing (judd@marine.usf.edu). # # Now GPL! # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # use strict; use vars qw( $VERSION ); $VERSION = "1.32"; # when switch to Alien::Proj4 as separate module # use Alien::Proj4; pp_addpm(<<'EODOC'); =head1 NAME PDL::GIS::Proj - PDL interface to the Proj4 projection library. =head1 DESCRIPTION PDL interface to the Proj4 projection library. For more information on the proj library, see: http://www.remotesensing.org/proj/ =head1 AUTHOR Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 DATE 18 March 2003 =head1 CHANGES =head2 1.32 (29 March 2006) Judd Taylor - Getting ready to merge this into the PDL CVS. =head2 1.31 (???) Judd Taylor - Can't remember what was in that version =head2 1.30 (16 September 2003) Judd Taylor - The get_proj_info() function actually works now. =head2 1.20 (24 April 2003) Judd Taylor - Added get_proj_info(). =head2 1.10 (23 April 2003) Judd Taylor - Changed from using the proj_init() type API in projects.h to the - proj_init_plus() API in proj_api.h. The old one was not that stable... =head2 1.00 (18 March 2003) Judd Taylor - Initial version =head1 COPYRIGHT NOTICE Copyright 2003 Judd Taylor, USF Institute for Marine Remote Sensing (judd@marine.usf.edu). GPL Now! This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. =head1 SUBROUTINES =cut EODOC # # Header files: # pp_addhdr(<<'EOHDR'); #include "projects.h" #include "proj_api.h" #include EOHDR pp_addpm(<<'EOPM'); =head2 fwd_transform($lon(pdl), $lat(pdl), $params) Proj4 forward transformation $params is a string of the projection transformation parameters. Returns two pdls for x and y values respectively. The units are dependent on Proj4 behavior. They will be PDL->null if an error has occurred. BadDoc: Ignores bad elements of $lat and $lon, and sets the corresponding elements of $x and $y to BAD =cut sub fwd_transform { my ($lon, $lat, $params) = @_; my $x = null; my $y = null; #print "Projection transformation parameters: \'$params\'\n"; _fwd_trans( $lon, $lat, $x, $y, $params ); return ($x, $y); } # End of fwd_transform()... =head2 inv_transform($x(pdl), $y(pdl), $params) Proj4 inverse transformation $params is a string of the projection transformation parameters. Returns two pdls for lat and lon values respectively. The units are dependent on Proj4 behavior. They will be PDL->null if an error has occurred. BadDoc: Ignores bad elements of $lat and $lon, and sets the corresponding elements of $x and $y to BAD =cut sub inv_transform { my ($x, $y, $params) = @_; my $lon = null; my $lat = null; #print "Projection transformation parameters: \'$params\'\n"; _inv_trans( $x, $y, $lon, $lat, $params ); return ($lon, $lat); } # End of fwd_transform()... =head2 get_proj_info($params_string) Returns a string with information about what parameters proj will actually use, this includes defaults, and +init=file stuff. It's the same as running 'proj -v'. It uses the proj command line, so it might not work with all shells. I've tested it with bash. =cut sub get_proj_info { my $params = shift; my @a = split(/\n/, `echo | proj -v $params`); pop(@a); return join("\n", @a); } # End of get_proj_info()... EOPM pp_add_exported('', ' fwd_transform inv_transform get_proj_info '); # # Forward transformation: # pp_def( '_fwd_trans', Pars => 'lon(n); lat(n); [o] x(n); [o] y(n);', GenericTypes => ['D'], Inplace => ['lon', 'x', 'lat', 'y'], OtherPars => 'char* params;', HandleBad => 1, Doc => undef, #BadDoc => 'Ignores bad elements of $lat and $lon, and sets ' # . 'the corresponding elements of $x and $y to BAD', Code => <<'EOCODE', /* vars needed: */ char* func = "_fwd_trans()"; char errstr[255]; projUV in, out; projPJ proj; const double d2r = DEG_TO_RAD; /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("%s: Projection initialization failed: %s\n", func, pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ loop (n) %{ in.u = $lon() * d2r; in.v = $lat() * d2r; out = pj_fwd(in, proj); if (out.u == HUGE_VAL) { croak("%s: Projection conversion failed at (%f, %f): %s\n", func, $lon(), $lat(), pj_strerrno(pj_errno)); } $x() = out.u; $y() = out.v; %} pj_free(proj); EOCODE BadCode => <<'EOBAD'); /* vars needed: */ char* func = "_fwd_trans()"; char errstr[255]; projUV in, out; projPJ proj; const double d2r = DEG_TO_RAD; /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("%s: Projection initialization failed: %s\n", func, pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ loop (n) %{ if ( $ISBAD(lon()) || $ISBAD(lat()) ) { $SETBAD(x()); $SETBAD(y()); } else { in.u = $lon() * d2r; in.v = $lat() * d2r; out = pj_fwd(in, proj); if (out.u == HUGE_VAL) { croak("%s: Projection conversion failed at (%f, %f): %s\n", func, $lon(), $lat(), pj_strerrno(pj_errno)); } $x() = out.u; $y() = out.v; } %} EOBAD # # INPLACE Forward transformation: (Call this one directly) # pp_addpm( <<'ENDPM' ); # # Wrapper sub for _fwd_trans_inplace that sets a default for the quiet variable. # sub fwd_trans_inplace { my $lon = shift; my $lat = shift; my $params = shift; my $quiet = shift || 0; _fwd_trans_inplace( $lon, $lat, $params, $quiet ); } # End of fwd_trans_inplace()... ENDPM pp_add_exported('', 'fwd_trans_inplace'); pp_def( '_fwd_trans_inplace', Pars => 'lon(); lat();', GenericTypes => ['F', 'D'], OtherPars => 'char* params; int quiet;', HandleBad => 1, Doc => undef, #BadDoc => 'Ignores bad elements of $lat and $lon, and sets ' # . 'the corresponding elements of $x and $y to BAD', Code => <<'EOCODE', /* vars needed: */ char* func = "_fwd_trans_inplace()"; char errstr[255]; projUV in, out; projPJ proj; const double d2r = DEG_TO_RAD; /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("%s: Projection initialization failed: %s\n", func, pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ threadloop %{ in.u = $lon() * d2r; in.v = $lat() * d2r; out = pj_fwd(in, proj); if (out.u == HUGE_VAL) { croak("%s: Projection conversion failed at (%f, %f): %s\n", func, $lon(), $lat(), pj_strerrno(pj_errno)); } $lon() = out.u; $lat() = out.v; %} pj_free(proj); EOCODE BadCode => <<'EOBAD'); /* vars needed: */ char* func = "_fwd_trans_inplace[BADCODE]()"; char errstr[255]; projUV in, out; projPJ proj; const double d2r = DEG_TO_RAD; int loud = ! $COMP(quiet); /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("%s: Projection initialization failed: %s\n", func, pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ threadloop %{ if ( !($ISBAD(lon()) || $ISBAD(lat())) ) { in.u = $lon() * d2r; in.v = $lat() * d2r; out = pj_fwd(in, proj); if (out.u != HUGE_VAL) { $lon() = out.u; $lat() = out.v; } else { $SETBAD( lon() ); $SETBAD( lat() ); if( loud ) { sprintf(errstr, "%s: Projection conversion failed at (%f, %f): %s\n", func, $lon(), $lat(), pj_strerrno(pj_errno)); fprintf( stderr, "%s", errstr ); fprintf( stderr, "%s: NOTE: Subsequent errors may have occurred, but I'm only reporting the first!\n", func ); } } } %} pj_free(proj); EOBAD # # Inverse Transformation: # pp_def( '_inv_trans', Pars => 'x(n); y(n); [o] lon(n); [o] lat(n);', GenericTypes => ['D'], OtherPars => 'char* params;', HandleBad => 1, Doc => undef, #BadDoc => 'Ignores bad elements of $x and $y, and sets ' # . 'the corresponding elements of $lon and $lat to BAD', Code => <<'EOCODE', /* vars needed: */ char errstr[255]; projUV in, out; projPJ proj; const double r2d = RAD_TO_DEG; /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("Projection initialization failed: %s\n", pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ loop (n) %{ in.u = $x(); in.v = $y(); out = pj_inv(in, proj); if (out.u == HUGE_VAL) { croak("Projection conversion failed: %s\n", pj_strerrno(pj_errno)); } $lon() = out.u * r2d; $lat() = out.v * r2d; %} pj_free(proj); EOCODE BadCode => <<'EOBAD' ); /* vars needed: */ char errstr[255]; projUV in, out; projPJ proj; const double r2d = RAD_TO_DEG; /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("Projection initialization failed: %s\n", pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ loop (n) %{ if ( $ISBAD(x()) || $ISBAD(y()) ) { $SETBAD(lon()); $SETBAD(lat()); } else { in.u = $x(); in.v = $y(); out = pj_inv(in, proj); if (out.u == HUGE_VAL) { croak("Projection conversion failed: %s\n", pj_strerrno(pj_errno)); } $lon() = out.u * r2d; $lat() = out.v * r2d; } %} pj_free(proj); EOBAD # # INPLACE Inverse Transformation: (call it directly) # pp_addpm( <<'ENDPM' ); # # Wrapper sub for _fwd_trans_inplace that sets a default for the quiet variable. # sub inv_trans_inplace { my $lon = shift; my $lat = shift; my $params = shift; my $quiet = shift || 0; _inv_trans_inplace( $lon, $lat, $params, $quiet ); } # End of fwd_trans_inplace()... ENDPM pp_add_exported('', 'inv_trans_inplace'); pp_def( '_inv_trans_inplace', Pars => 'x(); y();', GenericTypes => ['F','D'], OtherPars => 'char* params; int quiet;', HandleBad => 1, Doc => undef, #BadDoc => 'Ignores bad elements of $x and $y, and sets ' # . 'the corresponding elements of $lon and $lat to BAD', Code => <<'EOCODE', /* vars needed: */ char* func = "_inv_trans_inplace()"; char errstr[255]; projUV in, out; projPJ proj; const double r2d = RAD_TO_DEG; /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("%s: Projection initialization failed: %s\n", func, pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ threadloop %{ in.u = $x(); in.v = $y(); out = pj_inv(in, proj); if (out.u == HUGE_VAL) { croak("%s: Projection conversion failed: %s\n", func, pj_strerrno(pj_errno)); } $x() = out.u * r2d; $y() = out.v * r2d; %} pj_free(proj); EOCODE BadCode => <<'EOBAD' ); /* vars needed: */ char* func = "_inv_trans_inplace[BADCODE]()"; char errstr[255]; projUV in, out; projPJ proj; const double r2d = RAD_TO_DEG; int loud = ! $COMP(quiet); /* Init the projection */ proj = pj_init_plus( $COMP(params) ); if( proj == NULL ) { croak("%s: Projection initialization failed: %s\n", func, pj_strerrno(pj_errno)); } /* Loop over the values converting as we go */ threadloop %{ if ( ! ($ISBAD(x()) || $ISBAD(y())) ) { in.u = $x(); in.v = $y(); out = pj_inv(in, proj); if (out.u != HUGE_VAL) { $x() = out.u * r2d; $y() = out.v * r2d; } else { $SETBAD( x() ); $SETBAD( y() ); if( loud ) { /* Don't croak, just set the output to bad: */ sprintf(errstr, "%s: Projection conversion failed at (%f, %f): %s\n", func, $x(), $y(), pj_strerrno(pj_errno)); fprintf( stderr, "%s", errstr ); fprintf( stderr, "%s: NOTE: Subsequent errors may have occurred, but I'm only reporting the first!\n", func ); } } } %} pj_free(proj); EOBAD # # Utility functions for getting projection description information (in a general case). # # when switch to Alien::Proj4 as separate module, replace with: # pp_addpm(<<'ENDPM' ); # sub load_projection_descriptions { # return Alien::Proj4->load_projection_descriptions; # } # ENDPM pp_addxs('', <<'ENDXS' ); HV* load_projection_descriptions() CODE: struct PJ_LIST *lp; SV* scalar_val; RETVAL = newHV(); for (lp = pj_get_list_ref() ; lp->id ; ++lp) { scalar_val = newSVpv( *lp->descr, 0 ); hv_store( RETVAL, lp->id, strlen( lp->id ), scalar_val, 0 ); } OUTPUT: RETVAL ENDXS pp_add_exported('', ' load_projection_descriptions '); # # Perl code to finish loading the projetion information by parsing the descriptions: # # when switch to Alien::Proj4 as separate module, replace with: # pp_addpm(<<'ENDPM' ); # sub load_projection_information { # return Alien::Proj4->load_projection_information; # } # ENDPM pp_addpm( <<'ENDPM' ); sub load_projection_information { my $descriptions = PDL::GIS::Proj::load_projection_descriptions(); my $info = {}; foreach my $projection ( keys %$descriptions ) { my $description = $descriptions->{$projection}; my $hash = {}; $hash->{CODE} = $projection; my @lines = split( /\n/, $description ); chomp @lines; # Full name of this projection: $hash->{NAME} = $lines[0]; # The second line is usually a list of projection types this one is: my $temp = $lines[1]; $temp =~ s/no inv\.*,*//; $temp =~ s/or//; my @temp_types = split(/[,&\s]/, $temp ); my @types = grep( /.+/, @temp_types ); $hash->{CATEGORIES} = \@types; # If there's more than 2 lines, then it usually is a listing of parameters: # General parameters for all projections: $hash->{PARAMS}->{GENERAL} = [ qw( x_0 y_0 lon_0 units init no_defs geoc over ) ]; # Earth Figure Parameters: $hash->{PARAMS}->{EARTH} = [ qw( ellps b f rf e es R R_A R_V R_a R_g R_h R_lat_g ) ]; # Projection Specific Parameters: my @proj_params = (); if( $#lines >= 2 ) { foreach my $i ( 2 .. $#lines ) { my $text = $lines[$i]; my @temp2 = split( /\s+/, $text ); my @params = grep( /.+/, @temp2 ); foreach my $param (@params) { $param =~ s/=//; $param =~ s/[,\[\]]//sg; next if $param =~ /^and$/; next if $param =~ /^or$/; next if $param =~ /^Special$/; next if $param =~ /^for$/; next if $param =~ /^Madagascar$/; next if $param =~ /^fixed$/; next if $param =~ /^Earth$/; next if $param =~ /^For$/; next if $param =~ /^CH1903$/; push(@proj_params, $param); } } } $hash->{PARAMS}->{PROJ} = \@proj_params; # Can this projection do inverse? $hash->{INVERSE} = ( $description =~ /no inv/ ) ? 0 : 1; $info->{$projection} = $hash; } # A couple of overrides: # $info->{ob_tran}->{PARAMS}->{PROJ} = [ 'o_proj', 'o_lat_p', 'o_lon_p', 'o_alpha', 'o_lon_c', 'o_lat_c', 'o_lon_1', 'o_lat_1', 'o_lon_2', 'o_lat_2' ]; $info->{nzmg}->{CATEGORIES} = [ 'fixed Earth' ]; return $info; } # End of load_projection_information()... ENDPM pp_add_exported('', ' load_projection_information '); pp_done(); PDL-2.018/Lib/GIS/Proj/README0000644060175006010010000000256312562522364013333 0ustar chmNoneNAME PDL::Transform::Proj DESCRIPTION This is a port of the Proj library to PDL. COPYRIGHT NOTICE Copyright 2003 Judd Taylor, USF Institute for Marine Remote Sensing (judd@marine.usf.edu). This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. I'm making it GPL now, so I should probably update the above notice! PREREQUISITES Proj4 C library (tested with 4.4.5) Perl (tested with 5.8.0) PDL (tested with 2.3.4 with BadVals) BUILD INSTRUCTIONS 1. Install the Proj4 library if you haven't already. 2. Edit the Makefile.PL to point the $proj4_include_path and $proj4_lib_path variables to your installation of the Proj4 library. 3. Make the makefiles with the command: shell> perl Makefile.PL 4. Build the software with the command: shell> make 5. Install the software with the command: shell> make install 6. Test the software (option) using the included script test_proj4.pl. NOTE: There are no regression tests yet, but if something is wrong with the install, it will probably break the test script. USAGE See the POD in the lib itself, and check out the test script. CHANGES 1.0: Inital version PDL-2.018/Lib/GIS/Proj/TODO0000644060175006010010000000006712562522364013140 0ustar chmNone# # TODO for version 1.32 of PDL::Transform::Proj: # PDL-2.018/Lib/GSL/0000755060175006010010000000000013110402045011515 5ustar chmNonePDL-2.018/Lib/GSL/DIFF/0000755060175006010010000000000013110402046012226 5ustar chmNonePDL-2.018/Lib/GSL/DIFF/FUNC.c0000644060175006010010000000101512562522364013142 0ustar chmNonestatic SV* ext_funname; static gsl_function F; double FUNC(double x,void * p); double FUNC(double x,void * p){ double res; int count; dSP; SV* funname; /* get function name on the perl side */ funname = ext_funname; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVnv(x))); PUTBACK; count=call_sv(funname,G_SCALAR); SPAGAIN; if (count!=1) croak("error calling perl function\n"); /* recover output value */ res = POPn; PUTBACK; FREETMPS; LEAVE; return res; } PDL-2.018/Lib/GSL/DIFF/gsl_diff.pd0000644060175006010010000001025013101130663014331 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSL::DIFF - PDL interface to numerical differentiation routines in GSL =head1 DESCRIPTION This is an interface to the numerical differentiation package present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::DIFF; my $x0 = 3.3; my @res = gsldiff(\&myfunction,$x0); # same as above: @res = gsldiff(\&myfunction,$x0,{Method => 'central'}); # use only values greater than $x0 to get the derivative @res = gsldiff(\&myfunction,$x0,{Method => 'forward'}); # use only values smaller than $x0 to get the derivative @res = gsldiff(\&myfunction,$x0,{Method => 'backward'}); sub myfunction{ my ($x) = @_; return $x**2; } EOD pp_addpm({At=>Bot},<<'EOD'); # the rest of FUNCTIONS section =head2 gsldiff =for ref This functions serves as an interface to the three differentiation functions present in GSL: gsl_diff_central, gsl_diff_backward and gsl_diff_forward. To compute the derivative, the central method uses values greater and smaller than the point at which the derivative is to be evaluated, while backward and forward use only values smaller and greater respectively. gsldiff() returns both the derivative and an absolute error estimate. The default method is 'central', others can be specified by passing an option. Please check the GSL documentation for more information. =for usage Usage: ($d,$abserr) = gsldiff($function_ref,$x,{Method => $method}); =for example Example: #derivative using default method ('central') ($d,$abserr) = gsldiff(\&myf,3.3); #same as above with method set explicitly ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'central'}); #using backward & forward methods ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'backward'}); ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'forward'}); sub myf{ my ($x) = @_; return exp($x); } =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L). =head1 SEE ALSO L The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2003 Andres Jordan All rights reserved. There is no warranty. You are allowed to redistribute this software documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL differentiation routines were written by David Morrison. =cut EOD pp_addhdr(' #include #include #include #include "FUNC.c" '); pp_addpm(' sub gsldiff{ my $opt; if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Method => \'central\'}; } die \'Usage: gsldiff(function_ref, x, {Options} )\' if $#_<1 || $#_>2; my ($f,$x) = @_; my ($res,$abserr); if($$opt{Method}=~/cent/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_central($x,$f); } elsif($$opt{Method}=~/back/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_backward($x,$f); } elsif($$opt{Method}=~/forw/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_forward($x,$f); } else{ barf("Unknown differentiation method $method in gsldiff\n"); } return ($res,$abserr); } '); pp_add_exported('gsldiff'); pp_def('diff_central', Pars => 'double x(); double [o] res(); double [o] abserr();', OtherPars => 'SV* function;', Docs => undef, Code => ' ext_funname = $COMP(function); F.function = &FUNC; F.params = 0; gsl_diff_central (&F, $x(), $P(res), $P(abserr)); '); pp_def('diff_backward', Pars => 'double x(); double [o] res(); double [o] abserr();', OtherPars => 'SV* function;', Docs => undef, Code => ' ext_funname = $COMP(function); F.function = &FUNC; F.params = 0; gsl_diff_backward (&F, $x(), $P(res), $P(abserr)); '); pp_def('diff_forward', Pars => 'double x(); double [o] res(); double [o] abserr();', OtherPars => 'SV* function;', Docs => undef, Code => ' ext_funname = $COMP(function); F.function = &FUNC; F.params = 0; gsl_diff_forward (&F, $x(), $P(res), $P(abserr)); '); pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/DIFF/Makefile.PL0000644060175006010010000000336412562522364014226 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my $msg = undef; my $forcebuild=0; my $skip = 0; # this Makefile uses get_gsl_libs which is defined in # the parent Makefile.PL sub gsl_diff_links_ok { my($lib,$inc) = @_; return defined($lib) && defined($inc) && trylink( 'gsl diff libraries', << 'EOI', #include #include #include double f (double x, void * params) { return pow (x, 1.5); } EOI << 'EOB', $lib, $inc); gsl_function F; double result, abserr; F.function = &f; F.params = 0; gsl_diff_central (&F, 2.0, &result, &abserr); gsl_diff_forward (&F, 0.0, &result, &abserr); gsl_diff_backward (&F, 0.0, &result, &abserr); EOB } if (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==0) { $msg = "\n Will skip build of PDL::GSL::DIFF on this system \n"; $skip = 1; } elsif (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==1) { print "\n Will forcibly try and build PDL::GSL::DIFF on this system \n\n"; $forcebuild=1; } if (($skip && !$forcebuild) || !gsl_diff_links_ok($GSL_libs, $GSL_includes)) { warn "trying to force GSL build but link test failed\n". "\t -- aborting GSL build\n" if $forcebuild; $msg ||= "\n GSL Libraries not found... Skipping build of PDL::GSL::DIFF.\n"; write_dummy_make( $msg ); return; } else { print "\n Building PDL::GSL::DIFF.", "Turn off WITH_GSL if there are any problems\n\n"; } my @pack = (["gsl_diff.pd", qw(DIFF PDL::GSL::DIFF)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= " $GSL_includes"; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/INTEG/0000755060175006010010000000000013110402046012364 5ustar chmNonePDL-2.018/Lib/GSL/INTEG/FUNC.c0000644060175006010010000000136112562522364013304 0ustar chmNone#define max_nested_integrals 20 static SV* ext_funname[max_nested_integrals - 1]; static int current_fun = -1; static gsl_function F; double FUNC(double x,void * p); double FUNC(double x,void * p){ SV* funname; int count; I32 ax ; double res; double* resp; dSP; resp = &res; ENTER; SAVETMPS; /* get function name on the perl side */ funname = ext_funname[current_fun]; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVnv(x))); PUTBACK; count=call_sv(funname,G_SCALAR); SPAGAIN; SP -= count ; ax = (SP - PL_stack_base) + 1 ; if (count!=1) croak("error calling perl function\n"); /* recover output value */ /*res = POPn;*/ *resp = SvNV(ST(0)); PUTBACK; FREETMPS; LEAVE; return res; } PDL-2.018/Lib/GSL/INTEG/gsl_integ.pd0000644060175006010010000007542313036512175014713 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSL::INTEG - PDL interface to numerical integration routines in GSL =head1 DESCRIPTION This is an interface to the numerical integration package present in the GNU Scientific Library, which is an implementation of QUADPACK. Functions are named B where {algorithm} is the QUADPACK naming convention. The available functions are: =over 3 =item gslinteg_qng: Non-adaptive Gauss-Kronrod integration =item gslinteg_qag: Adaptive integration =item gslinteg_qags: Adaptive integration with singularities =item gslinteg_qagp: Adaptive integration with known singular points =item gslinteg_qagi: Adaptive integration on infinite interval of the form (-\infty,\infty) =item gslinteg_qagiu: Adaptive integration on infinite interval of the form (a,\infty) =item gslinteg_qagil: Adaptive integration on infinite interval of the form (-\infty,b) =item gslinteg_qawc: Adaptive integration for Cauchy principal values =item gslinteg_qaws: Adaptive integration for singular functions =item gslinteg_qawo: Adaptive integration for oscillatory functions =item gslinteg_qawf: Adaptive integration for Fourier integrals =back Each algorithm computes an approximation to the integral, I, of the function f(x)w(x), where w(x) is a weight function (for general integrands w(x)=1). The user provides absolute and relative error bounds (epsabs,epsrel) which specify the following accuracy requirement: |RESULT - I| <= max(epsabs, epsrel |I|) The routines will fail to converge if the error bounds are too stringent, but always return the best approximation obtained up to that stage All functions return the result, and estimate of the absolute error and an error flag (which is zero if there were no problems). You are responsible for checking for any errors, no warnings are issued unless the option {Warn => 'y'} is specified in which case the reason of failure will be printed. You can nest integrals up to 20 levels. If you find yourself in the unlikely situation that you need more, you can change the value of 'max_nested_integrals' in the first line of the file 'FUNC.c' and recompile. =for ref Please check the GSL documentation for more information. =head1 SYNOPSIS use PDL; use PDL::GSL::INTEG; my $a = 1.2; my $b = 3.7; my $epsrel = 0; my $epsabs = 1e-6; # Non adaptive integration my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&myf,$a,$b,$epsrel,$epsabs); # Warnings on my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&myf,$a,$b,$epsrel,$epsabs,{Warn=>'y'}); # Adaptive integration with warnings on my $limit = 1000; my $key = 5; my ($res,$abserr,$ierr) = gslinteg_qag(\&myf,$a,$b,$epsrel, $epsabs,$limit,$key,{Warn=>'y'}); sub myf{ my ($x) = @_; return exp(-$x**2); } EOD pp_addpm({At=>Bot},<<'EOD'); # the rest of FUNCTIONS section =head2 gslinteg_qng Non-adaptive Gauss-Kronrod integration This function applies the Gauss-Kronrod 10-point, 21-point, 43-point and 87-point integration rules in succession until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. It is meant for fast integration of smooth functions. It returns an array with the result, an estimate of the absolute error, an error flag and the number of function evaluations performed. =for usage Usage: ($res,$abserr,$ierr,$neval) = gslinteg_qng($function_ref,$a,$b, $epsrel,$epsabs,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&f,0,1,0,1e-9); # with warnings on my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&f,0,1,0,1e-9,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x**2.6)*log(1.0/$x); } =head2 gslinteg_qag Adaptive integration This function applies an integration rule adaptively until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. On each iteration the adaptive integration strategy bisects the interval with the largest error estimate; the maximum number of allowed subdivisions is given by the parameter $limit. The integration rule is determined by the value of $key, which has to be one of (1,2,3,4,5,6) and correspond to the 15, 21, 31, 41, 51 and 61 point Gauss-Kronrod rules respectively. It returns an array with the result, an estimate of the absolute error and an error flag. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qag($function_ref,$a,$b,$epsrel, $epsabs,$limit,$key,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qag(\&f,0,1,0,1e-10,1000,1); # with warnings on my ($res,$abserr,$ierr) = gslinteg_qag(\&f,0,1,0,1e-10,1000,1,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x**2.6)*log(1.0/$x); } =head2 gslinteg_qags Adaptive integration with singularities This function applies the Gauss-Kronrod 21-point integration rule adaptively until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. The algorithm is such that it accelerates the convergence of the integral in the presence of discontinuities and integrable singularities. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qags($function_ref,$a,$b,$epsrel, $epsabs,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qags(\&f,0,1,0,1e-10,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qags(\&f,0,1,0,1e-10,1000,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x)*log(1.0/$x); } =head2 gslinteg_qagp Adaptive integration with known singular points This function applies the adaptive integration algorithm used by gslinteg_qags taking into account the location of singular points until an estimate of the integral of f over ($a,$b) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. Singular points are supplied in the piddle $points, whose endpoints determine the integration range. So, for example, if the function has singular points at x_1 and x_2 and the integral is desired from a to b (a < x_1 < x_2 < b), $points = pdl(a,x_1,x_2,b). The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagp($function_ref,$points,$epsabs, $epsrel,$limit,[{Warn => $warn}]) =for example Example: my $points = pdl(0,1,sqrt(2),3); my ($res,$abserr,$ierr) = gslinteg_qagp(\&f,$points,0,1e-3,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagp(\&f,$points,0,1e-3,1000,{Warn => 'y'}); sub f{ my ($x) = @_; my $x2 = $x**2; my $x3 = $x**3; return $x3 * log(abs(($x2-1.0)*($x2-2.0))); } =head2 gslinteg_qagi Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (-\infty,+\infty) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagi($function_ref,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qagi(\&myfn,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagi(\&myfn,1e-7,0,1000,{Warn => 'y'}); sub myfn{ my ($x) = @_; return exp(-$x - $x*$x) ; } =head2 gslinteg_qagiu Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (a,+\infty) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagiu($function_ref,$a,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my $alfa = 1; my ($res,$abserr,$ierr) = gslinteg_qagiu(\&f,99.9,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagiu(\&f,99.9,1e-7,0,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if (($x==0) && ($alfa == 1)) {return 1;} if (($x==0) && ($alfa > 1)) {return 0;} return ($x**($alfa-1))/((1+10*$x)**2); } =head2 gslinteg_qagil Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (-\infty,b) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagl($function_ref,$b,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qagil(\&myfn,1.0,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagil(\&myfn,1.0,1e-7,0,1000,{Warn => 'y'}); sub myfn{ my ($x) = @_; return exp($x); } =head2 gslinteg_qawc Adaptive integration for Cauchy principal values This function computes the Cauchy principal value of the integral of f over (a,b), with a singularity at c, I = \int_a^b dx f(x)/(x - c). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawc($function_ref,$a,$b,$c,$epsabs,$epsrel,$limit) =for example Example: my ($res,$abserr,$ierr) = gslinteg_qawc(\&f,-1,5,0,0,1e-3,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qawc(\&f,-1,5,0,0,1e-3,1000,{Warn => 'y'}); sub f{ my ($x) = @_; return 1.0 / (5.0 * $x * $x * $x + 6.0) ; } =head2 gslinteg_qaws Adaptive integration for singular functions The algorithm in gslinteg_qaws is designed for integrands with algebraic-logarithmic singularities at the end-points of an integration region. Specifically, this function computes the integral given by I = \int_a^b dx f(x) (x-a)^alpha (b-x)^beta log^mu (x-a) log^nu (b-x). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawc($function_ref,$alpha,$beta,$mu,$nu,$a,$b, $epsabs,$epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qaws(\&f,0,0,1,0,0,1,0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qaws(\&f,0,0,1,0,0,1,0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if($x==0){return 0;} else{ my $u = log($x); my $v = 1 + $u*$u; return 1.0/($v*$v); } } =head2 gslinteg_qawo Adaptive integration for oscillatory functions This function uses an adaptive algorithm to compute the integral of f over (a,b) with the weight function sin(omega*x) or cos(omega*x) -- which of sine or cosine is used is determined by the parameter $opt ('cos' or 'sin'). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawo($function_ref,$omega,$sin_or_cos, $a,$b,$epsabs,$epsrel,$limit,[opt]) =for example Example: my $PI = 3.14159265358979323846264338328; my ($res,$abserr,$ierr) = PDL::GSL::INTEG::gslinteg_qawo(\&f,10*$PI,'sin',0,1,0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = PDL::GSL::INTEG::gslinteg_qawo(\&f,10*$PI,'sin',0,1,0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if($x==0){return 0;} else{ return log($x);} } =head2 gslinteg_qawf Adaptive integration for Fourier integrals This function attempts to compute a Fourier integral of the function f over the semi-infinite interval [a,+\infty). Specifically, it attempts tp compute I = \int_a^{+\infty} dx f(x)w(x), where w(x) is sin(omega*x) or cos(omega*x) -- which of sine or cosine is used is determined by the parameter $opt ('cos' or 'sin'). The integral is estimated within the desired absolute error limit $epsabs. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: gslinteg_qawf($function_ref,$omega,$sin_or_cos,$a,$epsabs,$limit,[opt]) =for example Example: my ($res,$abserr,$ierr) = gslinteg_qawf(\&f,$PI/2.0,'cos',0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qawf(\&f,$PI/2.0,'cos',0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if ($x == 0){return 0;} return 1.0/sqrt($x) } =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L). =head1 SEE ALSO L The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2003,2005 Andres Jordan All rights reserved. There is no warranty. You are allowed to redistribute this software documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL integration routines were written by Brian Gough. QUADPACK was written by Piessens, Doncker-Kapenga, Uberhuber and Kahaner. =cut EOD pp_add_exported('','gslinteg_qng gslinteg_qag gslinteg_qags gslinteg_qagp gslinteg_qagi gslinteg_qagiu gslinteg_qagil gslinteg_qawc gslinteg_qaws gslinteg_qawo gslinteg_qawf'); pp_addhdr(' #include #include #include #include #include "FUNC.c" void my_handler (const char * reason, const char * file, int line, int gsl_errno){ printf("Warning: %s at line %d of GSL file %s\n",reason,line,file); } '); pp_addpm(' sub gslinteg_qng{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$epsabs,$epsrel) = @_; barf \'Usage: gslinteg_qng($function_ref,$a,$b,$epsabs,$epsrel,[opt]) \' unless ($#_ == 4); my ($res,$abserr,$neval,$ierr) = qng_meat($a,$b,$epsabs,$epsrel,$warn,$f); return ($res,$abserr,$ierr,$neval); } '); pp_def('qng_meat', Pars => 'double a(); double b(); double epsabs(); double epsrel(); double [o] result(); double [o] abserr(); int [o] neval(); int [o] ierr(); int gslwarn()', OtherPars => 'SV* function;', Docs => undef, Code => ' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; $ierr() = gsl_integration_qng(&F,$a(),$b(),$epsabs(),$epsrel(),$P(result),$P(abserr),(size_t *) $P(neval)); current_fun--; '); pp_addpm(' sub gslinteg_qag{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$epsabs,$epsrel,$limit,$key) = @_; barf \'Usage: gslinteg_qag($function_ref,$a,$b,$epsabs,$epsrel,$limit,$key,[opt]) \' unless ($#_ == 6); my ($res,$abserr,$ierr) = qag_meat($a,$b,$epsabs,$epsrel,$limit,$key,$limit,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qag_meat', Pars => 'double a(); double b(); double epsabs();double epsrel(); int limit(); int key(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Docs => undef, Code =>' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_workspace *w; current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qag(&F,$a(),$b(),$epsabs(),$epsrel(),(size_t) $limit(),$key(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); current_fun--; } '); pp_addpm(' sub gslinteg_qags{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qags($function_ref,$a,$b,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 5); my ($res,$abserr,$ierr) = qags_meat($a,$b,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qags_meat', Pars => 'double a(); double b(); double epsabs();double epsrel(); int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Docs => undef, Code =>' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_workspace *w; current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qags(&F,$a(),$b(),$epsabs(),$epsrel(),(size_t) $limit(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); current_fun--; } '); pp_addpm(' sub gslinteg_qagp{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$points,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qagp($function_ref,$points,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagp_meat($points,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qagp_meat', Pars => 'double pts(l); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Code =>' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_workspace *w; current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qagp(&F,$P(pts),(size_t) $SIZE(l),$epsabs(),$epsrel(),(size_t) $limit(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); current_fun--; } '); pp_addpm(' sub gslinteg_qagi{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qagi($function_ref,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 3); my ($res,$abserr,$ierr) = qagi_meat($epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qagi_meat', Pars => 'double epsabs();double epsrel(); int limit(); double [o] result(); double [o] abserr(); int n(); int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Code =>' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_workspace *w; current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qagi(&F,$epsabs(),$epsrel(),(size_t) $limit(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); current_fun--; } '); pp_addpm(' sub gslinteg_qagiu{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qagiu($function_ref,$a,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagiu_meat($a,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qagiu_meat', Pars => 'double a(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Docs => undef, Code =>' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_workspace *w; current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qagiu(&F,$a(),$epsabs(),$epsrel(),(size_t) $limit(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); current_fun--; } '); pp_addpm(' sub gslinteg_qagil{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$b,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qagil($function_ref,$b,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagil_meat($b,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qagil_meat', Pars => 'double b(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Docs => undef, Code =>' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_workspace *w; current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qagil(&F,$b(),$epsabs(),$epsrel(),(size_t) $limit(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); current_fun--; } '); pp_addpm(' sub gslinteg_qawc{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$a,$b,$c,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qawc($function_ref,$a,$b,$c,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 6); my ($res,$abserr,$ierr) = qawc_meat($a,$b,$c,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qawc_meat', Pars => 'double a(); double b(); double c(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Code =>' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_workspace *w; current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qawc(&F,$a(),$b(),$c(),$epsabs(),$epsrel(),(size_t) $limit(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); current_fun--; } '); pp_addpm(' sub gslinteg_qaws{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$alpha,$beta,$mu,$nu,$a,$b,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qaws($function_ref,$alpha,$beta,$mu,$nu,$a,$b,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 9); my ($res,$abserr,$ierr) = qaws_meat($a,$b,$epsabs,$epsrel,$limit,$limit,$alpha,$beta,$mu,$nu,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qaws_meat', Pars => 'double a(); double b();double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n(); double alpha(); double beta(); int mu(); int nu();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Code => ' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_qaws_table * qtab; gsl_integration_workspace *w; qtab = gsl_integration_qaws_table_alloc($alpha(),$beta(),$mu(),$nu()); current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qaws(&F,$a(),$b(),qtab,$epsabs(),$epsrel(),(size_t) $limit(),w,$P(result),$P(abserr)); gsl_integration_workspace_free(w); gsl_integration_qaws_table_free(qtab); current_fun--; } '); pp_addpm(' sub gslinteg_qawo{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$omega,$sincosopt,$a,$b,$epsabs,$epsrel,$limit) = @_; barf \'Usage: gslinteg_qawo($function_ref,$omega,$sin_or_cos,$a,$b,$epsabs,$epsrel,$limit,[opt]) \' unless ($#_ == 7); my $OPTION_SIN_COS; if($sincosopt=~/cos/i){ $OPTION_SIN_COS = 0;} elsif($sincosopt=~/sin/i){ $OPTION_SIN_COS = 1;} else { barf("Error in argument 3 of function gslinteg_qawo: specify \'cos\' or \'sin\'\n");} my $L = $b - $a; my $nlevels = $limit; my ($res,$abserr,$ierr) = qawo_meat($a,$b,$epsabs,$epsrel,$limit,$limit,$OPTION_SIN_COS,$omega,$L,$nlevels,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qawo_meat', Pars => 'double a(); double b();double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n(); int sincosopt(); double omega(); double L(); int nlevels();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Code => ' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_qawo_table * qtab; gsl_integration_workspace *w; enum gsl_integration_qawo_enum T; T = GSL_INTEG_SINE; if ($sincosopt() == 0){ T = GSL_INTEG_COSINE ;} qtab = gsl_integration_qawo_table_alloc($omega(),$L(),T,(size_t) $nlevels()); current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qawo(&F,$a(),$epsabs(),$epsrel(),(size_t) $limit(),w,qtab,$P(result),$P(abserr)); gsl_integration_workspace_free(w); gsl_integration_qawo_table_free(qtab); current_fun--; } '); pp_addpm(' sub gslinteg_qawf{ my ($opt,$warn); if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Warn => \'n\'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$omega,$sincosopt,$a,$epsabs,$limit) = @_; barf \'Usage: gslinteg_qawf($function_ref,$omega,$sin_or_cos,$a,$epsabs,$limit,[opt]) \' unless ($#_ == 5); my $OPTION_SIN_COS; if($sincosopt=~/cos/i){ $OPTION_SIN_COS = 0;} elsif($sincosopt=~/sin/i){ $OPTION_SIN_COS = 1;} else { barf("Error in argument 3 of function gslinteg_qawf: specify \'cos\' or \'sin\'\n");} my $nlevels = $limit; my ($res,$abserr,$ierr) = qawf_meat($a,$epsabs,$limit,$limit,$OPTION_SIN_COS,$omega,$nlevels,$warn,$f); return ($res,$abserr,$ierr); } '); pp_def('qawf_meat', Pars => 'double a(); double epsabs();int limit(); double [o] result(); double [o] abserr();int n(); int sincosopt(); double omega(); int nlevels();int [o] ierr();int gslwarn();', OtherPars => 'SV* function;', Code => ' gsl_error_handler_t * old_handler; if ($gslwarn() == 1) { old_handler = gsl_set_error_handler(&my_handler); } else { gsl_set_error_handler_off ();} {gsl_integration_qawo_table * qtab; gsl_integration_workspace *w; gsl_integration_workspace *cw; enum gsl_integration_qawo_enum T; T = GSL_INTEG_SINE; if ($sincosopt() == 0){ T = GSL_INTEG_COSINE ;} qtab = gsl_integration_qawo_table_alloc($omega(),1.,T,(size_t) $nlevels()); current_fun++; if (current_fun >= (max_nested_integrals)) barf("Too many nested integrals, sorry!\n"); ext_funname[current_fun] = $COMP(function); F.function = &FUNC; F.params = 0; w = gsl_integration_workspace_alloc((size_t) $n()); cw = gsl_integration_workspace_alloc((size_t) $n()); $ierr() = gsl_integration_qawf(&F,$a(),$epsabs(),(size_t) $limit(),w,cw,qtab,$P(result),$P(abserr)); gsl_integration_workspace_free(w); gsl_integration_workspace_free(cw); gsl_integration_qawo_table_free(qtab); current_fun--; } '); pp_done(); PDL-2.018/Lib/GSL/INTEG/Makefile.PL0000644060175006010010000000336212562522364014362 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my $msg = undef; my $forcebuild=0; my $skip = 0; # this Makefile uses get_gsl_libs which is defined in # the parent Makefile.PL sub gsl_integ_links_ok { my($lib,$inc) = @_; return defined($lib) && defined($inc) && trylink('gsl numerical integration libraries', << 'EOI', #include #include #include #include double f (double x, void * params) { return pow (x, 1.5); } EOI << 'EOB', $lib, $inc); gsl_function F; double result, abserr; int ierr, neval; F.function = &f; F.params = 0; ierr = gsl_integration_qng(&F,1.0,2.0,0.0,1e-6,&result,&abserr,&neval); EOB } if (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==0) { $msg = "\n Will skip build of PDL::GSL::INTEG on this system \n"; $skip = 1; } elsif (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==1) { print "\n Will forcibly try and build PDL::GSL::INTEG on this system \n\n"; $forcebuild=1; } if (($skip && !$forcebuild) || !gsl_integ_links_ok($GSL_libs, $GSL_includes)) { warn "trying to force GSL build but link test failed\n". "\t -- aborting GSL build\n" if $forcebuild; $msg ||= "\n GSL Libraries not found... Skipping build of PDL::GSL::INTEG.\n"; write_dummy_make( $msg ); return; } else { print "\n Building PDL::GSL::INTEG.", "Turn off WITH_GSL if there are any problems\n\n"; } my @pack = (["gsl_integ.pd", qw(INTEG PDL::GSL::INTEG)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= " $GSL_includes"; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/INTERP/0000755060175006010010000000000013110402046012517 5ustar chmNonePDL-2.018/Lib/GSL/INTERP/gslerr.h0000644060175006010010000000036112562522364014206 0ustar chmNone static int status; static char buf[200]; /* Turn off GSL default handler. 10/18/2010 Jason Lin */ #define GSLERR(x,y) gsl_set_error_handler_off (); if ((status = x y)) {sprintf(buf,"Error in %s: %s",# x ,gsl_strerror(status));barf(buf);} PDL-2.018/Lib/GSL/INTERP/gsl_interp.pd0000644060175006010010000002455513101130663015230 0ustar chmNonepp_bless('PDL::GSL::INTERP'); # make the functions generated go into our namespace pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSL::INTERP - PDL interface to Interpolation routines in GSL =head1 DESCRIPTION This is an interface to the interpolation package present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::INTERP; my $x = sequence(10); my $y = exp($x); my $spl = PDL::GSL::INTERP->init('cspline',$x,$y); my $res = $spl->eval(4.35); $res = $spl->deriv(4.35); $res = $spl->deriv2(4.35); $res = $spl->integ(2.1,7.4); =head1 FUNCTIONS =head2 init() =for ref The init method initializes a new instance of INTERP. It needs as input an interpolation type and two piddles holding the x and y values to be interpolated. The GSL routines require that x be monotonically increasing and a quicksort is performed by default to ensure that. You can skip the quicksort by passing the option {Sort => 0}. The available interpolation types are : =over 2 =item linear =item polynomial =item cspline (natural cubic spline) =item cspline_periodic (periodic cubic spline) =item akima (natural akima spline) =item akima_periodic (periodic akima spline) =back Please check the GSL documentation for more information. =for usage Usage: $blessed_ref = PDL::GSL::INTERP->init($interp_method,$x,$y,$opt); =for example Example: $x = sequence(10); $y = exp($x); $spl = PDL::GSL::INTERP->init('cspline',$x,$y) $spl = PDL::GSL::INTERP->init('cspline',$x,$y,{Sort => 1}) #same as above # no sorting done on x, user is certain that x is monotonically increasing $spl = PDL::GSL::INTERP->init('cspline',$x,$y,{Sort => 0}); =head2 eval() =for ref The function eval returns the interpolating function at a given point. By default it will barf if you try to extrapolate, to comply silently if the point to be evaluated is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->eval($points,$opt); =for example Example: my $res = $spl->eval($x) $res = $spl->eval($x,{Extrapolate => 0}) #same as above # silently comply if $x is out of range $res = $spl->eval($x,{Extrapolate => 1}) =head2 deriv() =for ref The deriv function returns the derivative of the interpolating function at a given point. By default it will barf if you try to extrapolate, to comply silently if the point to be evaluated is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->deriv($points,$opt); =for example Example: my $res = $spl->deriv($x) $res = $spl->deriv($x,{Extrapolate => 0}) #same as above # silently comply if $x is out of range $res = $spl->deriv($x,{Extrapolate => 1}) =head2 deriv2() =for ref The deriv2 function returns the second derivative of the interpolating function at a given point. By default it will barf if you try to extrapolate, to comply silently if the point to be evaluated is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->deriv2($points,$opt); =for example Example: my $res = $spl->deriv2($x) $res = $spl->deriv2($x,{Extrapolate => 0}) #same as above # silently comply if $x is out of range $res = $spl->deriv2($x,{Extrapolate => 1}) =head2 integ() =for ref The integ function returns the integral of the interpolating function between two points. By default it will barf if you try to extrapolate, to comply silently if one of the integration limits is out of range pass the option {Extrapolate => 1} =for usage Usage: $result = $spl->integ($a,$b,$opt); =for example Example: my $res = $spl->integ($a,$b) $res = $spl->integ($a,$b,{Extrapolate => 0}) #same as above # silently comply if $a or $b are out of range $res = $spl->eval($a,$b,{Extrapolate => 1}) =head1 BUGS Feedback is welcome. =head1 SEE ALSO L The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2003 Andres Jordan All rights reserved. There is no warranty. You are allowed to redistribute this software/documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL interpolation module was written by Gerard Jungman. =cut EOD pp_addhdr(' #include #include #include #include #include "gslerr.h" typedef gsl_spline GslSpline; typedef gsl_interp_accel GslAccel; '); pp_addpm(' sub init{ my $opt; if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Sort => 1}; } my ($class,$type,$x,$y) = @_; if( (ref($x) ne \'PDL\') || (ref($y) ne \'PDL\') ){ barf("Have to pass piddles as arguments to init method\n"); } if($$opt{Sort} != 0){ my $idx = PDL::Ufunc::qsorti($x); $x = $x->index($idx); $y = $y->index($idx); } my $ene = nelem($x); my $obj1 = new_spline($type,$ene); my $obj2 = new_accel(); init_meat($x,$y,$$obj1); my @ret_a = ($obj1,$obj2); return bless(\@ret_a, $class); } '); pp_def('init_meat', Pars => 'double x(n); double y(n);', OtherPars => 'IV spl', Doc => undef, Code =>' GSLERR(gsl_spline_init,( INT2PTR(gsl_spline *, $COMP(spl)), $P(x),$P(y),$SIZE(n)));' ); pp_addpm(' sub eval{ my $opt; if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_meat($x,$$s_obj,$$a_obj); } else{ return eval_meat_ext($x,$$s_obj,$$a_obj); } } '); pp_def('eval_meat', Pars => 'double x(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, # BadCode added 5/31/2005, D. Hunt HandleBad => 1, BadCode => ' if ($ISBAD($x())) { $out() = $x(); } else { GSLERR(gsl_spline_eval_e,( INT2PTR(gsl_spline *, $COMP(spl)), $x(), INT2PTR(gsl_interp_accel *, $COMP(acc)), $P(out))); } ', Code =>' GSLERR(gsl_spline_eval_e,( INT2PTR(gsl_spline *, $COMP(spl)), $x(), INT2PTR(gsl_interp_accel *, $COMP(acc)), $P(out))); '); pp_def('eval_meat_ext', Pars => 'double x(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, Code =>' $out() = gsl_spline_eval( INT2PTR(gsl_spline *, $COMP(spl)), $x(), INT2PTR(gsl_interp_accel *, $COMP(acc))); '); pp_addpm(' sub deriv{ my $opt; if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_deriv_meat($x,$$s_obj,$$a_obj); } else{ return eval_deriv_meat_ext($x,$$s_obj,$$a_obj); } } '); pp_def('eval_deriv_meat', Pars => 'double x(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, Code =>' GSLERR(gsl_spline_eval_deriv_e,( INT2PTR(gsl_spline *, $COMP(spl)), $x(), INT2PTR(gsl_interp_accel *, $COMP(acc)), $P(out))); '); pp_def('eval_deriv_meat_ext', Pars => 'double x(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, Code =>' $out() = gsl_spline_eval_deriv( INT2PTR(gsl_spline *, $COMP(spl)), $x(), INT2PTR(gsl_interp_accel *, $COMP(acc))); '); pp_addpm(' sub deriv2{ my $opt; if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_deriv2_meat($x,$$s_obj,$$a_obj); } else{ return eval_deriv2_meat_ext($x,$$s_obj,$$a_obj); } } '); pp_def('eval_deriv2_meat', Pars => 'double x(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, Code =>' GSLERR(gsl_spline_eval_deriv2_e,( INT2PTR(gsl_spline *, $COMP(spl)), $x(), INT2PTR(gsl_interp_accel *, $COMP(acc)), $P(out))); '); pp_def('eval_deriv2_meat_ext', Pars => 'double x(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, Code =>' $out() = gsl_spline_eval_deriv2( INT2PTR(gsl_spline *, $COMP(spl)), $x(), INT2PTR(gsl_interp_accel *, $COMP(acc))); '); pp_addpm(' sub integ{ my $opt; if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Extrapolate => 0}; } my ($obj,$a,$b) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; if($$opt{Extrapolate} == 0){ return eval_integ_meat($a,$b,$$s_obj,$$a_obj); } else{ return eval_integ_meat_ext($a,$b,$$s_obj,$$a_obj); } } '); pp_def('eval_integ_meat', Pars => 'double a(); double b(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, Code =>' GSLERR(gsl_spline_eval_integ_e,( INT2PTR(gsl_spline *, $COMP(spl)), $a(), $b(), INT2PTR(gsl_interp_accel *, $COMP(acc)),$P(out))); '); pp_def('eval_integ_meat_ext', Pars => 'double a(); double b(); double [o] out();', OtherPars => 'IV spl;IV acc;', Doc => undef, Code =>' $out() = gsl_spline_eval_integ( INT2PTR(gsl_spline *, $COMP(spl)), $a(), $b(), INT2PTR(gsl_interp_accel *, $COMP(acc))); '); # XS functions for the INTERP objects pp_addxs('',' MODULE = PDL::GSL::INTERP PACKAGE = PDL::GSL::INTERP #define DEF_INTERP(X) if (!strcmp(TYPE,#X)) spline=gsl_spline_alloc( gsl_interp_ ## X , ene); strcat(ula,#X ", "); GslSpline * new_spline (TYPE,ene) char *TYPE int ene CODE: GslSpline * spline = NULL; char ula[100]; strcpy(ula,""); DEF_INTERP(linear); DEF_INTERP(polynomial); DEF_INTERP(cspline); DEF_INTERP(cspline_periodic); DEF_INTERP(akima); DEF_INTERP(akima_periodic); if (spline==NULL) { barf("Unknown interpolation type, please use one of the following: %s", ula); } else RETVAL = spline; OUTPUT: RETVAL GslAccel * new_accel () CODE: GslAccel * accel = NULL; accel = gsl_interp_accel_alloc(); if (accel == NULL){ barf("Problem allocating accelerator object\n"); } RETVAL = accel; OUTPUT: RETVAL MODULE = PDL::GSL::INTERP PACKAGE = GslSplinePtr PREFIX = spl_ void spl_DESTROY(spline) GslSpline * spline CODE: gsl_spline_free(spline); MODULE = PDL::GSL::INTERP PACKAGE = GslAccelPtr PREFIX = acc_ void acc_DESTROY(accel) GslAccel * accel CODE: gsl_interp_accel_free(accel); '); pp_export_nothing; pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/INTERP/Makefile.PL0000644060175006010010000000363212562522364014515 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my $msg = undef; my $forcebuild=0; my $skip = 0; # this Makefile uses get_gsl_libs which is defined in # the parent Makefile.PL sub gsl_interp_links_ok { my($lib,$inc) = @_; return defined($lib) && defined($inc) && trylink('gsl interp libraries', << 'EOI', #include #include #include EOI << 'EOB', $lib, $inc); int i; double xi, yi, x[10], y[10]; for (i = 0; i < 10; i++) { x[i] = i + 0.5 * sin (i); y[i] = i + cos (i * i); } { gsl_interp_accel *acc = gsl_interp_accel_alloc (); gsl_spline *spline = gsl_spline_alloc (gsl_interp_cspline, 10); gsl_spline_init (spline, x, y, 10); yi = gsl_spline_eval (spline, x[0] + 0.01, acc); gsl_spline_free (spline); gsl_interp_accel_free(acc); } EOB } if (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==0) { $msg = "\n Will skip build of PDL::GSL::INTERP on this system \n"; $skip = 1; } elsif (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==1) { print "\n Will forcibly try and build PDL::GSL::INTERP on this system \n\n"; $forcebuild=1; } if (($skip && !$forcebuild) || !gsl_interp_links_ok($GSL_libs, $GSL_includes)) { warn "trying to force GSL build but link test failed\n". "\t -- aborting GSL build\n" if $forcebuild; $msg ||= "\n GSL Libraries not found... Skipping build of PDL::GSL::INTERP.\n"; write_dummy_make( $msg ); return; } else { print "\n Building PDL::GSL::INTERP.", "Turn off WITH_GSL if there are any problems\n\n"; } my @pack = (["gsl_interp.pd", qw(INTERP PDL::GSL::INTERP)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= " $GSL_includes"; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/INTERP/typemap0000644060175006010010000000006112562522364014136 0ustar chmNoneTYPEMAP GslSpline * T_PTROBJ GslAccel * T_PTROBJ PDL-2.018/Lib/GSL/Makefile.PL0000644060175006010010000000434012562522364013511 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; sub get_gsl_config { my ($flags) = @_; no warnings 'exec'; `gsl-config $flags`; } # the real stuff happens in the subdirs # # DJB (12/30/03) # - would it not make sense to do all the checks here and just # write a dummy makefile if GSL support is not available # (as done with some of the other modules; or is it possible/desireable # to compile only some of the GSL modules here?) # sub get_gsl_libs { warn << 'EOW' if ref $PDL::Config{GSL_LIBS}; The GSL_LIBS config variable must be a string (!) not a reference. You should probably leave it undefined and rely on gsl-config. Build will likely fail. EOW my $lib = ($PDL::Config{GSL_LIBS} or get_gsl_config('--libs') or warn "\tno GSL link info (libgsl probably not available)\n"); my $inc = ($PDL::Config{GSL_INC} or get_gsl_config('--cflags') or warn "\tno GSL include info (libgsl probably not available)\n\n"); chomp $lib; chomp $inc; # print STDERR "Lib: $lib\nInc: $inc\n"; return ($inc,$lib); } # these will be used in the subdirs our ($GSL_includes, $GSL_libs) = get_gsl_libs(); # Version check my $MINVERSION = "1.3"; my $version = get_gsl_config('--version'); chomp $version if defined $version; my $new_enough = 0; if (!defined($version) or $version =~ /^\s*$/) { warn "\tno GSL version info found (gsl-config not installed?)\n\n"; $version = 'UNKNOWN VERSION'; } else { my @is_parts =split /\./,$version; my @needed_parts=split /\./,$MINVERSION; $needed_parts[-1]--; for (my $i=0; $i<=$#needed_parts; $i++) { my $is_part=(exists $is_parts[$i] ? $is_parts[$i] : 0); $new_enough=($is_part > $needed_parts[$i]); last if ($new_enough); } } undef &MY::postamble; # suppress warning *MY::postamble = sub {}; if (! $new_enough) { write_dummy_make("Not building GSL modules: GSL version $version found, but need at least $MINVERSION"); $PDL::Config{WITH_GSL} = 0; } elsif ( defined($PDL::Config{WITH_GSL}) and ! $PDL::Config{WITH_GSL} ) { write_dummy_make("Not building GSL modules: WITH_GSL=> 0"); } else { $PDL::Config{WITH_GSL} = 1; WriteMakefile( 'NAME' => 'PDL::GSL', (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); } PDL-2.018/Lib/GSL/MROOT/0000755060175006010010000000000013110402046012416 5ustar chmNonePDL-2.018/Lib/GSL/MROOT/FUNC.c0000644060175006010010000001117312562522364013340 0ustar chmNone// This file copyright (C) 2006 Andres Jordan // and Simon Casassus // All rights reserved. There is no warranty. You are allowed to // redistribute this software/documentation under certain conditions. // For details, see the file COPYING in the PDL distribution. If this file // is separated from the PDL distribution, the copyright notice should be // included in the file. #include #include #include #include static SV* ext_funname1; static int ene; void DFF(int* n, double* x, double* vector); int my_f (const gsl_vector * v, void * params, gsl_vector * df); void DFF(int* n, double* xval, double* vector){ //this version tries just to get the output SV* funname; double* xpass; int i; int count; I32 ax ; pdl* px; SV* pxsv; pdl* pvector; SV* pvectorsv; int ndims; PDL_Indx *pdims; dSP; ENTER; SAVETMPS; ndims = 1; pdims = (PDL_Indx *) PDL->smalloc((STRLEN) ((ndims) * sizeof(*pdims)) ); pdims[0] = (PDL_Indx) ene; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pxsv = POPs; PUTBACK; px = PDL->SvPDLV(pxsv); PDL->converttype( &px, PDL_D, PDL_PERM ); PDL->children_changesoon(px,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (px,pdims,ndims); px->state &= ~PDL_NOMYDIMS; px->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(px,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); px->data = (void *) xval; /* get function name on the perl side */ funname = ext_funname1; PUSHMARK(SP); XPUSHs(pxsv); PUTBACK; count=call_sv(funname,G_SCALAR); SPAGAIN; SP -= count ; ax = (SP - PL_stack_base) + 1 ; if (count!=1) croak("error calling perl function\n"); /* recover output value */ pvectorsv = ST(0); pvector = PDL->SvPDLV(pvectorsv); PDL->make_physical(pvector); xpass = (double *) pvector->data; for(i=0;ix, 0), gsl_vector_get (s->x, 1), gsl_vector_get (s->f, 0), gsl_vector_get (s->f, 1)); return 1; } int fsolver (double *xfree, int nelem, double epsabs, int method) { gsl_multiroot_fsolver_type *T; gsl_multiroot_fsolver *s; int status; size_t i, iter = 0; size_t n = nelem; double p[1] = { nelem }; int iloop; // struct func_params p = {1.0, 10.0}; gsl_multiroot_function func = {&my_f, n, p}; gsl_vector *x = gsl_vector_alloc (n); for (iloop=0;iloopf, epsabs); } while (status == GSL_CONTINUE && iter < 1000); if (status) warn ("Final status = %s\n", gsl_strerror (status)); for (iloop=0;iloopx, iloop); } gsl_multiroot_fsolver_free (s); gsl_vector_free (x); return 0; } PDL-2.018/Lib/GSL/MROOT/gsl_mroot.pd0000644060175006010010000000735213101130663014762 0ustar chmNonepp_bless('PDL::GSLMROOT'); pp_add_exported('','gslmroot_fsolver'); pp_addhdr(' #include #include "FUNC.c" '); pp_addpm(' sub gslmroot_fsolver{ my ($x, $f_vect) = @_; my $opt; if (ref($_[$#_]) eq \'HASH\'){ $opt = pop @_; } else{ $opt = {Method => 0, EpsAbs => 1e-3}; } if( (ref($x) ne \'PDL\')){ barf("Have to pass piddle as first argument to fsolver\n"); } my $res = $x->copy; fsolver_meat($res, $$opt{\'EpsAbs\'}, $$opt{\'Method\'}, $f_vect); return $res; } '); pp_def('fsolver_meat', Pars => 'double xfree(n); double epsabs(); int method();', OtherPars => 'SV* function1;', Docs => undef, Code =>' ext_funname1 = $COMP(function1); ene = $SIZE(n); fsolver($P(xfree), $SIZE(n), $epsabs(), $method()); '); pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSL::MROOT - PDL interface to multidimensional root-finding routines in GSL =head1 DESCRIPTION This is an interface to the multidimensional root-finding package present in the GNU Scientific Library. At the moment there is a single function B which provides an interface to the algorithms in the GSL library that do not use derivatives. =head1 SYNOPSIS use PDL; use PDL::GSL::MROOT; my $init = pdl (-10.00, -5.0); my $epsabs = 1e-7; $res = gslmroot_fsolver($init, \&rosenbrock, {Method => 0, EpsAbs => $epsabs}); sub rosenbrock{ my ($x) = @_; my $a = 1; my $b = 10; my $y = zeroes($x); my $y0 = $y->slice(0); $y0 .= $a * (1 - $x->slice(0)); my $y1 = $y->slice(1); $y1 .= $b * ($x->slice(1) - $x->slice(0)**2); return $y; } EOD pp_addpm({At=>Bot},<<'EOD'); # the rest of FUNCTIONS section =head2 gslmroot_fsolver Multidimensional root finder without using derivatives This function provides an interface to the multidimensional root finding algorithms in the GSL library. It takes a minimum of two argumennts: a piddle $init with an initial guess for the roots of the system and a reference to a function. The latter function must return a piddle whose i-th element is the i-th equation evaluated at the vector x (a piddle which is the sole input to this function). See the example in the Synopsis above for an illustration. The function returns a piddle with the roots for the system of equations. Two optional arguments can be specified as shown below. One is B, which can take the values 0,1,2,3. They correspond to the 'hybrids', 'hybrid', 'dnewton' and 'broyden' algorithms respectively (see GSL documentation for details). The other optional argument is B, which sets the absolute accuracy to which the roots of the system of equations are required. The default value for Method is 0 ('hybrids' algorithm) and the default for Epsabs is 1e-3. =for usage Usage: $res = gslmroot_fsolver($init, $function_ref, [{Method => $method, Epsabs => $epsabs}]); =for ref =head1 SEE ALSO L The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2006 Andres Jordan and Simon Casassus All rights reserved. There is no warranty. You are allowed to redistribute this software/documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/MROOT/Makefile.PL0000644060175006010010000000610412562522364014411 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my $msg = undef; my $forcebuild=0; my $skip = 0; # this Makefile uses get_gsl_libs which is defined in # the parent Makefile.PL sub gsl_mroot_links_ok { my($lib,$inc) = @_; return defined($lib) && defined($inc) && trylink('gsl multidimensional root finding libraries', << 'EOI', #include #include #include #include #include #include struct rparams{ double a; double b; }; int rosenbrock_f (const gsl_vector * x, void *params,gsl_vector * f){ double a = ((struct rparams *) params)->a; double b = ((struct rparams *) params)->b; const double x0 = gsl_vector_get (x, 0); const double x1 = gsl_vector_get (x, 1); const double y0 = a * (1 - x0); const double y1 = b * (x1 - x0 * x0); gsl_vector_set (f, 0, y0); gsl_vector_set (f, 1, y1); return GSL_SUCCESS; } EOI << 'EOB', $lib, $inc); const gsl_multiroot_fsolver_type *T; gsl_multiroot_fsolver *s; int status; size_t i, iter = 0; const size_t n = 2; struct rparams p = {1.0, 10.0}; gsl_multiroot_function f = {&rosenbrock_f, n, &p}; double x_init[2] = {-10.0, -5.0}; gsl_vector *x = gsl_vector_alloc (n); gsl_vector_set (x, 0, x_init[0]); gsl_vector_set (x, 1, x_init[1]); T = gsl_multiroot_fsolver_hybrids; s = gsl_multiroot_fsolver_alloc (T, 2); gsl_multiroot_fsolver_set (s, &f, x); do { iter++; status = gsl_multiroot_fsolver_iterate (s); if (status) break; status = gsl_multiroot_test_residual (s->f, 1e-7); } while (status == GSL_CONTINUE && iter < 1000); gsl_multiroot_fsolver_free (s); gsl_vector_free (x); return 0; EOB } if (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==0) { $msg = "\n Will skip build of PDL::GSL::MROOT on this system \n"; $skip = 1; } elsif (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==1) { print "\n Will forcibly try and build PDL::GSL::MROOT on this system \n\n"; $forcebuild=1; } if (($skip && !$forcebuild) || !gsl_mroot_links_ok($GSL_libs, $GSL_includes)) { warn "trying to force GSL build but link test failed\n". "\t -- aborting GSL build\n" if $forcebuild; $msg ||= "\n GSL Libraries not found... Skipping build of PDL::GSL::MROOT.\n"; write_dummy_make( $msg ); return; } else { print "\n Building PDL::GSL::MROOT.", "Turn off WITH_GSL if there are any problems\n\n"; } my @pack = (["gsl_mroot.pd", qw(MROOT PDL::GSL::MROOT)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= " $GSL_includes"; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/RNG/0000755060175006010010000000000013110402045012143 5ustar chmNonePDL-2.018/Lib/GSL/RNG/gsl_random.pd0000644060175006010010000011335313101130663014627 0ustar chmNone pp_bless('PDL::GSL::RNG'); # make the functions generated go into our namespace, and # not PDL's namespace pp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSL::RNG - PDL interface to RNG and randist routines in GSL =head1 DESCRIPTION This is an interface to the rng and randist packages present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::RNG; $rng = PDL::GSL::RNG->new('taus'); $rng->set_seed(time()); $a=zeroes(5,5,5) $rng->get_uniform($a); # inplace $b=$rng->get_uniform(3,4,5); # creates new pdl =head1 FUNCTIONS =head2 new =for ref The new method initializes a new instance of the RNG. The available RNGs are: coveyou cmrg fishman18 fishman20 fishman2x gfsr4 knuthran knuthran2 knuthran2002 lecuyer21 minstd mrg mt19937 mt19937_1999 mt19937_1998 r250 ran0 ran1 ran2 ran3 rand rand48 random128_bsd random128_glibc2 random128_libc5 random256_bsd random256_glibc2 random256_libc5 random32_bsd random32_glibc2 random32_libc5 random64_bsd random64_glibc2 random64_libc5 random8_bsd random8_glibc2 random8_libc5 random_bsd random_glibc2 random_libc5 randu ranf ranlux ranlux389 ranlxd1 ranlxd2 ranlxs0 ranlxs1 ranlxs2 ranmar slatec taus taus2 taus113 transputer tt800 uni uni32 vax waterman14 zuf default The last one (default) uses the environment variable GSL_RNG_TYPE. Note that only a few of these rngs are recommended for general use. Please check the GSL documentation for more information. =for usage Usage: $blessed_ref = PDL::GSL::RNG->new($RNG_name); Example: =for example $rng = PDL::GSL::RNG->new('taus'); =head2 set_seed =for ref Sets the RNG seed. Usage: =for usage $rng->set_seed($integer); # or $rng = PDL::GSL::RNG->new('taus')->set_seed($integer); Example: =for example $rng->set_seed(666); =head2 min =for ref Return the minimum value generable by this RNG. Usage: =for usage $integer = $rng->min(); Example: =for example $min = $rng->min(); $max = $rng->max(); =head2 max =for ref Return the maximum value generable by the RNG. Usage: =for usage $integer = $rng->max(); Example: =for example $min = $rng->min(); $max = $rng->max(); =head2 name =for ref Returns the name of the RNG. Usage: =for usage $string = $rng->name(); Example: =for example $name = $rng->name(); =head2 get =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get() returns integer values between a minimum and a maximum specific to every RNG. Usage: =for usage $piddle = $rng->get($list_of_integers) $rng->get($piddle); Example: =for example $a = zeroes 5,6; $o = $rng->get(10,10); $rng->get($a); =head2 get_int =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get_int() returns integer values between 0 and $max. Usage: =for usage $piddle = $rng->get($max, $list_of_integers) $rng->get($max, $piddle); Example: =for example $a = zeroes 5,6; $max=100; $o = $rng->get(10,10); $rng->get($a); =head2 get_uniform =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get_uniform() returns values 0<=x<1, Usage: =for usage $piddle = $rng->get_uniform($list_of_integers) $rng->get_uniform($piddle); Example: =for example $a = zeroes 5,6; $max=100; $o = $rng->get_uniform(10,10); $rng->get_uniform($a); =head2 get_uniform_pos =for ref This function creates a piddle with given dimensions or accept an existing piddle and fills it. get_uniform_pos() returns values 0get_uniform_pos($list_of_integers) $rng->get_uniform_pos($piddle); Example: =for example $a = zeroes 5,6; $o = $rng->get_uniform_pos(10,10); $rng->get_uniform_pos($a); =head2 ran_shuffle =for ref Shuffles values in piddle Usage: =for usage $rng->ran_shuffle($piddle); =head2 ran_shuffle_vec =for ref Shuffles values in piddle Usage: =for usage $rng->ran_shuffle_vec(@vec); =head2 ran_choose =for ref Chooses values from C<$inpiddle> to C<$outpiddle>. Usage: =for usage $rng->ran_choose($inpiddle,$outpiddle); =head2 ran_choose_vec =for ref Chooses C<$n> values from C<@vec>. Usage: =for usage @chosen = $rng->ran_choose_vec($n,@vec); =head2 ran_gaussian =for ref Fills output piddle with random values from Gaussian distribution with mean zero and standard deviation C<$sigma>. Usage: =for usage $piddle = $rng->ran_gaussian($sigma,[list of integers = output piddle dims]); $rng->ran_gaussian($sigma, $output_piddle); Example: =for example $o = $rng->ran_gaussian($sigma,10,10); $rng->ran_gaussian($sigma,$a); =head2 ran_gaussian_var =for ref This method is similar to L except that it takes the parameters of the distribution as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gaussian_var($sigma_piddle); $rng->ran_gaussian_var($sigma_piddle, $output_piddle); Example: =for example $sigma_pdl = rvals zeroes 11,11; $o = $rng->ran_gaussian_var($sigma_pdl); =head2 ran_additive_gaussian =for ref Add Gaussian noise of given sigma to a piddle. Usage: =for usage $rng->ran_additive_gaussian($sigma,$piddle); Example: =for example $rng->ran_additive_gaussian(1,$image); =head2 ran_bivariate_gaussian =for ref Generates C<$n> bivariate gaussian random deviates. Usage: =for usage $piddle = $rng->ran_bivariate_gaussian($sigma_x,$sigma_y,$rho,$n); Example: =for example $o = $rng->ran_bivariate_gaussian(1,2,0.5,1000); =head2 ran_poisson =for ref Fills output piddle by with random integer values from the Poisson distribution with mean C<$mu>. Usage: =for usage $piddle = $rng->ran_poisson($mu,[list of integers = output piddle dims]); $rng->ran_poisson($mu,$output_piddle); =head2 ran_poisson_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_poisson_var($mu_piddle); =head2 ran_additive_poisson =for ref Add Poisson noise of given C<$mu> to a C<$piddle>. Usage: =for usage $rng->ran_additive_poisson($mu,$piddle); Example: =for example $rng->ran_additive_poisson(1,$image); =head2 ran_feed_poisson =for ref This method simulates shot noise, taking the values of piddle as values for C<$mu> to be fed in the poissonian RNG. Usage: =for usage $rng->ran_feed_poisson($piddle); Example: =for example $rng->ran_feed_poisson($image); =head2 ran_bernoulli =for ref Fills output piddle with random values 0 or 1, the result of a Bernoulli trial with probability C<$p>. Usage: =for usage $piddle = $rng->ran_bernoulli($p,[list of integers = output piddle dims]); $rng->ran_bernoulli($p,$output_piddle); =head2 ran_bernoulli_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_bernoulli_var($p_piddle); =head2 ran_beta =for ref Fills output piddle with random variates from the beta distribution with parameters C<$a> and C<$b>. Usage: =for usage $piddle = $rng->ran_beta($a,$b,[list of integers = output piddle dims]); $rng->ran_beta($a,$b,$output_piddle); =head2 ran_beta_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_beta_var($a_piddle, $b_piddle); =head2 ran_binomial =for ref Fills output piddle with random integer values from the binomial distribution, the number of successes in C<$n> independent trials with probability C<$p>. Usage: =for usage $piddle = $rng->ran_binomial($p,$n,[list of integers = output piddle dims]); $rng->ran_binomial($p,$n,$output_piddle); =head2 ran_binomial_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_binomial_var($p_piddle, $n_piddle); =head2 ran_cauchy =for ref Fills output piddle with random variates from the Cauchy distribution with scale parameter C<$a>. Usage: =for usage $piddle = $rng->ran_cauchy($a,[list of integers = output piddle dims]); $rng->ran_cauchy($a,$output_piddle); =head2 ran_cauchy_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_cauchy_var($a_piddle); =head2 ran_chisq =for ref Fills output piddle with random variates from the chi-squared distribution with C<$nu> degrees of freedom. Usage: =for usage $piddle = $rng->ran_chisq($nu,[list of integers = output piddle dims]); $rng->ran_chisq($nu,$output_piddle); =head2 ran_chisq_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_chisq_var($nu_piddle); =head2 ran_exponential =for ref Fills output piddle with random variates from the exponential distribution with mean C<$mu>. Usage: =for usage $piddle = $rng->ran_exponential($mu,[list of integers = output piddle dims]); $rng->ran_exponential($mu,$output_piddle); =head2 ran_exponential_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_exponential_var($mu_piddle); =head2 ran_exppow =for ref Fills output piddle with random variates from the exponential power distribution with scale parameter C<$a> and exponent C<$b>. Usage: =for usage $piddle = $rng->ran_exppow($mu,$a,[list of integers = output piddle dims]); $rng->ran_exppow($mu,$a,$output_piddle); =head2 ran_exppow_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_exppow_var($mu_piddle, $a_piddle); =head2 ran_fdist =for ref Fills output piddle with random variates from the F-distribution with degrees of freedom C<$nu1> and C<$nu2>. Usage: =for usage $piddle = $rng->ran_fdist($nu1, $nu2,[list of integers = output piddle dims]); $rng->ran_fdist($nu1, $nu2,$output_piddle); =head2 ran_fdist_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_fdist_var($nu1_piddle, $nu2_piddle); =head2 ran_flat =for ref Fills output piddle with random variates from the flat (uniform) distribution from C<$a> to C<$b>. Usage: =for usage $piddle = $rng->ran_flat($a,$b,[list of integers = output piddle dims]); $rng->ran_flat($a,$b,$output_piddle); =head2 ran_flat_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_flat_var($a_piddle, $b_piddle); =head2 ran_gamma =for ref Fills output piddle with random variates from the gamma distribution. Usage: =for usage $piddle = $rng->ran_gamma($a,$b,[list of integers = output piddle dims]); $rng->ran_gamma($a,$b,$output_piddle); =head2 ran_gamma_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gamma_var($a_piddle, $b_piddle); =head2 ran_geometric =for ref Fills output piddle with random integer values from the geometric distribution, the number of independent trials with probability C<$p> until the first success. Usage: =for usage $piddle = $rng->ran_geometric($p,[list of integers = output piddle dims]); $rng->ran_geometric($p,$output_piddle); =head2 ran_geometric_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_geometric_var($p_piddle); =head2 ran_gumbel1 =for ref Fills output piddle with random variates from the Type-1 Gumbel distribution. Usage: =for usage $piddle = $rng->ran_gumbel1($a,$b,[list of integers = output piddle dims]); $rng->ran_gumbel1($a,$b,$output_piddle); =head2 ran_gumbel1_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gumbel1_var($a_piddle, $b_piddle); =head2 ran_gumbel2 =for ref Fills output piddle with random variates from the Type-2 Gumbel distribution. Usage: =for usage $piddle = $rng->ran_gumbel2($a,$b,[list of integers = output piddle dims]); $rng->ran_gumbel2($a,$b,$output_piddle); =head2 ran_gumbel2_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_gumbel2_var($a_piddle, $b_piddle); =head2 ran_hypergeometric =for ref Fills output piddle with random integer values from the hypergeometric distribution. If a population contains C<$n1> elements of type 1 and C<$n2> elements of type 2 then the hypergeometric distribution gives the probability of obtaining C<$x> elements of type 1 in C<$t> samples from the population without replacement. Usage: =for usage $piddle = $rng->ran_hypergeometric($n1, $n2, $t,[list of integers = output piddle dims]); $rng->ran_hypergeometric($n1, $n2, $t,$output_piddle); =head2 ran_hypergeometric_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_hypergeometric_var($n1_piddle, $n2_piddle, $t_piddle); =head2 ran_laplace =for ref Fills output piddle with random variates from the Laplace distribution with width C<$a>. Usage: =for usage $piddle = $rng->ran_laplace($a,[list of integers = output piddle dims]); $rng->ran_laplace($a,$output_piddle); =head2 ran_laplace_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_laplace_var($a_piddle); =head2 ran_levy =for ref Fills output piddle with random variates from the Levy symmetric stable distribution with scale C<$c> and exponent C<$alpha>. Usage: =for usage $piddle = $rng->ran_levy($mu,$a,[list of integers = output piddle dims]); $rng->ran_levy($mu,$a,$output_piddle); =head2 ran_levy_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_levy_var($mu_piddle, $a_piddle); =head2 ran_logarithmic =for ref Fills output piddle with random integer values from the logarithmic distribution. Usage: =for usage $piddle = $rng->ran_logarithmic($p,[list of integers = output piddle dims]); $rng->ran_logarithmic($p,$output_piddle); =head2 ran_logarithmic_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_logarithmic_var($p_piddle); =head2 ran_logistic =for ref Fills output piddle with random random variates from the logistic distribution. Usage: =for usage $piddle = $rng->ran_logistic($m,[list of integers = output piddle dims]u) $rng->ran_logistic($m,$output_piddle) =head2 ran_logistic_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_logistic_var($m_piddle); =head2 ran_lognormal =for ref Fills output piddle with random variates from the lognormal distribution with parameters C<$mu> (location) and C<$sigma> (scale). Usage: =for usage $piddle = $rng->ran_lognormal($mu,$sigma,[list of integers = output piddle dims]); $rng->ran_lognormal($mu,$sigma,$output_piddle); =head2 ran_lognormal_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_lognormal_var($mu_piddle, $sigma_piddle); =head2 ran_negative_binomial =for ref Fills output piddle with random integer values from the negative binomial distribution, the number of failures occurring before C<$n> successes in independent trials with probability C<$p> of success. Note that C<$n> is not required to be an integer. Usage: =for usage $piddle = $rng->ran_negative_binomial($p,$n,[list of integers = output piddle dims]); $rng->ran_negative_binomial($p,$n,$output_piddle); =head2 ran_negative_binomial_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_negative_binomial_var($p_piddle, $n_piddle); =head2 ran_pareto =for ref Fills output piddle with random variates from the Pareto distribution of order C<$a> and scale C<$b>. Usage: =for usage $piddle = $rng->ran_pareto($a,$b,[list of integers = output piddle dims]); $rng->ran_pareto($a,$b,$output_piddle); =head2 ran_pareto_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_pareto_var($a_piddle, $b_piddle); =head2 ran_pascal =for ref Fills output piddle with random integer values from the Pascal distribution. The Pascal distribution is simply a negative binomial distribution (see L) with an integer value of C<$n>. Usage: =for usage $piddle = $rng->ran_pascal($p,$n,[list of integers = output piddle dims]); $rng->ran_pascal($p,$n,$output_piddle); =head2 ran_pascal_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_pascal_var($p_piddle, $n_piddle); =head2 ran_rayleigh =for ref Fills output piddle with random variates from the Rayleigh distribution with scale parameter C<$sigma>. Usage: =for usage $piddle = $rng->ran_rayleigh($sigma,[list of integers = output piddle dims]); $rng->ran_rayleigh($sigma,$output_piddle); =head2 ran_rayleigh_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_rayleigh_var($sigma_piddle); =head2 ran_rayleigh_tail =for ref Fills output piddle with random variates from the tail of the Rayleigh distribution with scale parameter C<$sigma> and a lower limit of C<$a>. Usage: =for usage $piddle = $rng->ran_rayleigh_tail($a,$sigma,[list of integers = output piddle dims]); $rng->ran_rayleigh_tail($a,$sigma,$output_piddle); =head2 ran_rayleigh_tail_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_rayleigh_tail_var($a_piddle, $sigma_piddle); =head2 ran_tdist =for ref Fills output piddle with random variates from the t-distribution (AKA Student's t-distribution) with C<$nu> degrees of freedom. Usage: =for usage $piddle = $rng->ran_tdist($nu,[list of integers = output piddle dims]); $rng->ran_tdist($nu,$output_piddle); =head2 ran_tdist_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_tdist_var($nu_piddle); =head2 ran_ugaussian_tail =for ref Fills output piddle with random variates from the upper tail of a Gaussian distribution with C (AKA unit Gaussian distribution). Usage: =for usage $piddle = $rng->ran_ugaussian_tail($tail,[list of integers = output piddle dims]); $rng->ran_ugaussian_tail($tail,$output_piddle); =head2 ran_ugaussian_tail_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_ugaussian_tail_var($tail_piddle); =head2 ran_weibull =for ref Fills output piddle with random variates from the Weibull distribution. Usage: =for usage $piddle = $rng->ran_weibull($mu,$a,[list of integers = output piddle dims]); $rng->ran_weibull($mu,$a,$output_piddle); =head2 ran_weibull_var =for ref Similar to L except that it takes the distribution parameters as a piddle and returns a piddle of equal dimensions. Usage: =for usage $piddle = $rng->ran_weibull_var($mu_piddle, $a_piddle); =head2 ran_dir =for ref Returns C<$n> random vectors in C<$ndim> dimensions. Usage: =for usage $piddle = $rng->ran_dir($ndim,$n); Example: =for example $o = $rng->ran_dir($ndim,$n); =head2 ran_discrete_preproc =for ref This method returns a handle that must be used when calling L. You specify the probability of the integer number that are returned by L. Usage: =for usage $discrete_dist_handle = $rng->ran_discrete_preproc($double_piddle_prob); Example: =for example $prob = pdl [0.1,0.3,0.6]; $ddh = $rng->ran_discrete_preproc($prob); $o = $rng->ran_discrete($discrete_dist_handle,100); =head2 ran_discrete =for ref Is used to get the desired samples once a proper handle has been enstablished (see ran_discrete_preproc()). Usage: =for usage $piddle = $rng->ran_discrete($discrete_dist_handle,$num); Example: =for example $prob = pdl [0.1,0.3,0.6]; $ddh = $rng->ran_discrete_preproc($prob); $o = $rng->ran_discrete($discrete_dist_handle,100); =head2 ran_ver =for ref Returns a piddle with C<$n> values generated by the Verhulst map from C<$x0> and parameter C<$r>. Usage: =for usage $rng->ran_ver($x0, $r, $n); =head2 ran_caos =for ref Returns values from Verhuls map with C<$r=4.0> and randomly chosen C<$x0>. The values are scaled by C<$m>. Usage: =for usage $rng->ran_caos($m,$n); =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L). =head1 SEE ALSO L The GSL documentation is online at L =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin Docs mangled by C. Soeller. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL RNG and randist modules were written by James Theiler. =cut EOD # PP interface to RNG ############################## # # make_get_sub generates a wrapper PDL subroutine that handles the # fill-a-PDL and create-a-PDL cases for each of the GSL functions. # --CED # sub make_get_sub { my ($fname,$par) =@_; my $s; $s = ' sub ' . $fname . ' { my ($obj,' . $par . '@var) = @_;'; if ($par ne '') { my $ss=$par; $ss =~ s/,//; $s .= 'if (!(' . $ss . '>0)) {barf("first parameter must be an int >0")};'; } $s .= 'if (ref($var[0]) eq \'PDL\') { gsl_' . $fname . '_meat($var[0],' . $par . '$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_' . $fname . '_meat($p,' . $par . '$$obj); return $p; } } ' } pp_addpm(<<'EOPM'); use strict; # PDL::GSL::RNG::nullcreate just creates a null PDL. Used # for the GSL functions that create PDLs sub nullcreate{ my ($type,$arg) = @_; PDL->nullcreate($arg); } EOPM pp_addpm(make_get_sub('get_uniform','')); pp_addpm(make_get_sub('get_uniform_pos','')); pp_addpm(make_get_sub('get','')); pp_addpm(make_get_sub('get_int','$n,')); pp_addhdr(' #include #include "gsl/gsl_rng.h" #include "gsl/gsl_randist.h" '); sub pp_defnd { # hide the docs my ($name, %hash) = @_; pp_def($name,%hash,Doc=>undef); } pp_defnd( 'gsl_get_uniform_meat', Pars => '[o]a()', GenericTypes => [F,D], OtherPars => 'IV rng', Code => ' $a() = gsl_rng_uniform(INT2PTR(gsl_rng *, $COMP(rng)));'); pp_defnd( 'gsl_get_uniform_pos_meat', Pars => '[o]a()', GenericTypes => [F,D], OtherPars => 'IV rng', Code => ' $a() = gsl_rng_uniform_pos(INT2PTR(gsl_rng *, $COMP(rng)));'); pp_defnd( 'gsl_get_meat', Pars => '[o]a()', OtherPars => 'IV rng', Code => ' $a() = gsl_rng_get(INT2PTR(gsl_rng *, $COMP(rng)));'); pp_defnd( 'gsl_get_int_meat', Pars => '[o]a()', OtherPars => 'int n; IV rng', Code => ' $a() = gsl_rng_uniform_int(INT2PTR(gsl_rng *, $COMP(rng)),$COMP(n));'); # randist stuff sub add_randist { my ($name,$npar) = @_; my ($pars1,$fcall1,$arglist); if ($npar==1) { $pars1='double a; IV rng'; $fcall1='$COMP(a)'; $arglist='$a,'; $pars2='a()'; $fcall2='$a()'; } if ($npar==2) { $pars1='double a; double b; IV rng'; $fcall1='$COMP(a),$COMP(b)'; $arglist='$a,$b,'; $pars2='a();b()'; $fcall2='$a(),$b()'; } if ($npar==3) { $pars1='double a; double b; double c; IV rng'; $fcall1='$COMP(a),$COMP(b),$COMP(c)'; $arglist='$a,$b,$c,'; $pars2='a();b();c()'; $fcall2='$a(),$b(),$c()'; } pp_defnd( 'ran_' . $name . '_meat', Pars => '[o]x()', OtherPars => $pars1, Code =>' $x() = gsl_ran_' . $name . '(INT2PTR(gsl_rng *, $COMP(rng)),' . $fcall1 . ');'); pp_addpm(' sub ran_' . $name . ' { my ($obj,' . $arglist . '@var) = @_; if (ref($var[0]) eq \'PDL\') { ran_' . $name . '_meat($var[0],' . $arglist . '$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_' . $name . '_meat($p,' . $arglist . '$$obj); return $p; } } '); pp_defnd( 'ran_' . $name . '_var_meat', Pars => $pars2 . ';[o]x()', OtherPars => 'IV rng', Code =>' $x() = gsl_ran_' . $name . '(INT2PTR(gsl_rng *, $COMP(rng)),' . $fcall2 . ');'); pp_addpm(' sub ran_' . $name . '_var { my ($obj,@var) = @_; if (scalar(@var) != ' . $npar . ') {barf("Bad number of parameters!");} return ran_' . $name . '_var_meat(@var,$$obj); } '); # pp_defnd( # 'ran_' . $name . '_add_meat', # Pars => '[o]x()', # OtherPars => $pars1, # Code =>' #$x() += gsl_ran_' . $name . '(INT2PTR(gsl_rng *, $COMP(rng)),' . $fcall1 . ');'); # pp_addpm(' #sub ran_' . $name . '_add { #my ($obj,' . $arglist . '@var) = @_; #if (ref($var[0]) eq \'PDL\') { # PDL::ran_' . $name . '_add_meat($var[0],' . $arglist . '$$obj); # return $var[0]; #} #else { # barf("In add mode you must specify a piddle!"); #} #} #'); # if ($npar==1) { # pp_defnd( # 'ran_' . $name . '_feed_meat', # Pars => '[o]x()', # OtherPars => 'IV rng', # Code =>' #$x() = gsl_ran_' . $name . '(INT2PTR(gsl_rng *, $COMP(rng)), $x());'); # pp_addpm(' #sub ran_' . $name . '_feed { #my ($obj, @var) = @_; #if (ref($var[0]) eq \'PDL\') { # PDL::ran_' . $name . '_feed_meat($var[0], $$obj); # return $var[0]; #} #else { # barf("In feed mode you must specify a piddle!"); #} #} #'); # } } add_randist('gaussian',1); add_randist('ugaussian_tail',1); add_randist('exponential',1); add_randist('laplace',1); add_randist('exppow',2); add_randist('cauchy',1); add_randist('rayleigh',1); add_randist('rayleigh_tail',2); add_randist('levy',2); add_randist('gamma',2); add_randist('flat',2); add_randist('lognormal',2); add_randist('chisq',1); add_randist('fdist',2); add_randist('tdist',1); add_randist('beta',2); add_randist('logistic',1); add_randist('pareto',2); add_randist('weibull',2); add_randist('gumbel1',2); add_randist('gumbel2',2); add_randist('poisson',1); add_randist('bernoulli',1); add_randist('binomial',2); add_randist('negative_binomial',2); add_randist('pascal',2); add_randist('geometric',1); add_randist('hypergeometric',3); add_randist('logarithmic',1); # specific rnadist pp_defnd( 'ran_additive_gaussian_meat', Pars => ';[o]x()', OtherPars => 'double sigma; IV rng', Code =>'$x() += gsl_ran_gaussian(INT2PTR(gsl_rng *, $COMP(rng)), $COMP(sigma));'); pp_addpm(' sub ran_additive_gaussian { my ($obj,$sigma,@var) = @_; if (ref($var[0]) eq \'PDL\') { ran_additive_gaussian_meat($var[0],$sigma,$$obj); return $var[0]; } else { barf("In additive gaussian mode you must specify a piddle!"); } } '); pp_defnd( 'ran_additive_poisson_meat', Pars => ';[o]x()', OtherPars => 'double sigma; IV rng', Code =>'$x() += gsl_ran_poisson(INT2PTR(gsl_rng *, $COMP(rng)), $COMP(sigma));'); pp_addpm(' sub ran_additive_poisson { my ($obj,$sigma,@var) = @_; if (ref($var[0]) eq \'PDL\') { ran_additive_poisson_meat($var[0],$sigma,$$obj); return $var[0]; } else { barf("In additive poisson mode you must specify a piddle!"); } } '); pp_defnd( 'ran_feed_poisson_meat', Pars => ';[o]x()', OtherPars => 'IV rng', Code =>'$x() = gsl_ran_poisson(INT2PTR(gsl_rng *, $COMP(rng)), $x());'); pp_addpm(' sub ran_feed_poisson { my ($obj,@var) = @_; if (ref($var[0]) eq \'PDL\') { ran_feed_poisson_meat($var[0],$$obj); return $var[0]; } else { barf("In poisson mode you must specify a piddle!"); } } '); pp_defnd( 'ran_bivariate_gaussian_meat', Pars => ';[o]x(n)', OtherPars => 'double sigma_x; double sigma_y; double rho; IV rng', Code =>' double xx,yy; gsl_ran_bivariate_gaussian(INT2PTR(gsl_rng *, $COMP(rng)), $COMP(sigma_x), $COMP(sigma_y),$COMP(rho), &xx, &yy); $x(n=>0)=xx; $x(n=>1)=yy; '); pp_addpm(' sub ran_bivariate_gaussian { my ($obj,$sigma_x,$sigma_y,$rho,$n) = @_; if ($n>0) { my $p = zeroes(2,$n); ran_bivariate_gaussian_meat($p,$sigma_x,$sigma_y,$rho,$$obj); return $p; } else { barf("Not enough parameters for gaussian bivariate!"); } } '); pp_defnd( 'ran_dir_2d_meat', Pars => ';[o]x(n)', OtherPars => 'IV rng', Code =>' double xx,yy; gsl_ran_dir_2d(INT2PTR(gsl_rng *, $COMP(rng)), &xx, &yy); $x(n=>0)=xx; $x(n=>1)=yy; '); pp_defnd( 'ran_dir_3d_meat', Pars => ';[o]x(n)', OtherPars => 'IV rng', Code =>' double xx,yy,zz; gsl_ran_dir_3d(INT2PTR(gsl_rng *, $COMP(rng)), &xx, &yy, &zz); $x(n=>0)=xx; $x(n=>1)=yy; $x(n=>2)=zz; '); $MAX_DIMENSIONS = 100; pp_defnd( 'ran_dir_nd_meat', Pars => ';[o]x(n)', OtherPars => 'int ns => n; IV rng', Code =>' double xxx[' . $MAX_DIMENSIONS .']; gsl_ran_dir_nd(INT2PTR(gsl_rng *, $COMP(rng)), $COMP(ns), xxx); loop (n) %{ $x() = xxx[n]; %}'); pp_addpm(' sub ran_dir { my ($obj,$ndim,$n) = @_; if ($n>0) { my $p = zeroes($ndim,$n); if ($ndim==2) { ran_dir_2d_meat($p,$$obj); } elsif ($ndim==3) { ran_dir_3d_meat($p,$$obj); } elsif ($ndim>=4 && $ndim<=' . $MAX_DIMENSIONS . ') { ran_dir_nd_meat($p,$ndim,$$obj); } else { barf("Bad number of dimensions!"); } return $p; } else { barf("Not enough parameters for random vectors!"); } } '); pp_defnd( 'ran_discrete_meat', Pars => ';[o]x()', OtherPars => 'IV rng_discrete; IV rng', Code =>' $x()=gsl_ran_discrete(INT2PTR(gsl_rng *, $COMP(rng)), INT2PTR(gsl_ran_discrete_t *, $COMP(rng_discrete))); '); pp_addpm(' sub ran_discrete { my ($obj, $rdt, @var) = @_; if (ref($var[0]) eq \'PDL\') { ran_discrete_meat($var[0], $$rdt, $$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_discrete_meat($p, $$rdt, $$obj); return $p; } } '); pp_addpm(' sub ran_shuffle_vec { my ($obj,@in) = @_; my (@out,$i,$p); $p = long [0..$#in]; $obj->ran_shuffle($p); for($i=0;$iat($i)]=$in[$i]; } return @out; } '); pp_addpm(' sub ran_choose_vec { my ($obj,$nout,@in) = @_; my (@out,$i,$pin,$pout); $pin = long [0..$#in]; $pout = long [0..($nout-1)]; $obj->ran_choose($pin,$pout); for($i=0;$i<$nout;$i++) { $out[$i]=$in[$pout->at($i)]; } return @out; } '); pp_defnd( 'ran_ver_meat', Pars => ';[o]x(n)', OtherPars => 'double x0; double r;int ns => n; IV rng', Code =>' double xx=$COMP(x0); loop (n) %{ $x() = xx; xx = $COMP(r)*(1-xx)*xx; %}'); pp_defnd( 'ran_caos_meat', Pars => ';[o]x(n)', OtherPars => 'double m; int ns => n; IV rng', Code =>' double xx=gsl_ran_gaussian(INT2PTR(gsl_rng *, $COMP(rng)),0.1)+0.5; loop (n) %{ $x() = (xx-0.5)*$COMP(m); xx = 4.0*(1-xx)*xx; %}'); pp_addpm(' sub ran_ver { my ($obj,$x0,$r,$n) = @_; if ($n>0) { my $p = zeroes($n); ran_ver_meat($p,$x0,$r,$n,$$obj); return $p; } else { barf("Not enough parameters for ran_ver!"); } } '); pp_addpm(' sub ran_caos { my ($obj,$m,$n) = @_; if ($n>0) { my $p = zeroes($n); ran_caos_meat($p,$m,$n,$$obj); return $p; } else { barf("Not enough parameters for ran_caos!"); } } '); # XS function for the RNG object pp_addxs('',' MODULE = PDL::GSL::RNG PACKAGE = PDL::GSL::RNG #define DEF_RNG(X) if (!strcmp(TYPE,#X)) rng=gsl_rng_alloc( gsl_rng_ ## X ); strcat(rngs,#X ", "); gsl_rng * new (CLASS,TYPE) char *CLASS char *TYPE CODE: gsl_rng * rng = NULL; char rngs[5000]; strcpy(rngs,""); DEF_RNG(borosh13) DEF_RNG(coveyou) DEF_RNG(cmrg) DEF_RNG(fishman18) DEF_RNG(fishman20) DEF_RNG(fishman2x) DEF_RNG(gfsr4) DEF_RNG(knuthran) DEF_RNG(knuthran2) DEF_RNG(knuthran2002) DEF_RNG(lecuyer21) DEF_RNG(minstd) DEF_RNG(mrg) DEF_RNG(mt19937) DEF_RNG(mt19937_1999) DEF_RNG(mt19937_1998) DEF_RNG(r250) DEF_RNG(ran0) DEF_RNG(ran1) DEF_RNG(ran2) DEF_RNG(ran3) DEF_RNG(rand) DEF_RNG(rand48) DEF_RNG(random128_bsd) DEF_RNG(random128_glibc2) DEF_RNG(random128_libc5) DEF_RNG(random256_bsd) DEF_RNG(random256_glibc2) DEF_RNG(random256_libc5) DEF_RNG(random32_bsd) DEF_RNG(random32_glibc2) DEF_RNG(random32_libc5) DEF_RNG(random64_bsd) DEF_RNG(random64_glibc2) DEF_RNG(random64_libc5) DEF_RNG(random8_bsd) DEF_RNG(random8_glibc2) DEF_RNG(random8_libc5) DEF_RNG(random_bsd) DEF_RNG(random_glibc2) DEF_RNG(random_libc5) DEF_RNG(randu) DEF_RNG(ranf) DEF_RNG(ranlux) DEF_RNG(ranlux389) DEF_RNG(ranlxd1) DEF_RNG(ranlxd2) DEF_RNG(ranlxs0) DEF_RNG(ranlxs1) DEF_RNG(ranlxs2) DEF_RNG(ranmar) DEF_RNG(slatec) DEF_RNG(taus) DEF_RNG(taus2) DEF_RNG(taus113) DEF_RNG(transputer) DEF_RNG(tt800) DEF_RNG(uni) DEF_RNG(uni32) DEF_RNG(vax) DEF_RNG(waterman14) DEF_RNG(zuf) DEF_RNG(default) if (rng==NULL) { barf("Unknown RNG, plese use one of the following: %s", rngs); } else RETVAL = rng; OUTPUT: RETVAL void set_seed(rng, seed) gsl_rng * rng int seed PPCODE: gsl_rng_set(rng,seed); XPUSHs(ST(0)); /* return self */ unsigned int min(rng) gsl_rng * rng CODE: RETVAL = gsl_rng_min(rng); OUTPUT: RETVAL unsigned int max(rng) gsl_rng * rng CODE: RETVAL = gsl_rng_max(rng); OUTPUT: RETVAL char* name(rng) gsl_rng * rng CODE: RETVAL = (char *) gsl_rng_name(rng); OUTPUT: RETVAL void DESTROY(sv) SV * sv CODE: gsl_rng *rng = INT2PTR(gsl_rng *, SvIV((SV*)SvRV(sv))); /* fprintf(stderr,"Freeing %d\n",rng); */ gsl_rng_free((gsl_rng *) rng); gsl_ran_discrete_t * ran_discrete_preproc(rng, p) gsl_rng * rng pdl * p CODE: int n; if (p->ndims!=1 || p->datatype!=PDL_D) { barf("Bad input to ran_discrete_preproc!"); } n = p->dims[0]; PDL->make_physical(p); RETVAL = gsl_ran_discrete_preproc(n,(double *) p->data); OUTPUT: RETVAL void ran_shuffle(rng, in) gsl_rng * rng pdl * in CODE: int size, n; n = in->nvals; PDL->make_physical(in); switch(in->datatype) { case PDL_INVALID: barf("ran_shuffle was passed a piddle of type PDL_INVALID"); break; case PDL_B: size=sizeof(PDL_Byte); break; case PDL_S: size=sizeof(PDL_Short); break; case PDL_US: size=sizeof(PDL_Ushort); break; case PDL_L: size=sizeof(PDL_Long); break; case PDL_IND: size=sizeof(PDL_Indx); break; case PDL_LL: size=sizeof(PDL_LongLong); break; case PDL_F: size=sizeof(PDL_Float); break; case PDL_D: size=sizeof(PDL_Double); break; } gsl_ran_shuffle(rng,(double *) in->data,n,size); void ran_choose(rng, in, out) gsl_rng * rng pdl * in pdl * out CODE: int size, n,m; n = in->nvals; m = out->nvals; if (in->datatype != out->datatype) barf("Data Types must match for ran_chooser"); PDL->make_physical(in); PDL->make_physical(out); switch(in->datatype) { case PDL_INVALID: barf("ran_choose was passed a piddle of type PDL_INVALID"); break; case PDL_B: size=sizeof(PDL_Byte); break; case PDL_S: size=sizeof(PDL_Short); break; case PDL_US: size=sizeof(PDL_Ushort); break; case PDL_L: size=sizeof(PDL_Long); break; case PDL_IND: size=sizeof(PDL_Indx); break; case PDL_LL: size=sizeof(PDL_LongLong); break; case PDL_F: size=sizeof(PDL_Float); break; case PDL_D: size=sizeof(PDL_Double); break; } gsl_ran_choose(rng,(double *) out->data, m, (double *) in->data,n,size); '); pp_core_importList(' qw/ zeroes long barf /'); # import just a named list to our namespace, so we don't get warning # messages like 'warning 'min' redefined at line ...' pp_export_nothing; # set to not export anything. (This is a OO package, it doesn't need to export any methods.) pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/RNG/Makefile.PL0000644060175006010010000000313012562522364014133 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my $msg = undef; my $forcebuild=0; my $skip = 0; # this Makefile uses get_gsl_libs which is defined in # the parent Makefile.PL sub gsl_rng_links_ok { my($lib,$inc) = @_; return defined($lib) && defined($inc) && trylink('gsl rng libraries', << 'EOI', #include #include EOI << 'EOB', $lib, $inc); const gsl_rng_type * T; gsl_rng * r; double mu = 3.0; T = gsl_rng_default; r = gsl_rng_alloc (T); { unsigned int k = gsl_ran_poisson (r, mu); } EOB } if (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==0) { $msg = "\n Will skip build of PDL::GSL::RNG on this system \n"; $skip = 1; } elsif (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==1) { print "\n Will forcibly try and build PDL::GSL::RNG on this system \n\n"; $forcebuild=1; } if (($skip && !$forcebuild) || !gsl_rng_links_ok($GSL_libs, $GSL_includes)) { warn "trying to force GSL build but link test failed\n". "\t -- aborting GSL build\n" if $forcebuild; $msg ||= "\n GSL Libraries not found... Skipping build of PDL::GSL::RNG.\n"; write_dummy_make( $msg ); return; } else { print "\n Building PDL::GSL::RNG.", "Turn off WITH_GSL if there are any problems\n\n"; } my @pack = (["gsl_random.pd", qw(RNG PDL::GSL::RNG)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= " $GSL_includes"; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/RNG/README0000644060175006010010000000050212562522364013041 0ustar chmNonePDL interface to GSL 1.X rng and randist functions. by Christian Pellegrin , Copyleft, 1999 see COPYING in the root of the PDL build tree. This is an interface to the random number generator part of the GNU Scientific Library. The documentation is in the .pd file and is automaticaly generated. PDL-2.018/Lib/GSL/RNG/typemap0000644060175006010010000000026212562522364013566 0ustar chmNoneTYPEMAP gsl_rng * ANY_OBJ gsl_ran_discrete_t * T_PTROBJ OUTPUT ANY_OBJ sv_setref_pv($arg, CLASS, (void *) $var); INPUT ANY_OBJ $var = INT2PTR($type, SvIV((SV*)SvRV($arg))) PDL-2.018/Lib/GSL/SF/0000755060175006010010000000000013110402046012026 5ustar chmNonePDL-2.018/Lib/GSL/SF/airy/0000755060175006010010000000000013110402045012771 5ustar chmNonePDL-2.018/Lib/GSL/SF/airy/gsl_sf_airy.pd0000644060175006010010000000660013101130663015625 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::AIRY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_airy_Ai', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Ai_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Airy Function Ai(x).' ); pp_def('gsl_sf_airy_Bi', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Bi_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Airy Function Bi(x).' ); pp_def('gsl_sf_airy_Ai_scaled', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Ai_scaled_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled Airy Function Ai(x). Ai(x) for x < 0 and exp(+2/3 x^{3/2}) Ai(x) for x > 0.' ); pp_def('gsl_sf_airy_Bi_scaled', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Bi_scaled_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled Airy Function Bi(x). Bi(x) for x < 0 and exp(+2/3 x^{3/2}) Bi(x) for x > 0.' ); pp_def('gsl_sf_airy_Ai_deriv', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Ai_deriv_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Derivative Airy Function Ai`(x).' ); pp_def('gsl_sf_airy_Bi_deriv', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Bi_deriv_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Derivative Airy Function Bi`(x).' ); pp_def('gsl_sf_airy_Ai_deriv_scaled', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Ai_deriv_scaled_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Derivative Scaled Airy Function Ai(x). Ai`(x) for x < 0 and exp(+2/3 x^{3/2}) Ai`(x) for x > 0.' ); pp_def('gsl_sf_airy_Bi_deriv_scaled', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_airy_Bi_deriv_scaled_e,($x(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Derivative Scaled Airy Function Bi(x). Bi`(x) for x < 0 and exp(+2/3 x^{3/2}) Bi`(x) for x > 0.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/airy/Makefile.PL0000644060175006010010000000055412562522364014770 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_airy.pd', qw(AIRY PDL::GSLSF::AIRY)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/bessel/0000755060175006010010000000000013110402046013303 5ustar chmNonePDL-2.018/Lib/GSL/SF/bessel/gsl_sf_bessel.pd0000644060175006010010000002330613101130663016451 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::BESSEL - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_bessel_Jn', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Jn_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regular Bessel Function J_n(x).' ); pp_def('gsl_sf_bessel_J_array', GenericTypes => [D], OtherPars =>'int s; int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_Jn_array,($COMP(s),$COMP(s)+$COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Regular Bessel Functions J_{s}(x) to J_{s+n-1}(x).' ); pp_def('gsl_sf_bessel_Yn', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Yn_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'IrRegular Bessel Function Y_n(x).' ); pp_def('gsl_sf_bessel_Y_array', GenericTypes => [D], OtherPars =>'int s; int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_Yn_array,($COMP(s),$COMP(s)+$COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Regular Bessel Functions Y_{s}(x) to Y_{s+n-1}(x).' ); pp_def('gsl_sf_bessel_In', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_In_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regular Modified Bessel Function I_n(x).' ); pp_def('gsl_sf_bessel_I_array', GenericTypes => [D], OtherPars =>'int s; int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_In_array,($COMP(s),$COMP(s)+$COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Regular Modified Bessel Functions I_{s}(x) to I_{s+n-1}(x).' ); pp_def('gsl_sf_bessel_In_scaled', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_In_scaled_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled Regular Modified Bessel Function exp(-|x|) I_n(x).' ); pp_def('gsl_sf_bessel_I_scaled_array', GenericTypes => [D], OtherPars =>'int s; int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_In_scaled_array,($COMP(s),$COMP(s)+$COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Scaled Regular Modified Bessel Functions exp(-|x|) I_{s}(x) to exp(-|x|) I_{s+n-1}(x).' ); pp_def('gsl_sf_bessel_Kn', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Kn_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'IrRegular Modified Bessel Function K_n(x).' ); pp_def('gsl_sf_bessel_K_array', GenericTypes => [D], OtherPars =>'int s; int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_Kn_array,($COMP(s),$COMP(s)+$COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of IrRegular Modified Bessel Functions K_{s}(x) to K_{s+n-1}(x).' ); pp_def('gsl_sf_bessel_Kn_scaled', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Kn_scaled_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled IrRegular Modified Bessel Function exp(-|x|) K_n(x).' ); pp_def('gsl_sf_bessel_K_scaled_array', GenericTypes => [D], OtherPars =>'int s; int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_Kn_scaled_array,($COMP(s),$COMP(s)+$COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Scaled IrRegular Modified Bessel Functions exp(-|x|) K_{s}(x) to exp(-|x|) K_{s+n-1}(x).' ); pp_def('gsl_sf_bessel_jl', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_jl_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regular Sphericl Bessel Function J_n(x).' ); pp_def('gsl_sf_bessel_j_array', GenericTypes => [D], OtherPars =>'int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_jl_array,($COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Spherical Regular Bessel Functions J_{0}(x) to J_{n-1}(x).' ); pp_def('gsl_sf_bessel_yl', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_yl_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'IrRegular Spherical Bessel Function y_n(x).' ); pp_def('gsl_sf_bessel_y_array', GenericTypes => [D], OtherPars =>'int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_yl_array,($COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Regular Spherical Bessel Functions y_{0}(x) to y_{n-1}(x).' ); pp_def('gsl_sf_bessel_il_scaled', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_il_scaled_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled Regular Modified Spherical Bessel Function exp(-|x|) i_n(x).' ); pp_def('gsl_sf_bessel_i_scaled_array', GenericTypes => [D], OtherPars =>'int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_il_scaled_array,($COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Scaled Regular Modified Spherical Bessel Functions exp(-|x|) i_{0}(x) to exp(-|x|) i_{n-1}(x).' ); pp_def('gsl_sf_bessel_kl_scaled', GenericTypes => [D], OtherPars =>'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_kl_scaled_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled IrRegular Modified Spherical Bessel Function exp(-|x|) k_n(x).' ); pp_def('gsl_sf_bessel_k_scaled_array', GenericTypes => [D], OtherPars =>'int n=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_bessel_kl_scaled_array,($COMP(n)-1,$x(),$P(y))) ', Doc =>'Array of Scaled IrRegular Modified Spherical Bessel Functions exp(-|x|) k_{s}(x) to exp(-|x|) k_{s+n-1}(x).' ); pp_def('gsl_sf_bessel_Jnu', GenericTypes => [D], OtherPars =>'double n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Jnu_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regular Cylindrical Bessel Function J_nu(x).' ); pp_def('gsl_sf_bessel_Ynu', GenericTypes => [D], OtherPars =>'double n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Ynu_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'IrRegular Cylindrical Bessel Function J_nu(x).' ); pp_def('gsl_sf_bessel_Inu_scaled', GenericTypes => [D], OtherPars =>'double n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Inu_scaled_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled Modified Cylindrical Bessel Function exp(-|x|) I_nu(x).' ); pp_def('gsl_sf_bessel_Inu', GenericTypes => [D], OtherPars =>'double n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Inu_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Modified Cylindrical Bessel Function I_nu(x).' ); pp_def('gsl_sf_bessel_Knu_scaled', GenericTypes => [D], OtherPars =>'double n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Knu_scaled_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Scaled Modified Cylindrical Bessel Function exp(-|x|) K_nu(x).' ); pp_def('gsl_sf_bessel_Knu', GenericTypes => [D], OtherPars =>'double n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_Knu_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Modified Cylindrical Bessel Function K_nu(x).' ); pp_def('gsl_sf_bessel_lnKnu', GenericTypes => [D], OtherPars =>'double n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_bessel_lnKnu_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Logarithm of Modified Cylindrical Bessel Function K_nu(x).' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/bessel/Makefile.PL0000644060175006010010000000056112562522364015277 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_bessel.pd',qw(BESSEL PDL::GSLSF::BESSEL)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/clausen/0000755060175006010010000000000013110402045013457 5ustar chmNonePDL-2.018/Lib/GSL/SF/clausen/gsl_sf_clausen.pd0000644060175006010010000000222513101130663017000 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::CLAUSEN - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_clausen', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_clausen_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Clausen Integral. Cl_2(x) := Integrate[-Log[2 Sin[t/2]], {t,0,x}]' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/clausen/Makefile.PL0000644060175006010010000000056512562522364015460 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_clausen.pd', qw(CLAUSEN PDL::GSLSF::CLAUSEN)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/coulomb/0000755060175006010010000000000013110402045013465 5ustar chmNonePDL-2.018/Lib/GSL/SF/coulomb/gsl_sf_coulomb.pd0000644060175006010010000000601113101130663017011 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::COULOMB - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include #include "../gslerr.h" '); pp_def('gsl_sf_hydrogenicR', GenericTypes => [D], OtherPars =>'int n; int l; double z', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hydrogenicR_e,($COMP(n),$COMP(l),$COMP(z),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Normalized Hydrogenic bound states. Radial dipendence.' ); pp_def('gsl_sf_coulomb_wave_FGp_array', GenericTypes => [D], OtherPars =>'double lam_min; int kmax=>n; double eta', Pars=>'double x(); double [o]fc(n); double [o]fcp(n); double [o]gc(n); double [o]gcp(n); int [o]ovfw(); double [o]fe(n); double [o]ge(n);', Code =>' int s; s = gsl_sf_coulomb_wave_FGp_array($COMP(lam_min),$COMP(kmax),$COMP(eta),$x(),$PP(fc),$PP(fcp),$PP(gc),$PP(gcp),$PP(fe),$PP(ge)); if (s==GSL_EOVRFLW) { $ovfw()=1; } else {if (s) {sprintf(buf,"Error in gsl_sf_coulomb_wave_FGp_array: %s",gsl_strerror(s));barf("%s", buf);} else {$ovfw()=0;}} ', Doc =>' Coulomb wave functions F_{lam_F}(eta,x), G_{lam_G}(eta,x) and their derivatives; lam_G := lam_F - k_lam_G. if ovfw is signaled then F_L(eta,x) = fc[k_L] * exp(fe) and similar. ' ); pp_def('gsl_sf_coulomb_wave_sphF_array', GenericTypes => [D], OtherPars =>'double lam_min; int kmax=>n; double eta', Pars=>'double x(); double [o]fc(n); int [o]ovfw(); double [o]fe(n);', Code =>' int s; s = gsl_sf_coulomb_wave_sphF_array($COMP(lam_min),$COMP(kmax),$COMP(eta),$x(),$PP(fc),$PP(fe)); if (s==GSL_EOVRFLW) { $ovfw()=1; } else {if (s) {sprintf(buf,"Error in gsl_sf_coulomb_wave_sphF_array: %s",gsl_strerror(s));barf("%s", buf);} else {$ovfw()=0;}} ', Doc =>' Coulomb wave function divided by the argument, F(xi, eta)/xi. This is the function which reduces to spherical Bessel functions in the limit eta->0. ' ); pp_def('gsl_sf_coulomb_CL_e', GenericTypes => [D], Pars=>'double L(); double eta(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_coulomb_CL_e,($L(),$eta(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Coulomb wave function normalization constant. [Abramowitz+Stegun 14.1.8, 14.1.9].' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/coulomb/Makefile.PL0000644060175006010010000000056512562522364015466 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_coulomb.pd', qw(COULOMB PDL::GSLSF::COULOMB)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/coupling/0000755060175006010010000000000013110402046013646 5ustar chmNonePDL-2.018/Lib/GSL/SF/coupling/gsl_sf_coupling.pd0000644060175006010010000000362713101130663017363 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::COUPLING - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_coupling_3j', GenericTypes => [L], Pars=>'ja(); jb(); jc(); ma(); mb(); mc(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_coupling_3j_e,($ja(),$jb(),$jc(),$ma(),$mb(),$mc(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'3j Symbols: (ja jb jc) over (ma mb mc).' ); pp_def('gsl_sf_coupling_6j', GenericTypes => [L], Pars=>'ja(); jb(); jc(); jd(); je(); jf(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_coupling_6j_e,($ja(),$jb(),$jc(),$jd(),$je(),$jf(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'6j Symbols: (ja jb jc) over (jd je jf).' ); pp_def('gsl_sf_coupling_9j', GenericTypes => [L], Pars=>'ja(); jb(); jc(); jd(); je(); jf(); jg(); jh(); ji(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_coupling_9j_e,($ja(),$jb(),$jc(),$jd(),$je(),$jf(),$jg(),$jh(),$ji(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'9j Symbols: (ja jb jc) over (jd je jf) over (jg jh ji).' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/coupling/Makefile.PL0000644060175006010010000000057012562522364015642 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_coupling.pd', qw(COUPLING PDL::GSLSF::COUPLING)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/dawson/0000755060175006010010000000000013110402045013320 5ustar chmNonePDL-2.018/Lib/GSL/SF/dawson/gsl_sf_dawson.pd0000644060175006010010000000221113101130663016475 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::DAWSON - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_dawson', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_dawson_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Dawsons integral: Exp[-x^2] Integral[ Exp[t^2], {t,0,x}]' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/dawson/Makefile.PL0000644060175006010010000000056212562522364015316 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_dawson.pd', qw(DAWSON PDL::GSLSF::DAWSON)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/debye/0000755060175006010010000000000013110402046013116 5ustar chmNonePDL-2.018/Lib/GSL/SF/debye/gsl_sf_debye.pd0000644060175006010010000000373213101130663016100 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::DEBYE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_debye_1', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_debye_1_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}]' ); pp_def('gsl_sf_debye_2', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_debye_2_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}]' ); pp_def('gsl_sf_debye_3', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_debye_3_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}]' ); pp_def('gsl_sf_debye_4', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_debye_4_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}]' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/debye/Makefile.PL0000644060175006010010000000055712562522364015117 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_debye.pd', qw(DEBYE PDL::GSLSF::DEBYE)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/dilog/0000755060175006010010000000000013110402045013123 5ustar chmNonePDL-2.018/Lib/GSL/SF/dilog/gsl_sf_dilog.pd0000644060175006010010000000320013101130663016102 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::DILOG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_dilog', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_dilog_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'/* Real part of DiLogarithm(x), for real argument. In Lewins notation, this is Li_2(x). Li_2(x) = - Re[ Integrate[ Log[1-s] / s, {s, 0, x}] ]' ); pp_def('gsl_sf_complex_dilog', GenericTypes => [D], Pars=>'double r(); double t(); double [o]re(); double [o]im(); double [o]ere(); double [o]eim()', Code =>' gsl_sf_result re; gsl_sf_result im; GSLERR(gsl_sf_complex_dilog_e,($r(),$t(),&re,&im)) $re() = re.val; $ere() = re.err; $im() = im.val; $eim() = im.err; ', Doc =>'DiLogarithm(z), for complex argument z = r Exp[i theta].' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/dilog/Makefile.PL0000644060175006010010000000055712562522364015125 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_dilog.pd', qw(DILOG PDL::GSLSF::DILOG)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/elementary/0000755060175006010010000000000013110402046014173 5ustar chmNonePDL-2.018/Lib/GSL/SF/elementary/gsl_sf_elementary.pd0000644060175006010010000000272313101130663020231 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::ELEMENTARY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_multiply', GenericTypes => [D], Pars=>'double x(); double xx(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_multiply_e,($x(),$xx(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Multiplication.' ); pp_def('gsl_sf_multiply_err', GenericTypes => [D], Pars=>'double x(); double xe(); double xx(); double xxe(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_multiply_err_e,($x(),$xe(),$xx(),$xxe(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Multiplication with associated errors.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/elementary/Makefile.PL0000644060175006010010000000057612562522364016175 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_elementary.pd', qw(ELEMENTARY PDL::GSLSF::ELEMENTARY)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/ellint/0000755060175006010010000000000013110402045013314 5ustar chmNonePDL-2.018/Lib/GSL/SF/ellint/gsl_sf_ellint.pd0000644060175006010010000001211113101130663016465 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::ELLINT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_ellint_Kcomp', GenericTypes => [D], Pars=>'double k(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_Kcomp_e,($k(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Legendre form of complete elliptic integrals K(k) = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}].' ); pp_def('gsl_sf_ellint_Ecomp', GenericTypes => [D], Pars=>'double k(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_Ecomp_e,($k(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Legendre form of complete elliptic integrals E(k) = Integral[ Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}]' ); pp_def('gsl_sf_ellint_F', GenericTypes => [D], Pars=>'double phi(); double k(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_F_e,($phi(),$k(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Legendre form of incomplete elliptic integrals F(phi,k) = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}]' ); pp_def('gsl_sf_ellint_E', GenericTypes => [D], Pars=>'double phi(); double k(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_E_e,($phi(),$k(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Legendre form of incomplete elliptic integrals E(phi,k) = Integral[ Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}]' ); pp_def('gsl_sf_ellint_P', GenericTypes => [D], Pars=>'double phi(); double k(); double n(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_P_e,($phi(),$k(),$n(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Legendre form of incomplete elliptic integrals P(phi,k,n) = Integral[(1 + n Sin[t]^2)^(-1)/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}]' ); my $v = `gsl-config --version`; if($v < 2.0) { pp_def('gsl_sf_ellint_D', GenericTypes => [D], Pars=>'double phi(); double k(); double n(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_D_e,($phi(),$k(),$n(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Legendre form of incomplete elliptic integrals D(phi,k,n)' ); } else { pp_def('gsl_sf_ellint_D', GenericTypes => [D], Pars=>'double phi(); double k(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_D_e,($phi(),$k(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Legendre form of incomplete elliptic integrals D(phi,k)' ); } pp_def('gsl_sf_ellint_RC', GenericTypes => [D], Pars=>'double x(); double yy(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_RC_e,($x(),$yy(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Carlsons symmetric basis of functions RC(x,y) = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1)], {t,0,Inf}' ); pp_def('gsl_sf_ellint_RD', GenericTypes => [D], Pars=>'double x(); double yy(); double z(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_RD_e,($x(),$yy(),$z(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Carlsons symmetric basis of functions RD(x,y,z) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-3/2), {t,0,Inf}]' ); pp_def('gsl_sf_ellint_RF', GenericTypes => [D], Pars=>'double x(); double yy(); double z(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_RF_e,($x(),$yy(),$z(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Carlsons symmetric basis of functions RF(x,y,z) = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2), {t,0,Inf}]' ); pp_def('gsl_sf_ellint_RJ', GenericTypes => [D], Pars=>'double x(); double yy(); double z(); double p(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_ellint_RJ_e,($x(),$yy(),$z(),$p(),GSL_PREC_DOUBLE,&r)) $y() = r.val; $e() = r.err; ', Doc =>'Carlsons symmetric basis of functions RJ(x,y,z,p) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2) (t+p)^(-1), {t,0,Inf}]' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin , 2002 Christian Soeller. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/ellint/Makefile.PL0000644060175006010010000000056212562522364015312 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_ellint.pd', qw(ELLINT PDL::GSLSF::ELLINT)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/elljac/0000755060175006010010000000000013110402046013260 5ustar chmNonePDL-2.018/Lib/GSL/SF/elljac/gsl_sf_elljac.pd0000644060175006010010000000230513101130663016377 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::ELLJAC - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_elljac', GenericTypes => [D], Pars=>'double u(); double m(); double [o]sn(); double [o]cn(); double [o]dn()', Code =>' if (gsl_sf_elljac_e($u(),$m(),$PP(sn),$PP(cn),$PP(dn))) {barf("Error in gsl_sf_elljac");}; ', Doc =>'Jacobian elliptic functions sn, dn, cn by descending Landen transformations' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/elljac/Makefile.PL0000644060175006010010000000056212562522364015255 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_elljac.pd', qw(ELLJAC PDL::GSLSF::ELLJAC)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/erf/0000755060175006010010000000000013110402046012602 5ustar chmNonePDL-2.018/Lib/GSL/SF/erf/gsl_sf_erf.pd0000644060175006010010000000434513101130663015251 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::ERF - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_erfc', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_erfc_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Complementary Error Function erfc(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,x,Infinity}]' ); pp_def('gsl_sf_log_erfc', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_log_erfc_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Log Complementary Error Function' ); pp_def('gsl_sf_erf', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_erf_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Error Function erf(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,0,x}]' ); pp_def('gsl_sf_erf_Z', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_erf_Z_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Z(x) : Abramowitz+Stegun 26.2.1' ); pp_def('gsl_sf_erf_Q', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_erf_Q_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Q(x) : Abramowitz+Stegun 26.2.1' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/erf/Makefile.PL0000644060175006010010000000055112562522364014575 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_erf.pd', qw(ERF PDL::GSLSF::ERF)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/exp/0000755060175006010010000000000013110402045012621 5ustar chmNonePDL-2.018/Lib/GSL/SF/exp/gsl_sf_exp.pd0000644060175006010010000000342713101130663015311 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::EXP - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_exp', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_exp_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Exponential' ); pp_def('gsl_sf_exprel_n', GenericTypes => [D], OtherPars => 'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_exprel_n_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'N-relative Exponential. exprel_N(x) = N!/x^N (exp(x) - Sum[x^k/k!, {k,0,N-1}]) = 1 + x/(N+1) + x^2/((N+1)(N+2)) + ... = 1F1(1,1+N,x)' ); pp_def('gsl_sf_exp_err', GenericTypes => [D], Pars=>'double x(); double dx(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_exp_err_e,($x(),$dx(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Exponential of a quantity with given error.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/exp/Makefile.PL0000644060175006010010000000055112562522364014615 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_exp.pd', qw(EXP PDL::GSLSF::EXP)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/expint/0000755060175006010010000000000013110402046013335 5ustar chmNonePDL-2.018/Lib/GSL/SF/expint/gsl_sf_expint.pd0000644060175006010010000000652413101130663016540 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::EXPINT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_expint_E1', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_expint_E1_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'E_1(x) := Re[ Integrate[ Exp[-xt]/t, {t,1,Infinity}] ]' ); pp_def('gsl_sf_expint_E2', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_expint_E2_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'E_2(x) := Re[ Integrate[ Exp[-xt]/t^2, {t,1,Infity}] ]' ); pp_def('gsl_sf_expint_Ei', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_expint_Ei_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Ei(x) := PV Integrate[ Exp[-t]/t, {t,-x,Infinity}]' ); pp_def('gsl_sf_Shi', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_Shi_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Shi(x) := Integrate[ Sinh[t]/t, {t,0,x}]' ); pp_def('gsl_sf_Chi', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_Chi_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Chi(x) := Re[ M_EULER + log(x) + Integrate[(Cosh[t]-1)/t, {t,0,x}] ]' ); pp_def('gsl_sf_expint_3', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_expint_3_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Ei_3(x) := Integral[ Exp[-t^3], {t,0,x}]' ); pp_def('gsl_sf_Si', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_Si_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Si(x) := Integrate[ Sin[t]/t, {t,0,x}]' ); pp_def('gsl_sf_Ci', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_Ci_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Ci(x) := -Integrate[ Cos[t]/t, {t,x,Infinity}]' ); pp_def('gsl_sf_atanint', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_atanint_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'AtanInt(x) := Integral[ Arctan[t]/t, {t,0,x}]' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/expint/Makefile.PL0000644060175006010010000000056212562522364015332 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_expint.pd', qw(EXPINT PDL::GSLSF::EXPINT)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/fermi_dirac/0000755060175006010010000000000013110402046014272 5ustar chmNonePDL-2.018/Lib/GSL/SF/fermi_dirac/gsl_sf_fermi_dirac.pd0000644060175006010010000000511513101130663020425 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::FERMI_DIRAC - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Please note that: Complete Fermi-Dirac Integrals: F_j(x) := 1/Gamma[j+1] Integral[ t^j /(Exp[t-x] + 1), {t,0,Infinity}] Incomplete Fermi-Dirac Integrals: F_j(x,b) := 1/Gamma[j+1] Integral[ t^j /(Exp[t-x] + 1), {t,b,Infinity}] =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_fermi_dirac_int', GenericTypes => [D], OtherPars => 'int j', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_fermi_dirac_int_e,($COMP(j),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Complete integral F_j(x) for integer j' ); pp_def('gsl_sf_fermi_dirac_mhalf', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_fermi_dirac_mhalf_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Complete integral F_{-1/2}(x)' ); pp_def('gsl_sf_fermi_dirac_half', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_fermi_dirac_half_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Complete integral F_{1/2}(x)' ); pp_def('gsl_sf_fermi_dirac_3half', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_fermi_dirac_3half_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Complete integral F_{3/2}(x)' ); pp_def('gsl_sf_fermi_dirac_inc_0', GenericTypes => [D], OtherPars => 'double b', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_fermi_dirac_inc_0_e,($x(),$COMP(b),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Incomplete integral F_0(x,b) = ln(1 + e^(b-x)) - (b-x)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/fermi_dirac/Makefile.PL0000644060175006010010000000060112562522364016261 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_fermi_dirac.pd', qw(FERMI_DIRAC PDL::GSLSF::FERMI_DIRAC)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/gamma/0000755060175006010010000000000013110402044013106 5ustar chmNonePDL-2.018/Lib/GSL/SF/gamma/gsl_sf_gamma.pd0000644060175006010010000001543013101130663016062 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::GAMMA - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_lngamma', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]s(); double [o]e()', Code =>' gsl_sf_result r; double sgn; GSLERR(gsl_sf_lngamma_sgn_e,($x(),&r,&sgn)) $y() = r.val; $e() = r.err; $s() = sgn; ', Doc =>'Log[Gamma(x)], x not a negative integer Uses real Lanczos method. Determines the sign of Gamma[x] as well as Log[|Gamma[x]|] for x < 0. So Gamma[x] = sgn * Exp[result_lg].' ); pp_def('gsl_sf_gamma', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_gamma_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Gamma(x), x not a negative integer' ); pp_def('gsl_sf_gammastar', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_gammastar_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regulated Gamma Function, x > 0 Gamma^*(x) = Gamma(x)/(Sqrt[2Pi] x^(x-1/2) exp(-x)) = (1 + 1/(12x) + ...), x->Inf' ); pp_def('gsl_sf_gammainv', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_gammainv_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'1/Gamma(x)' ); pp_def('gsl_sf_lngamma_complex', GenericTypes => [D], Pars=>'double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()', Code =>' gsl_sf_result r; gsl_sf_result ri; GSLERR(gsl_sf_lngamma_complex_e,($zr(),$zi(),&r,&ri)) $x() = r.val; $xe() = r.err; $y() = ri.val; $ye() = ri.err; ', Doc =>'Log[Gamma(z)] for z complex, z not a negative integer. Calculates: lnr = log|Gamma(z)|, arg = arg(Gamma(z)) in (-Pi, Pi]' ); pp_def('gsl_sf_taylorcoeff', GenericTypes => [D], OtherPars => 'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_taylorcoeff_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'x^n / n!' ); pp_def('gsl_sf_fact', GenericTypes => [L], Pars=>'x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_fact_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'n!' ); pp_def('gsl_sf_doublefact', GenericTypes => [L], Pars=>'x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_doublefact_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'n!! = n(n-2)(n-4)' ); pp_def('gsl_sf_lnfact', GenericTypes => [L], Pars=>'x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_lnfact_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'ln n!' ); pp_def('gsl_sf_lndoublefact', GenericTypes => [L], Pars=>'x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_lndoublefact_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'ln n!!' ); pp_def('gsl_sf_lnchoose', GenericTypes => [L], Pars=>'n(); m(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_lnchoose_e,($n(), $m(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'log(n choose m)' ); pp_def('gsl_sf_choose', GenericTypes => [L], Pars=>'n(); m(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_choose_e,($n(), $m(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'n choose m' ); pp_def('gsl_sf_lnpoch', GenericTypes => [D], OtherPars => 'double a', Pars=>'double x(); double [o]y(); double [o]s(); double [o]e()', Code =>' gsl_sf_result r; double sgn; GSLERR(gsl_sf_lnpoch_sgn_e,($COMP(a),$x(),&r,&sgn)) $y() = r.val; $e() = r.err; $s() = sgn; ', Doc =>'Logarithm of Pochammer (Apell) symbol, with sign information. result = log( |(a)_x| ), sgn = sgn( (a)_x ) where (a)_x := Gamma[a + x]/Gamma[a]' ); pp_def('gsl_sf_poch', GenericTypes => [D], OtherPars => 'double a', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_poch_e,($COMP(a),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Pochammer (Apell) symbol (a)_x := Gamma[a + x]/Gamma[x]' ); pp_def('gsl_sf_pochrel', GenericTypes => [D], OtherPars => 'double a', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_pochrel_e,($COMP(a),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Relative Pochammer (Apell) symbol ((a,x) - 1)/x where (a,x) = (a)_x := Gamma[a + x]/Gamma[a]' ); pp_def('gsl_sf_gamma_inc_Q', GenericTypes => [D], OtherPars => 'double a', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_gamma_inc_Q_e,($COMP(a),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Normalized Incomplete Gamma Function Q(a,x) = 1/Gamma(a) Integral[ t^(a-1) e^(-t), {t,x,Infinity} ]' ); pp_def('gsl_sf_gamma_inc_P', GenericTypes => [D], OtherPars => 'double a', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_gamma_inc_P_e,($COMP(a),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Complementary Normalized Incomplete Gamma Function P(a,x) = 1/Gamma(a) Integral[ t^(a-1) e^(-t), {t,0,x} ]' ); pp_def('gsl_sf_lnbeta', GenericTypes => [D], Pars=>'double a(); double b(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_lnbeta_e,($a(),$b(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Logarithm of Beta Function Log[B(a,b)]' ); pp_def('gsl_sf_beta', GenericTypes => [D], OtherPars => '', Pars=>'double a(); double b();double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_beta_e,($a(),$b(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Beta Function B(a,b)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/gamma/Makefile.PL0000644060175006010010000000055712562522364015111 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_gamma.pd', qw(GAMMA PDL::GSLSF::GAMMA)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/gegenbauer/0000755060175006010010000000000013110402045014131 5ustar chmNonePDL-2.018/Lib/GSL/SF/gegenbauer/gsl_sf_gegenbauer.pd0000644060175006010010000000300713101130663020123 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::GEGENBAUER - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_gegenpoly_n', GenericTypes => [D], OtherPars =>'int n; double lambda', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_gegenpoly_n_e,($COMP(n),$COMP(lambda), $x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Evaluate Gegenbauer polynomials.' ); pp_def('gsl_sf_gegenpoly_array', GenericTypes => [D], OtherPars =>'int n=>num; double lambda', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_gegenpoly_array,($COMP(n)-1,$COMP(lambda),$x(),$P(y))) ', Doc =>'Calculate array of Gegenbauer polynomials from 0 to n-1.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/gegenbauer/Makefile.PL0000644060175006010010000000057612562522364016134 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_gegenbauer.pd', qw(GEGENBAUER PDL::GSLSF::GEGENBAUER)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/gslerr.h0000644060175006010010000000024412562522364013515 0ustar chmNone static int status; static char buf[200]; #define GSLERR(x,y) if ((status = x y)) {snprintf(buf,200,"Error in %s: %s", #x, gsl_strerror(status));barf("%s", buf);} PDL-2.018/Lib/GSL/SF/hyperg/0000755060175006010010000000000013110402046013324 5ustar chmNonePDL-2.018/Lib/GSL/SF/hyperg/gsl_sf_hyperg.pd0000644060175006010010000001005213101130663016505 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::HYPERG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_hyperg_0F1', GenericTypes => [D], OtherPars =>'double c', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_0F1_e,($COMP(c), $x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'/* Hypergeometric function related to Bessel functions 0F1[c,x] = Gamma[c] x^(1/2(1-c)) I_{c-1}(2 Sqrt[x]) Gamma[c] (-x)^(1/2(1-c)) J_{c-1}(2 Sqrt[-x])' ); pp_def('gsl_sf_hyperg_1F1', GenericTypes => [D], OtherPars =>'double a; double b', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_1F1_e,($COMP(a),$COMP(b), $x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Confluent hypergeometric function for integer parameters. 1F1[a,b,x] = M(a,b,x)' ); pp_def('gsl_sf_hyperg_U', GenericTypes => [D], OtherPars =>'double a; double b', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_U_e,($COMP(a),$COMP(b), $x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Confluent hypergeometric function for integer parameters. U(a,b,x)' ); pp_def('gsl_sf_hyperg_2F1', GenericTypes => [D], OtherPars =>'double a; double b; double c', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_2F1_e,($COMP(a),$COMP(b), $COMP(c),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Confluent hypergeometric function for integer parameters. 2F1[a,b,c,x]' ); pp_def('gsl_sf_hyperg_2F1_conj', GenericTypes => [D], OtherPars =>'double a; double b; double c', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_2F1_conj_e,($COMP(a),$COMP(b), $COMP(c),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Gauss hypergeometric function 2F1[aR + I aI, aR - I aI, c, x]' ); pp_def('gsl_sf_hyperg_2F1_renorm', GenericTypes => [D], OtherPars =>'double a; double b; double c', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_2F1_renorm_e,($COMP(a),$COMP(b), $COMP(c),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Renormalized Gauss hypergeometric function 2F1[a,b,c,x] / Gamma[c]' ); pp_def('gsl_sf_hyperg_2F1_conj_renorm', GenericTypes => [D], OtherPars =>'double a; double b; double c', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_2F1_conj_renorm_e,($COMP(a),$COMP(b), $COMP(c),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Renormalized Gauss hypergeometric function 2F1[aR + I aI, aR - I aI, c, x] / Gamma[c]' ); pp_def('gsl_sf_hyperg_2F0', GenericTypes => [D], OtherPars =>'double a; double b', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hyperg_2F0_e,($COMP(a),$COMP(b), $x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Mysterious hypergeometric function. The series representation is a divergent hypergeometric series. However, for x < 0 we have 2F0(a,b,x) = (-1/x)^a U(a,1+a-b,-1/x)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/hyperg/Makefile.PL0000644060175006010010000000056212562522364015321 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_hyperg.pd', qw(HYPERG PDL::GSLSF::HYPERG)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/laguerre/0000755060175006010010000000000013110402046013634 5ustar chmNonePDL-2.018/Lib/GSL/SF/laguerre/gsl_sf_laguerre.pd0000644060175006010010000000227713101130663017337 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::LAGUERRE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_laguerre_n', GenericTypes => [D], OtherPars =>'int n; double a', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_laguerre_n_e,($COMP(n),$COMP(a), $x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Evaluate generalized Laguerre polynomials.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/laguerre/Makefile.PL0000644060175006010010000000057012562522364015630 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_laguerre.pd', qw(LAGUERRE PDL::GSLSF::LAGUERRE)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/legendre/0000755060175006010010000000000013110402046013613 5ustar chmNonePDL-2.018/Lib/GSL/SF/legendre/gsl_sf_legendre.pd0000644060175006010010000002432613101130663017274 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::LEGENDRE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_legendre_Pl', GenericTypes => [D], OtherPars =>'int l', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_legendre_Pl_e,($COMP(l),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'P_l(x)' ); pp_def('gsl_sf_legendre_Pl_array', GenericTypes => [D], OtherPars =>'int l=>num', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_legendre_Pl_array,($COMP(l)-1,$x(),$P(y))) ', Doc =>'P_l(x) from 0 to n-1.' ); pp_def('gsl_sf_legendre_Ql', GenericTypes => [D], OtherPars =>'int l', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_legendre_Ql_e,($COMP(l),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Q_l(x)' ); pp_def('gsl_sf_legendre_Plm', GenericTypes => [D], OtherPars =>'int l; int m', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_legendre_Plm_e,($COMP(l),$COMP(m),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'P_lm(x)' ); my $v = `gsl-config --version`; if (defined($v) && $v>=2.0){ pp_def('gsl_sf_legendre_array', GenericTypes => [D], OtherPars => 'char norm; int lmax; int csphase', Pars => 'double x(); double [o]y(n); double [t]work(wn)', RedoDimsCode => ' $SIZE(wn)=gsl_sf_legendre_array_n($COMP(lmax)); $SIZE(n)=$COMP(lmax)*($COMP(lmax)+1)/2+$COMP(lmax)+1; ', Code => <<'EOC', int i; if($x()<-1||$x()>1) barf("The input to gsl_sf_legendre_array must be abs(x)<=1, and you input %f. Try normalizing your input.",$x()); switch ($COMP(norm)){ case 'P' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_NONE, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; case 'S' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_SCHMIDT, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; case 'Y' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_SPHARM, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; case 'N' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_FULL, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; default : ; } for(i=0; i<$SIZE(n); i++) { $y(n=>i) = $work(wn=>i); } EOC HandleBad => 1, BadCode => <<'EOBC', int i; if ( $ISBAD( x() ) ) { loop(n) %{ $SETBAD ( y() ); %} } else { if($x()<-1||$x()>1) barf("The input to gsl_sf_legendre_array must be abs(x)<=1, and you input %f",$x()); switch ($COMP(norm)) { case 'P' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_NONE, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; case 'S' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_SCHMIDT, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; case 'Y' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_SPHARM, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; case 'N' : GSLERR(gsl_sf_legendre_array_e,(GSL_SF_LEGENDRE_FULL, $COMP(lmax), $x(), $COMP(csphase), $P(work))); break; default : ; } for(i=0; i<$SIZE(n); i++) { $y(n=>i) = $work(wn=>i); } } EOBC Doc => <<'EOD', =for ref Calculate all normalized associated Legendre polynomials. =for usage $Plm = gsl_sf_legendre_array($x,'P',4,-1); The calculation is done for degree 0 <= l <= lmax and order 0 <= m <= l on the range abs(x)<=1. The parameter norm should be: =over 3 =item 'P' for unnormalized associated Legendre polynomials P_l^m(x), =item 'S' for Schmidt semi-normalized associated Legendre polynomials S_l^m(x), =item 'Y' for spherical harmonic associated Legendre polynomials Y_l^m(x), or =item 'N' for fully normalized associated Legendre polynomials N_l^m(x). =back lmax is the maximum degree l. csphase should be (-1) to INCLUDE the Condon-Shortley phase factor (-1)^m, or (+1) to EXCLUDE it. See L to get the value of C and C in the returned vector. EOD ); pp_def('gsl_sf_legendre_array_index', OtherPars => 'int lmax', Pars => 'int [o]l(n); int [o]m(n)', RedoDimsCode => '$SIZE(n)=$COMP(lmax)*($COMP(lmax)+1)/2+$COMP(lmax)+1;', Code => q/ int ell, em, index; for (ell=0; ell<=$COMP(lmax); ell++){ for (em=0; em<=ell; em++){ index = gsl_sf_legendre_array_index(ell,em); $l(n=>index)=ell; $m(n=>index)=em; } }/, Doc =>'=for ref Calculate the relation between gsl_sf_legendre_arrays index and l and m values. =for usage ($l,$m) = gsl_sf_legendre_array_index($lmax); Note that this function is called differently than the corresponding GSL function, to make it more useful for PDL: here you just input the maximum l (lmax) that was used in C and it calculates all l and m values.' ); } elsif (defined($v) && $v<2.0) { pp_def('gsl_sf_legendre_Plm_array', GenericTypes => [D], OtherPars =>'int l=>num; int m', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_legendre_Plm_array,($COMP(l)-2+$COMP(m),$COMP(m),$x(),$P(y))) ', Doc =>'P_lm(x) for l from 0 to n-2+m. gsl_sf_legendre_Plm_array has been deprecated in GSL version 2.0. It is included here for backwards compatability and may be removed in a future release. New code should use L instead.' ); pp_def('gsl_sf_legendre_sphPlm_array', GenericTypes => [D], OtherPars =>'int n=>num; int m', Pars=>'double x(); double [o]y(num)', Code =>' GSLERR(gsl_sf_legendre_sphPlm_array,($COMP(n)-2+$COMP(m),$COMP(m),$x(),$P(y))) ', Doc =>'P_lm(x), normalized properly for use in spherical harmonics for l from 0 to n-2+m. gsl_sf_legendre_sphPlm_array has been deprecated in GSL version 2.0. It is included here for backwards compatability and may be removed in a future release. New code should use L instead.' ); } else { die("Could not determine GSL version from gsl-config, so can not determine which legendre array functions to define."); } pp_def('gsl_sf_legendre_sphPlm', GenericTypes => [D], OtherPars =>'int l; int m', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_legendre_sphPlm_e,($COMP(l),$COMP(m),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'P_lm(x), normalized properly for use in spherical harmonics' ); pp_def('gsl_sf_conicalP_half', GenericTypes => [D], OtherPars =>'double lambda', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_conicalP_half_e,($COMP(lambda),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Irregular Spherical Conical Function P^{1/2}_{-1/2 + I lambda}(x)' ); pp_def('gsl_sf_conicalP_mhalf', GenericTypes => [D], OtherPars =>'double lambda', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_conicalP_mhalf_e,($COMP(lambda),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regular Spherical Conical Function P^{-1/2}_{-1/2 + I lambda}(x)' ); pp_def('gsl_sf_conicalP_0', GenericTypes => [D], OtherPars =>'double lambda', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_conicalP_0_e,($COMP(lambda),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Conical Function P^{0}_{-1/2 + I lambda}(x)' ); pp_def('gsl_sf_conicalP_1', GenericTypes => [D], OtherPars =>'double lambda', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_conicalP_1_e,($COMP(lambda),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Conical Function P^{1}_{-1/2 + I lambda}(x)' ); pp_def('gsl_sf_conicalP_sph_reg', GenericTypes => [D], OtherPars =>'int l; double lambda', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_conicalP_sph_reg_e,($COMP(l),$COMP(lambda),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regular Spherical Conical Function P^{-1/2-l}_{-1/2 + I lambda}(x)' ); pp_def('gsl_sf_conicalP_cyl_reg_e', GenericTypes => [D], OtherPars =>'int m; double lambda', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_conicalP_cyl_reg_e,($COMP(m),$COMP(lambda),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Regular Cylindrical Conical Function P^{-m}_{-1/2 + I lambda}(x)' ); pp_def('gsl_sf_legendre_H3d', GenericTypes => [D], OtherPars =>'int l; double lambda; double eta', Pars=>'double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_legendre_H3d_e,($COMP(l),$COMP(lambda),$COMP(eta),&r)) $y() = r.val; $e() = r.err; ', Doc =>'lth radial eigenfunction of the Laplacian on the 3-dimensional hyperbolic space.' ); pp_def('gsl_sf_legendre_H3d_array', GenericTypes => [D], OtherPars =>'int l=>num; double lambda; double eta', Pars=>'double [o]y(num)', Code =>' GSLERR(gsl_sf_legendre_H3d_array,($COMP(l)-1,$COMP(lambda),$COMP(eta),$P(y))) ', Doc =>'Array of H3d(ell), for l from 0 to n-1.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/legendre/Makefile.PL0000644060175006010010000000057012562522364015607 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_legendre.pd', qw(LEGENDRE PDL::GSLSF::LEGENDRE)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/log/0000755060175006010010000000000013110402046012607 5ustar chmNonePDL-2.018/Lib/GSL/SF/log/gsl_sf_log.pd0000644060175006010010000000305213101130663015255 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::LOG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_log', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_log_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Provide a logarithm function with GSL semantics.' ); pp_def('gsl_sf_complex_log', GenericTypes => [D], Pars=>'double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()', Code =>' gsl_sf_result r; gsl_sf_result ri; GSLERR(gsl_sf_complex_log_e,($zr(),$zi(),&r,&ri)) $x() = r.val; $xe() = r.err; $y() = ri.val; $ye() = ri.err; ', Doc =>'Complex Logarithm exp(lnr + I theta) = zr + I zi Returns argument in [-pi,pi].' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/log/Makefile.PL0000644060175006010010000000055112562522364014602 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_log.pd', qw(LOG PDL::GSLSF::LOG)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/Makefile.PL0000644060175006010010000000311512562522364014020 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); sub gsl_sf_links_ok { my($lib,$inc) = @_; return defined($lib) && defined($inc) && trylink('gsl SF libraries', << 'EOI', #include EOI << 'EOB', $lib, $inc); double x = 5.0; double expected = -0.17759677131433830434739701; double y = gsl_sf_bessel_J0 (x); return 0; EOB } my $skip = 0; my $msg = undef; my $forcebuild=0; if (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==0) { $msg = "\n Will skip build of PDL::GSLSF on this system \n"; $skip = 1; } elsif (defined $PDL::Config{WITH_GSL} && $PDL::Config{WITH_GSL}==1) { print "\n Will forcibly try and build PDL::GSLSF on this system \n\n"; $forcebuild=1; } if (($skip && !$forcebuild) || !gsl_sf_links_ok($GSL_libs, $GSL_includes)) { warn "trying to force GSL build but link test failed\n". "\t -- aborting GSL build\n" if $forcebuild; $msg ||= "\n GSL Libraries not found... Skipping build of PDL::GSLSF.\n"; write_dummy_make( $msg ); return; } else { print "\n Building PDL::GSLSF.", "Turn off WITH_GSL if there are any problems\n\n"; } WriteMakefile( 'NAME' => 'PDL::GSLSF', VERSION => '0.5', # VERSION_FROM => '../../Basic/Core/Version.pm', #DIR => [ qw/airy bessel chebyshev clausen coulomb coupling dawson debye dilog elementary ellint elljac erf exp expint fermi_dirac gamma gegenbauer hyperg laguerre legendre log poly pow_int psi synchrotron transport trig zeta/ ], (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Lib/GSL/SF/poly/0000755060175006010010000000000013110402045013010 5ustar chmNonePDL-2.018/Lib/GSL/SF/poly/gsl_sf_poly.pd0000644060175006010010000000242213101130663015661 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::POLY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. NOTE: this should actually be PDL::POLY for consistency but I don't want to get into edits changing the directory structure at this time. These fixes should allow things to build. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_poly_eval', GenericTypes => [D], Pars=>'double x(); double c(m); double [o]y()', Code =>' $y() = gsl_poly_eval($P(c),$SIZE(m),$x()); ', Doc =>'c[0] + c[1] x + c[2] x^2 + ... + c[m-1] x^(m-1)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/poly/Makefile.PL0000644060175006010010000000055412562522364015007 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_poly.pd', qw(POLY PDL::GSLSF::POLY)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/pow_int/0000755060175006010010000000000013110402044013503 5ustar chmNonePDL-2.018/Lib/GSL/SF/pow_int/gsl_sf_pow_int.pd0000644060175006010010000000221313101130663017047 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::POW_INT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_pow_int', GenericTypes => [D], OtherPars => 'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_pow_int_e,($x(),$COMP(n),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Calculate x^n.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/pow_int/Makefile.PL0000644060175006010010000000056512562522364015505 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_pow_int.pd', qw(POW_INT PDL::GSLSF::POW_INT)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/psi/0000755060175006010010000000000013110402046012621 5ustar chmNonePDL-2.018/Lib/GSL/SF/psi/gsl_sf_psi.pd0000644060175006010010000000336113101130663015304 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::PSI - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Poly-Gamma Functions psi(m,x) := (d/dx)^m psi(0,x) = (d/dx)^{m+1} log(gamma(x)) =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_psi', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_psi_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Di-Gamma Function psi(x).' ); pp_def('gsl_sf_psi_1piy', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_psi_1piy_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Di-Gamma Function Re[psi(1 + I y)]' ); pp_def('gsl_sf_psi_n', GenericTypes => [D], OtherPars => 'int n', Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_psi_n_e,($COMP(n),$x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Poly-Gamma Function psi^(n)(x)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/psi/Makefile.PL0000644060175006010010000000055112562522364014614 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_psi.pd', qw(PSI PDL::GSLSF::PSI)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/README0000644060175006010010000000070212562522364012725 0ustar chmNoneThis is a port of the original PDL GSL Special Functions interface by Christian Pellegrin to GSL 1.x. Only some minor tweaks were necessary to get it going but documentation and testing is in dire need of improvement! We need: - an example for every function (C<=for example> section in docs). - a test for every function (to go into t/gsl_sf.t) Patches by GSL SF users are most welcome! 2002 Christian Soeller PDL-2.018/Lib/GSL/SF/synchrotron/0000755060175006010010000000000013110402046014416 5ustar chmNonePDL-2.018/Lib/GSL/SF/synchrotron/gsl_sf_synchrotron.pd0000644060175006010010000000276313101130663020703 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::SYNCHROTRON - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_synchrotron_1', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_synchrotron_1_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'First synchrotron function: synchrotron_1(x) = x Integral[ K_{5/3}(t), {t, x, Infinity}]' ); pp_def('gsl_sf_synchrotron_2', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_synchrotron_2_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Second synchroton function: synchrotron_2(x) = x * K_{2/3}(x)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/synchrotron/Makefile.PL0000644060175006010010000000060212562522364016406 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_synchrotron.pd', qw(SYNCHROTRON PDL::GSLSF::SYNCHROTRON)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/transport/0000755060175006010010000000000013110402045014061 5ustar chmNonePDL-2.018/Lib/GSL/SF/transport/gsl_sf_transport.pd0000644060175006010010000000363713101130663020014 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::TRANSPORT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Transport function: J(n,x) := Integral[ t^n e^t /(e^t - 1)^2, {t,0,x}] =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_transport_2', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_transport_2_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'J(2,x)' ); pp_def('gsl_sf_transport_3', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_transport_3_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'J(3,x)' ); pp_def('gsl_sf_transport_4', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_transport_4_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'J(4,x)' ); pp_def('gsl_sf_transport_5', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_transport_5_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'J(5,x)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/transport/Makefile.PL0000644060175006010010000000057312562522364016061 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_transport.pd', qw(TRANSPORT PDL::GSLSF::TRANSPORT)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/trig/0000755060175006010010000000000013110402046012773 5ustar chmNonePDL-2.018/Lib/GSL/SF/trig/gsl_sf_trig.pd0000644060175006010010000001211213101130663015622 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::TRIG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_sin', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_sin_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Sin(x) with GSL semantics.' ); pp_def('gsl_sf_cos', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_cos_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Cos(x) with GSL semantics.' ); pp_def('gsl_sf_hypot', GenericTypes => [D], Pars=>'double x(); double xx(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hypot_e,($x(),$xx(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Hypot(x,xx) with GSL semantics.' ); pp_def('gsl_sf_complex_sin', GenericTypes => [D], Pars=>'double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()', Code =>' gsl_sf_result r; gsl_sf_result ri; GSLERR(gsl_sf_complex_sin_e,($zr(),$zi(),&r,&ri)) $x() = r.val; $xe() = r.err; $y() = ri.val; $ye() = ri.err; ', Doc =>'Sin(z) for complex z' ); pp_def('gsl_sf_complex_cos', GenericTypes => [D], Pars=>'double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()', Code =>' gsl_sf_result r; gsl_sf_result ri; GSLERR(gsl_sf_complex_cos_e,($zr(),$zi(),&r,&ri)) $x() = r.val; $xe() = r.err; $y() = ri.val; $ye() = ri.err; ', Doc =>'Cos(z) for complex z' ); pp_def('gsl_sf_complex_logsin', GenericTypes => [D], Pars=>'double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()', Code =>' gsl_sf_result r; gsl_sf_result ri; GSLERR(gsl_sf_complex_logsin_e,($zr(),$zi(),&r,&ri)) $x() = r.val; $xe() = r.err; $y() = ri.val; $ye() = ri.err; ', Doc =>'Log(Sin(z)) for complex z' ); pp_def('gsl_sf_lnsinh', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_lnsinh_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Log(Sinh(x)) with GSL semantics.' ); pp_def('gsl_sf_lncosh', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_lncosh_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Log(Cos(x)) with GSL semantics.' ); pp_def('gsl_sf_polar_to_rect', GenericTypes => [D], Pars=>'double r(); double t(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()', Code =>' gsl_sf_result r; gsl_sf_result ri; GSLERR(gsl_sf_polar_to_rect,($r(),$t(),&r,&ri)) $x() = r.val; $xe() = r.err; $y() = ri.val; $ye() = ri.err; ', Doc =>'Convert polar to rectlinear coordinates.' ); pp_def('gsl_sf_rect_to_polar', GenericTypes => [D], Pars=>'double x(); double y(); double [o]r(); double [o]t(); double [o]re(); double [o]te()', Code =>' gsl_sf_result r; gsl_sf_result ri; GSLERR(gsl_sf_rect_to_polar,($x(),$y(),&r,&ri)) $r() = r.val; $re() = r.err; $t() = ri.val; $te() = ri.err; ', Doc =>'Convert rectlinear to polar coordinates. return argument in range [-pi, pi].' ); pp_def('gsl_sf_angle_restrict_symm', GenericTypes => [D], Pars=>'double [o]y();', Code =>' GSLERR(gsl_sf_angle_restrict_symm_e,($P(y))) ', Doc =>'Force an angle to lie in the range (-pi,pi].' ); pp_def('gsl_sf_angle_restrict_pos', GenericTypes => [D], Pars=>'double [o]y();', Code =>' GSLERR(gsl_sf_angle_restrict_pos_e,($P(y))) ', Doc =>'Force an angle to lie in the range [0,2 pi).' ); pp_def('gsl_sf_sin_err', GenericTypes => [D], Pars=>'double x(); double dx(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_sin_err_e,($x(),$dx(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Sin(x) for quantity with an associated error.' ); pp_def('gsl_sf_cos_err', GenericTypes => [D], Pars=>'double x(); double dx(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_cos_err_e,($x(),$dx(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Cos(x) for quantity with an associated error.' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/trig/Makefile.PL0000644060175006010010000000055412562522364014771 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_trig.pd', qw(TRIG PDL::GSLSF::TRIG)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/GSL/SF/zeta/0000755060175006010010000000000013110402046012771 5ustar chmNonePDL-2.018/Lib/GSL/SF/zeta/gsl_sf_zeta.pd0000644060175006010010000000336513101130663015630 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::GSLSF::ZETA - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut EOD # PP interface to GSL pp_addhdr(' #include #include "../gslerr.h" '); pp_def('gsl_sf_zeta', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_zeta_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Riemann Zeta Function zeta(x) = Sum[ k^(-s), {k,1,Infinity} ], s != 1.0' ); pp_def('gsl_sf_hzeta', GenericTypes => [D], OtherPars =>'double q', Pars=>'double s(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_hzeta_e,($s(), $COMP(q), &r)) $y() = r.val; $e() = r.err; ', Doc =>'Hurwicz Zeta Function zeta(s,q) = Sum[ (k+q)^(-s), {k,0,Infinity} ]' ); pp_def('gsl_sf_eta', GenericTypes => [D], Pars=>'double x(); double [o]y(); double [o]e()', Code =>' gsl_sf_result r; GSLERR(gsl_sf_eta_e,($x(),&r)) $y() = r.val; $e() = r.err; ', Doc =>'Eta Function eta(s) = (1-2^(1-s)) zeta(s)' ); pp_addpm({At=>Bot},<<'EOD'); =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. The GSL SF modules were written by G. Jungman. =cut EOD pp_add_boot('gsl_set_error_handler_off(); '); pp_done(); PDL-2.018/Lib/GSL/SF/zeta/Makefile.PL0000644060175006010010000000055412562522364014767 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; our ($GSL_includes, $GSL_libs); my @pack = (['gsl_sf_zeta.pd', qw(ZETA PDL::GSLSF::ZETA)]); my %hash = pdlpp_stdargs_int(@pack); $hash{INC} .= ' '.$GSL_includes; push @{$hash{LIBS}},$GSL_libs; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/Image2D/0000755060175006010010000000000013110402046012301 5ustar chmNonePDL-2.018/Lib/Image2D/image2d.pd0000644060175006010010000017146713036512175014172 0ustar chmNoneuse strict; use PDL::Types; pp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::Image2D - Miscellaneous 2D image processing functions =head1 DESCRIPTION Miscellaneous 2D image processing functions - for want of anywhere else to put them. =head1 SYNOPSIS use PDL::Image2D; =cut use PDL; # ensure qsort routine available use PDL::Math; use Carp; use strict; EOD pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHORS Copyright (C) Karl Glazebrook 1997 with additions by Robin Williams (rjrw@ast.leeds.ac.uk), Tim Jeness (timj@jach.hawaii.edu), and Doug Burke (burke@ifa.hawaii.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD ################################################# # BEGIN INTERNAL FUNCTION DECLARATIONS # ################################################# pp_addhdr(' #define MAXSEC 32 #define line(x1, x2, y) for (k=x1;k<=x2;k++) \ { /* printf("line from %d to %d\n",x1,x2); */ \ image[k+wx*y] = col; } #define PX(n) ps[2*n] #define PY(n) ps[2*n+1] void polyfill(PDL_Long *image, int wx, int wy, float *ps, int n, PDL_Long col, int *ierr) { int ymin, ymax, xmin, xmax, fwrd = 1, i, j, k, nsect; int x[MAXSEC], temp, l; float s1, s2, t1, t2; ymin = PY(0); ymax = PY(0); xmin = PX(0); xmax = PX(0); *ierr = 0; for (i=1; i PY(i) ? PY(i) : ymin; ymax = ymax < PY(i) ? PY(i) : ymax; xmin = xmin > PX(i) ? PX(i) : xmin; xmax = xmax < PX(i) ? PX(i) : xmax; } if (xmin < 0 || xmax >= wx || ymin < 0 || ymax >= wy) { *ierr = 1; /* clipping */ return; } s1 = PX(n-1); t1 = PY(n-1); for (l=ymin; l<= ymax; l++) { nsect = 0; fwrd = 1; for (i=0; i= l && l > t2)) { if (nsect > MAXSEC) { *ierr = 2; /* too complex */ return; } x[nsect] = (s1+(s2-s1)*((l-t1)/(t2-t1))); nsect += 1; } s1 = s2; t1 = t2; } /* sort the intersections */ for (i=1; i x[i]) { temp = x[j]; x[j] = x[i]; x[i] = temp; } if (fwrd) { for (i=0; i0; i -= 2) line(x[i-1],x[i],l); fwrd = 1; } } } '); pp_def('polyfill_pp', HandleBad => 0, # a marker Pars => 'int [o,nc] im(m,n); float ps(two=2,np); int col()', Code => 'int ierr = 0, nerr; threadloop %{ polyfill($P(im), $SIZE(m), $SIZE(n), $P(ps), $SIZE(np), $col(), &nerr); ierr = ierr < nerr ? nerr : ierr; %} if (ierr) warn("errors during polygonfilling"); ', Doc => undef, PMFunc => '' ); my %pnpolyFields = ( 'pnpoly_pp' => {'pars' => 'a(m,n); ps(k,l); int [o] msk(m,n)', 'special' => '$msk() = c;'}, 'pnpolyfill_pp' => {'pars' => '[o,nc] a(m,n); ps(k,l); int col()', 'special' => 'if(c) { $a() = $col(); }'} ); for my $name (sort keys %pnpolyFields) { pp_def($name, HandleBad => 0, PMFunc => '', Doc => undef, Pars => $pnpolyFields{$name}->{'pars'}, Code => ' int i, j, c, nvert; nvert = $SIZE(l); #define VERTX(q) $ps(k=>0,l=>q) #define VERTY(q) $ps(k=>1,l=>q) threadloop %{ loop(n) %{ loop(m) %{ c = 0; for(i=0,j=nvert-1;in) != (VERTY(j)>n)) && (m < (VERTX(j)-VERTX(i)) * (n-VERTY(i)) / (VERTY(j)-VERTY(i)) + VERTX(i)) ) c = !c; } ' . $pnpolyFields{$name}->{'special'} .' %} %} %} #undef VERTX #undef VERTY ' ); } pp_export_nothing(); # Clear the export list ################################################# # END INTERNAL FUNCTION DECLARATIONS # ################################################# pp_addhdr(' #define IsNaN(x) (x != x) /* Fast Modulus with proper negative behaviour */ #define REALMOD(a,b) {while ((a)>=(b)) (a) -= (b); while ((a)<0) (a) += (b);} /* rint is missing on some platforms (eg Win32) */ #ifdef NEEDS_RINT #define rint(X) floor( X + 0.5 ) #endif '); for ( PDL::Types::typesrtkeys() ) { my $ctype = $PDL::Types::typehash{$_}{ctype}; my $ppsym = $PDL::Types::typehash{$_}{ppsym}; pp_addhdr << "EOH"; /* * this routine is based on code referenced from * http://www.eso.org/~ndevilla/median/ * the original algorithm is described in Numerical Recipes */ #define ELEM_SWAP(a,b) { register $ctype t=(a);(a)=(b);(b)=t; } $ctype quick_select_$ppsym($ctype arr[], int n) { int low, high ; int median; int middle, ll, hh; low = 0 ; high = n-1 ; median = (low + high) / 2; for (;;) { if (high <= low) /* One element only */ return arr[median] ; if (high == low + 1) { /* Two elements only */ if (arr[low] > arr[high]) ELEM_SWAP(arr[low], arr[high]) ; return arr[median] ; } /* Find median of low, middle and high items; swap into position low */ middle = (low + high) / 2; if (arr[middle] > arr[high]) ELEM_SWAP(arr[middle], arr[high]) ; if (arr[low] > arr[high]) ELEM_SWAP(arr[low], arr[high]) ; if (arr[middle] > arr[low]) ELEM_SWAP(arr[middle], arr[low]) ; /* Swap low item (now in position middle) into position (low+1) */ ELEM_SWAP(arr[middle], arr[low+1]) ; /* Nibble from each end towards middle, swapping items when stuck */ ll = low + 1; hh = high; for (;;) { do ll++; while (arr[low] > arr[ll]) ; do hh--; while (arr[hh] > arr[low]) ; if (hh < ll) break; ELEM_SWAP(arr[ll], arr[hh]) ; } /* Swap middle item (in position low) back into correct position */ ELEM_SWAP(arr[low], arr[hh]) ; /* Re-set active partition */ if (hh <= median) low = ll; if (hh >= median) high = hh - 1; } } #undef ELEM_SWAP EOH } my %init = ( i => { size => 'm_size', off => 'poff', init => '1-p_size' }, j => { size => 'n_size', off => 'qoff', init => '1-q_size' }, ); # requires 'int $var, ${var}2' to have been declared in the c code # (along with [pq]off and [pq]_size) # sub init_map { my $var = shift; my $loop = $var; my $loop2 = "${var}2"; my $href = $init{$var} || die "ERROR: unknown variable sent to init_map()\n"; my $size = $href->{size} || die "ERROR: unable to find size for $var\n"; my $off = $href->{off} || die "ERROR: unable to find off for $var\n"; my $init = $href->{init} || die "ERROR: unable to find init for $var\n"; return "for ( $loop = $init; $loop< $size; ${loop}++) { $loop2 = $loop + $off; switch (opt) { case 1: /* REFLECT */ if (${loop2}<0) $loop2 = -${loop2}-1; else if ($loop2 >= $size) $loop2 = 2*${size}-(${loop2}+1); break; case 2: /* TRUNCATE */ if (${loop2}<0 || ${loop2} >= $size) $loop2 = -1; break; case 3: /* REPLICATE */ if (${loop2}<0) $loop2 = 0; if (${loop2} >= $size) $loop2 = $size-1; break; default: REALMOD($loop2,$size); } map${var}\[$loop] = $loop2; }\n"; } # sub: init_map() sub init_vars { my $href = shift || { }; $href->{vars} = '' unless defined $href->{vars}; $href->{malloc} = '' unless defined $href->{malloc}; $href->{check} = '' unless defined $href->{check}; my $str = $href->{vars}; $str .= "int i,j, i1,j1, i2,j2, poff, qoff;"; $str .= 'int opt = $COMP(opt); int m_size = $COMP(__m_size); int n_size = $COMP(__n_size); int p_size = $COMP(__p_size); int q_size = $COMP(__q_size); int *mapi, *mapj; mapi = (int *) malloc((p_size+m_size)*sizeof(int)); mapj = (int *) malloc((q_size+n_size)*sizeof(int)); '; $str .= $href->{malloc} . "\n"; $str .= "if ($href->{check} (mapi==NULL) || (mapj==NULL))\n"; $str .= ' barf("Out of Memory"); poff = p_size/2; mapi += p_size-1; qoff = q_size/2; mapj += q_size-1; '; return $str; } # sub: init_vars() pp_def('conv2d', Doc=><<'EOD', =for ref 2D convolution of an array with a kernel (smoothing) For large kernels, using a FFT routine, such as L in C, will be quicker. =for usage $new = conv2d $old, $kernel, {OPTIONS} =for example $smoothed = conv2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =cut EOD BadDoc => 'Unlike the FFT routines, conv2d is able to process bad values.', HandleBad => 1, Pars => 'a(m,n); kern(p,q); [o]b(m,n);', OtherPars => 'int opt;', PMCode => ' sub PDL::conv2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq \'HASH\'; die \'Usage: conv2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )\' if $#_<1 || $#_>2; my($a,$kern) = @_; my $c = $#_ == 2 ? $_[2] : $a->nullcreate; &PDL::_conv2d_int($a,$kern,$c, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } ', Code => init_vars( { vars => 'PDL_Double tmp;' } ) . init_map("i") . init_map("j") . ' threadloop %{ for(j=0; j= 0) { for(i1=0; i1= 0) tmp += $a(m=>i2,n=>j2) * $kern(p=>i1,q=>j1); } /* for: i1 */ } /* if: j2 >= 0 */ } /* for: j1 */ $b(m=>i,n=>j) = tmp; } /* for: i */ } /* for: j */ %} free(mapj+1-q_size); free(mapi+1-p_size);', BadCode => init_vars( { vars => 'PDL_Double tmp; int flag;' } ) . init_map("i") . init_map("j") . ' threadloop %{ for(j=0; j= 0) { for(i1=0; i1= 0) { if ( $ISGOOD(a(m=>i2,n=>j2)) && $ISGOOD(kern(p=>i1,q=>j1)) ) { tmp += $a(m=>i2,n=>j2) * $kern(p=>i1,q=>j1); flag = 1; } /* if: good */ } /* if: i2 >= 0 */ } /* for: i1 */ } /* if: j2 >= 0 */ } /* for: j1 */ if ( flag ) { $b(m=>i,n=>j) = tmp; } else { $SETBAD(b(m=>i,n=>j)); } } /* for: i */ } /* for: j */ %} free(mapj+1-q_size); free(mapi+1-p_size);', ); # pp_def: conv2d pp_def('med2d', Doc=> <<'EOD', =for ref 2D median-convolution of an array with a kernel (smoothing) Note: only points in the kernel E0 are included in the median, other points are weighted by the kernel value (medianing lots of zeroes is rather pointless) =for usage $new = med2d $old, $kernel, {OPTIONS} =for example $smoothed = med2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =cut EOD BadDoc => 'Bad values are ignored in the calculation. If all elements within the kernel are bad, the output is set bad.', HandleBad => 1, Pars => 'a(m,n); kern(p,q); [o]b(m,n);', OtherPars => 'int opt;', PMCode => ' sub PDL::med2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq \'HASH\'; die \'Usage: med2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )\' if $#_<1 || $#_>2; my($a,$kern) = @_; croak "med2d: kernel must contain some positive elements.\n" if all( $kern <= 0 ); my $c = $#_ == 2 ? $_[2] : $a->nullcreate; &PDL::_med2d_int($a,$kern,$c, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } ', Code => init_vars( { vars => 'PDL_Double *tmp, kk; int count;', malloc => 'tmp = malloc(p_size*q_size*sizeof(PDL_Double));', check => '(tmp==NULL) || ' } ) . init_map("i") . init_map("j") . ' threadloop %{ for(j=0; j= 0) for(i1=0; i1= 0) { kk = $kern(p=>i1,q=>j1); if (kk>0) { tmp[count++] = $a(m=>i2,n=>j2) * kk; } } /* if: i2 >= 0 */ } /* for: i1 */ } /* for: j1 */ PDL->qsort_D( tmp, 0, count-1 ); $b(m=>i,n=>j) = tmp[(count-1)/2]; } /* for: i */ } /* for: j */ %} free(mapj+1-q_size); free(mapi+1-p_size); free(tmp); ', BadCode => init_vars( { vars => 'PDL_Double *tmp, kk, aa; int count, flag;', malloc => 'tmp = malloc(p_size*q_size*sizeof(PDL_Double));', check => '(tmp==NULL) || ' } ) . init_map("i") . init_map("j") . ' threadloop %{ for(j=0; j= 0) for(i1=0; i1= 0) { kk = $kern(p=>i1,q=>j1); aa = $a(m=>i2,n=>j2); if ( $ISGOODVAR(kk,kern) && $ISGOODVAR(aa,a) ) { flag = 1; if ( kk > 0 ) { tmp[count++] = aa * kk; } } } /* if: i2 >= 0 */ } /* for: i1 */ } /* for: j1 */ if ( flag == 0 ) { $SETBAD(b(m=>i,n=>j)); } else { PDL->qsort_D( tmp, 0, count-1 ); $b(m=>i,n=>j) = tmp[(count-1)/2]; } } /* for: i */ } /* for: j */ %} free(mapj+1-q_size); free(mapi+1-p_size); free(tmp); ' ); # pp_def: med2d pp_def('med2df', Doc=> <<'EOD', =for ref 2D median-convolution of an array in a pxq window (smoothing) Note: this routine does the median over all points in a rectangular window and is not quite as flexible as C in this regard but slightly faster instead =for usage $new = med2df $old, $xwidth, $ywidth, {OPTIONS} =for example $smoothed = med2df $image, 3, 3, {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =cut EOD Pars => 'a(m,n); [o]b(m,n);', # funny parameter names to avoid special case in 'init_vars' OtherPars => 'int __p_size; int __q_size; int opt;', PMCode => ' sub PDL::med2df { my $opt; $opt = pop @_ if ref($_[$#_]) eq \'HASH\'; die \'Usage: med2df( a(m,n), [o]b(m,n), p, q, {Options} )\' if $#_<2 || $#_>3; my($a,$p,$q) = @_; croak "med2df: kernel must contain some positive elements.\n" if $p == 0 && $q == 0; my $c = $#_ == 3 ? $_[3] : $a->nullcreate; &PDL::_med2df_int($a,$c,$p,$q, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } ', Code => init_vars( { vars => '$GENERIC() *tmp, kk; int count;', malloc => 'tmp = malloc(p_size*q_size*sizeof($GENERIC()));', check => '(tmp==NULL) || ' } ) . init_map("i") . init_map("j") . ' threadloop %{ for(j=0; j= 0) for(i1=0; i1= 0) { tmp[count++] = $a(m=>i2,n=>j2); } /* if: i2 >= 0 */ } /* for: i1 */ } /* for: j1 */ $b(m=>i,n=>j) = quick_select_$TBSULNQFD(B,S,U,L,N,Q,F,D) (tmp, count ); } /* for: i */ } /* for: j */ %} free(mapj+1-q_size); free(mapi+1-p_size); free(tmp); ', ); # pp_def: med2df pp_addhdr(<<'EOH'); #define EZ(x) ez ? 0 : (x) EOH pp_def('box2d', Pars => 'a(n,m); [o] b(n,m)', OtherPars => 'int wx; int wy; int edgezero', Code => ' register int nx = 0.5*$COMP(wx); register int ny = 0.5*$COMP(wy); register int xs = $SIZE(n); register int ys = $SIZE(m); register int ez = $COMP(edgezero); double div, sum, lsum; int xx,yy,y,ind1,ind2,first; div = 1/((2.0*nx+1)*(2.0*ny+1)); threadloop %{ first = 1; for (y=0;yxx,m=>y) = EZ($a(n=>xx,m=>y)); $b(n=>ind1,m=>y) = EZ($a(n=>ind1,m=>y)); } for (xx=0;xxxx,m=>y) = EZ($a(n=>xx,m=>y)); $b(n=>xx,m=>ind1) = EZ($a(n=>xx,m=>ind1)); } for (y=ny;yxx,m=>yy); } else { ind1 = y-ny-1; ind2 = y+ny; for (xx=0;xx<=2*nx;xx++) { lsum -= $a(n=>xx,m=>ind1); /* remove top pixels */ lsum += $a(n=>xx,m=>ind2); /* add bottom pixels */ } } sum = lsum; $b(n=>nx,m=>y) = div*sum; /* and assign */ for (xx=nx+1;xxind1,m=>yy); /* remove leftmost data */ sum += $a(n=>ind2,m=>yy); /* and add rightmost */ } $b(n=>xx,m=>y) = div*sum; /* and assign */ } } %}', Doc => << 'EOD', =for ref fast 2D boxcar average =for example $smoothim = $im->box2d($wx,$wy,$edgezero=1); The edgezero argument controls if edge is set to zero (edgezero=1) or just keeps the original (unfiltered) values. C should be updated to support similar edge options as C and C etc. Boxcar averaging is a pretty crude way of filtering. For serious stuff better filters are around (e.g., use L with the appropriate kernel). On the other hand it is fast and computational cost grows only approximately linearly with window size. =cut EOD ); # pp_def box2d =head2 patch2d =cut pp_def('patch2d', Doc=><<'EOD', =for ref patch bad pixels out of 2D images using a mask =for usage $patched = patch2d $data, $bad; C<$bad> is a 2D mask array where 1=bad pixel 0=good pixel. Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the original data value is copied across. =cut EOD BadDoc => 'This routine does not handle bad values - use L instead', HandleBad => 0, Pars => 'a(m,n); int bad(m,n); [o]b(m,n);', Code => 'int m_size, n_size, i,j, i1,j1, i2,j2, norm; double tmp; m_size = $COMP(__m_size); n_size = $COMP(__n_size); threadloop %{ for(j=0; ji,n=>j) = $a(m=>i,n=>j); if ( $bad(m=>i,n=>j)==1 ) { tmp = 0; norm=0; for(j1=-1; j1<=1; j1++) { j2 = j+j1; if ( j2>=0 && j2=0 && i2i2,n=>j2)!=1 ) { tmp += $a(m=>i2,n=>j2); norm++; } } /* if: i1!=0 || j1!=0 */ } /* for: i1 */ } } /* for: j1 */ if (norm>0) { /* Patch */ $b(m=>i,n=>j) = tmp/norm; } } /* if: bad() */ } /* for: i */ } /* for: j */ %} /* threadloop */ ', # Code ); pp_def('patchbad2d', Doc=><<'EOD', =for ref patch bad pixels out of 2D images containing bad values =for usage $patched = patchbad2d $data; Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the output is set bad. If the input piddle contains I bad values, then a straight copy is performed (see L). =cut EOD BadDoc => 'patchbad2d handles bad values. The output piddle I contain bad values, depending on the pattern of bad values in the input piddle.', HandleBad => 1, Pars => 'a(m,n); [o]b(m,n);', Code => 'loop(n,m) %{ $b() = $a(); %}', # just copy CopyBadStatusCode => '', # handled by BadCode BadCode => 'int m_size, n_size, i,j, i1,j1, i2,j2, norm, flag; double tmp; $GENERIC(a) a_val; flag = 0; m_size = $COMP(__m_size); n_size = $COMP(__n_size); threadloop %{ for(j=0; ji,n=>j); if ( $ISGOODVAR(a_val,a) ) { $b(m=>i,n=>j) = a_val; } else { tmp = 0; norm=0; for(j1=-1; j1<=1; j1++) { j2 = j+j1; if ( j2>=0 && j2=0 && i2i2,n=>j2); if ( $ISGOODVAR(a_val,a) ) { tmp += a_val; norm++; } } } /* if: i1!=0 || j1!=0 */ } /* for: i1 */ } } /* for: j1 */ /* Patch */ if (norm>0) { $b(m=>i,n=>j) = tmp/norm; } else { $SETBAD(b(m=>i,n=>j)); flag = 1; } } /* if: ISGOODVAR() */ } /* for: i */ } /* for: j */ %} /* threadloop */ /* handle bad flag */ if ( flag ) $PDLSTATESETBAD(b); ', # BadCode ); pp_def('max2d_ind', Doc=><<'EOD', =for ref Return value/position of maximum value in 2D image Contributed by Tim Jeness =cut EOD BadDoc=><<'EOD', Bad values are excluded from the search. If all pixels are bad then the output is set bad. EOD HandleBad => 1, Pars => 'a(m,n); [o]val(); int [o]x(); int[o]y();', Code => ' double cur; int curind1; int curind2; curind1=0; curind2=0; loop(m) %{ loop(n) %{ if((!m && !n) || $a() > cur || IsNaN(cur)) { cur = $a(); curind1 = m; curind2 = n; } %} %} $val() = cur; $x() = curind1; $y() = curind2; ', BadCode => ' double cur; int curind1; int curind2; curind1 = -1; curind2 = -1; loop(m) %{ loop(n) %{ if( $ISGOOD(a()) && ( (!n && !m) || ($a() > cur) ) ) { cur = $a(); curind1 = m; curind2 = n; } %} %} if ( curind1 < 0 ) { $SETBAD(val()); $SETBAD(x()); $SETBAD(y()); } else { $val() = cur; $x() = curind1; $y() = curind2; } '); pp_def('centroid2d', Doc=><<'EOD', =for ref Refine a list of object positions in 2D image by centroiding in a box C<$box> is the full-width of the box, i.e. the window is C<+/- $box/2>. =cut EOD BadDoc=><<'EOD', Bad pixels are excluded from the centroid calculation. If all elements are bad (or the pixel sum is 0 - but why would you be centroiding something with negatives in...) then the output values are set bad. EOD HandleBad => 1, Pars => 'im(m,n); x(); y(); box(); [o]xcen(); [o]ycen();', Code => ' int i,j,i1,i2,j1,j2,m_size,n_size; double sum,data,sumx,sumy; m_size = $SIZE(m); n_size = $SIZE(n); i1 = $x() - $box()/2; i1 = i1<0 ? 0 : i1; i2 = $x() + $box()/2; i2 = i2>=m_size ? m_size-1 : i2; j1 = $y() - $box()/2; j1 = j1<0 ? 0 : j1; j2 = $y() + $box()/2; j2 = j2>=n_size ? n_size-1 : j2; sum = sumx = sumy = 0; for(j=j1; j<=j2; j++) { for(i=i1; i<=i2; i++) { data = $im(m=>i,n=>j); sum += data; sumx += data*i; sumy += data*j; }} $xcen() = sumx/sum; $ycen() = sumy/sum; ', BadCode => ' int i,j,i1,i2,j1,j2,m_size,n_size; double sum,data,sumx,sumy; m_size = $SIZE(m); n_size = $SIZE(n); i1 = $x() - $box()/2; i1 = i1<0 ? 0 : i1; i2 = $x() + $box()/2; i2 = i2>=m_size ? m_size-1 : i2; j1 = $y() - $box()/2; j1 = j1<0 ? 0 : j1; j2 = $y() + $box()/2; j2 = j2>=n_size ? n_size-1 : j2; sum = sumx = sumy = 0; for(j=j1; j<=j2; j++) { for(i=i1; i<=i2; i++) { data = $im(m=>i,n=>j); if ( $ISGOODVAR(data,im) ) { sum += data; sumx += data*i; sumy += data*j; } } } /* * if sum == 0 then we will flag as bad -- although it could just mean that * there is negative values in the dataset. * - should use a better check than != 0.0 ... */ if ( sum != 0.0 ) { $xcen() = sumx/sum; $ycen() = sumy/sum; } else { $SETBAD(xcen()); $SETBAD(ycen()); } ' ); pp_addhdr(' /* Add an equivalence to a list - used by pdl_ccNcompt */ void AddEquiv ( PDL_Long* equiv, PDL_Long i, PDL_Long j) { PDL_Long k, tmp; if (i==j) return; k = j; do { k = equiv[k]; } while ( k != j && k != i ); if ( k == j ) { tmp = equiv[i]; equiv[i] = equiv[j]; equiv[j] = tmp; } } '); pp_add_exported('', 'cc8compt','cc4compt'); pp_addpm(<<'EOPM'); =head2 cc8compt =for ref Connected 8-component labeling of a binary image. Connected 8-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 8-component labeling includes all neighboring pixels. This is just a front-end to ccNcompt. See also L. =for example $segmented = cc8compt( $image > $threshold ); =head2 cc4compt =for ref Connected 4-component labeling of a binary image. Connected 4-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 4-component labling does not include the diagonal neighbors. This is just a front-end to ccNcompt. See also L. =for example $segmented = cc4compt( $image > $threshold ); =cut sub PDL::cc8compt{ return ccNcompt(shift,8); } *cc8compt = \&PDL::cc8compt; sub PDL::cc4compt{ return ccNcompt(shift,4); } *cc4compt = \&PDL::cc4compt; EOPM pp_def('ccNcompt',Doc=>' =for ref Connected component labeling of a binary image. Connected component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. See also L and L. The connectivity parameter must be 4 or 8. =for example $segmented = ccNcompt( $image > $threshold, 4); $segmented2 = ccNcompt( $image > $threshold, 8); where the second parameter specifies the connectivity (4 or 8) of the labeling. =cut ', HandleBad => 0, # a marker Pars => 'a(m,n); int+ [o]b(m,n);', OtherPars => 'int con', Code => ' PDL_Long i,j,k; PDL_Long newlabel; PDL_Long neighbour[4]; PDL_Long nfound; PDL_Long pass,count,next,this; PDL_Long *equiv; PDL_Long i1,j1,i2; PDL_Long nx = $SIZE(m); PDL_Long ny = $SIZE(n); if ($COMP(con)!=4 && $COMP(con)!=8) barf("In ccNcompt, connectivity must be 4 or 8, you gave %d",$COMP(con)); loop(n) %{ loop(m) %{ /* Copy */ $b() = $a(); %} %} /* 1st pass counts max possible compts, 2nd records equivalences */ for (pass = 0; pass<2; pass++) { if (pass==1) { equiv = (PDL_Long*) malloc((newlabel+1)*sizeof(PDL_Long)); if (equiv==(PDL_Long*)0) barf("Out of memory"); for(i=0;i<=newlabel;i++) equiv[i]=i; } newlabel = 1; /* Running label */ for(j=0; j0 */ i1 = i-1; j1 = j-1; i2 = i+1; /*West x, North y, East x*/ if ($b(m=>i, n=>j) > 0) { /* Check 4 neighbour already seen */ if (i>0 && $b(m=>i1, n=>j)>0) /*West*/ neighbour[nfound++] = $b(m=>i1, n=>j); /* Store label of it */ if (j>0 && $b(m=>i, n=>j1)>0) /*North*/ neighbour[nfound++] = $b(m=>i, n=>j1); if (j>0 && i>0 && $b(m=>i1, n=>j1)>0 && $COMP(con)==8) /*North-West*/ neighbour[nfound++] = $b(m=>i1, n=>j1); if (j>0 && i<(nx-1) && $b(m=>i2, n=>j1)>0 && $COMP(con)==8) /*North-East*/ neighbour[nfound++] = $b(m=>i2, n=>j1); if (nfound==0) { /* Assign new label */ $b(m=>i, n=>j) = newlabel++; } else { $b(m=>i, n=>j) = neighbour[0]; if (nfound>1 && pass == 1) { /* Assign equivalents */ for(k=1; ki, n=>j), neighbour[k] ); } } } else { /* No label */ $b(m=>i, n=>j) = 0; } }} /* End of image loop */ } /* Passes */ /* Replace each cycle by single label */ count = 0; for (i = 1; i <= newlabel; i++) if ( i <= equiv[i] ) { count++; this = i; while ( equiv[this] != i ) { next = equiv[this]; equiv[this] = count; this = next; } equiv[this] = count; } /* Now remove equivalences */ for(j=0; ji, n=>j) = equiv[ (PDL_Long) $b(m=>i, n=>j) ] ; }} free(equiv); /* Tidy */ '); pp_add_exported('polyfill'); pp_addpm(<<'EOPM'); =head2 polyfill =for ref fill the area of the given polygon with the given colour. This function works inplace, i.e. modifies C. =for usage polyfill($im,$ps,$colour,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L. Often, it includes vertices and edge points. Set the C option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L algorithm =for example # Make a convex 3x3 square of 1s in an image using the pnpoly algorithm $ps = pdl([3,3],[3,6],[6,6],[6,3]); polyfill($im,$ps,1,{'Method' =>'pnpoly'}); =cut sub PDL::polyfill { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfill($im,$ps,$colour,[\%options])') unless @_==3; my ($im,$ps,$colour) = @_; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); if( $parsed->current->{'Method'} eq 'pnpoly' ) { PDL::pnpolyfill_pp($im,$ps,$colour); } } else { PDL::polyfill_pp($im,$ps,$colour); } return $im; } *polyfill = \&PDL::polyfill; EOPM pp_add_exported('', 'pnpoly'); pp_addpm(<<'EOPM'); =head2 pnpoly =for ref 'points in a polygon' selection from a 2-D piddle =for usage $mask = $img->pnpoly($ps); # Old style, do not use $mask = pnpoly($x, $y, $px, $py); For a closed polygon determined by the sequence of points in {$px,$py} the output of pnpoly is a mask corresponding to whether or not each coordinate (x,y) in the set of test points, {$x,$y}, is in the interior of the polygon. This is the 'points in a polygon' algorithm from L and vectorized for PDL by Karl Glazebrook. =for example # define a 3-sided polygon (a triangle) $ps = pdl([3, 3], [20, 20], [34, 3]); # $tri is 0 everywhere except for points in polygon interior $tri = $img->pnpoly($ps); With the second form, the x and y coordinates must also be specified. B< I >. $px = pdl( 3, 20, 34 ); $py = pdl( 3, 20, 3 ); $x = $img->xvals; # get x pixel coords $y = $img->yvals; # get y pixel coords # $tri is 0 everywhere except for points in polygon interior $tri = pnpoly($x,$y,$px,$py); =cut # From: http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html # # Fixes needed to pnpoly code: # # Use topdl() to ensure piddle args # # Add POD docs for usage # # Calculate first term in & expression to use to fix divide-by-zero when # the test point is in line with a vertical edge of the polygon. # By adding the value of $mask we prevent a divide-by-zero since the & # operator does not "short circuit". sub PDL::pnpoly { barf('Usage: $mask = pnpoly($img, $ps);') unless(@_==2 || @_==4); my ($tx, $ty, $vertx, $verty) = @_; # if only two inputs, use the pure PP version unless( defined $vertx ) { barf("ps must contain pairwise points.\n") unless $ty->getdim(0) == 2; # Input mapping: $img => $tx, $ps => $ty return PDL::pnpoly_pp($tx,$ty); } my $testx = PDL::Core::topdl($tx)->dummy(0); my $testy = PDL::Core::topdl($ty)->dummy(0); my $vertxj = PDL::Core::topdl($vertx)->rotate(1); my $vertyj = PDL::Core::topdl($verty)->rotate(1); my $mask = ( ($verty>$testy) == ($vertyj>$testy) ); my $c = sumover( ! $mask & ( $testx < ($vertxj-$vertx) * ($testy-$verty) / ($vertyj-$verty+$mask) + $vertx) ) % 2; return $c; } *pnpoly = \&PDL::pnpoly; EOPM pp_add_exported('', 'polyfillv'); pp_addpm(<<'EOPM'); =head2 polyfillv =for ref return the (dataflown) area of an image described by a polygon =for usage polyfillv($im,$ps,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L. Often, it includes vertices and edge points. Set the C option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L algorithm =for example # increment intensity in area bounded by $poly using the pnpoly algorithm $im->polyfillv($poly,{'Method'=>'pnpoly'})++; # legal in perl >= 5.6 # compute average intensity within area bounded by $poly using the default algorithm $av = $im->polyfillv($poly)->avg; =cut sub PDL::polyfillv :lvalue { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfillv($im,$ps,[\%options])') unless @_==2; my ($im,$ps) = @_; barf("ps must contain pairwise points.\n") unless $ps->getdim(0) == 2; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); return $im->where(PDL::pnpoly_pp($im, $ps)) if $parsed->current->{'Method'} eq 'pnpoly'; } my $msk = zeroes(long,$im->dims); PDL::polyfill_pp($msk, $ps, 1); return $im->where($msk); } *polyfillv = \&PDL::polyfillv; EOPM pp_addhdr('#include "rotate.c"'."\n\n"); pp_add_exported('','rotnewsz'); pp_addxs(' void rotnewsz(m,n,angle) int m int n float angle PPCODE: int newcols, newrows; if (getnewsize(m,n,angle,&newcols,&newrows) != 0) croak("wrong angle (should be between -90 and +90)"); EXTEND(sp,2); PUSHs(sv_2mortal(newSVnv(newcols))); PUSHs(sv_2mortal(newSVnv(newrows))); '); pp_def('rot2d', HandleBad => 0, Pars => 'im(m,n); float angle(); bg(); int aa(); [o] om(p,q)', Code => 'int ierr; if ((ierr = rotate($P(im),$P(om),$SIZE(m),$SIZE(n),$SIZE(p), $SIZE(q),$angle(),$bg(),$aa())) != 0) { if (ierr == -1) croak("error during rotate, wrong angle"); else croak("wrong output dims, did you set them?"); }', # ugly workaround since $SIZE(m) and $SIZE(n) are not initialized # when the redodimscode is called # need to fix this! RedoDimsCode => 'int ncols, nrows; if ($PDL(im)->ndims < 2) croak("need > 2d piddle"); if (getnewsize($PDL(im)->dims[0],$PDL(im)->dims[1], $angle(), &ncols, &nrows) != 0) croak("error during rotate, wrong angle"); /* printf("o: %d, p: %d\n",ncols,nrows); */ $SIZE(p) = ncols; $SIZE(q) = nrows;', GenericTypes => ['B'], Doc => << 'EOD', =for ref rotate an image by given C =for example # rotate by 10.5 degrees with antialiasing, set missing values to 7 $rot = $im->rot2d(10.5,7,1); This function rotates an image through an C between -90 and + 90 degrees. Uses/doesn't use antialiasing depending on the C flag. Pixels outside the rotated image are set to C. Code modified from pnmrotate (Copyright Jef Poskanzer) with an algorithm based on "A Fast Algorithm for General Raster Rotation" by Alan Paeth, Graphics Interface '86, pp. 77-81. Use the C function to find out about the dimension of the newly created image ($newcols,$newrows) = rotnewsz $oldn, $oldm, $angle; L offers a more general interface to distortions, including rotation, with various types of sampling; but rot2d is faster. =cut EOD ); pp_def('bilin2d', HandleBad => 0, Pars => 'I(n,m); O(q,p)', Doc=><<'EOD', =for ref Bilinearly maps the first piddle in the second. The interpolated values are actually added to the second piddle which is supposed to be larger than the first one. =cut EOD , Code =>' int i,j,ii,jj,ii1,jj1,num; double x,y,dx,dy,y1,y2,y3,y4,t,u,sum; if ($SIZE(q)>=$SIZE(n) && $SIZE(p)>=$SIZE(m)) { threadloop %{ dx = ((double) ($SIZE(n)-1)) / ($SIZE(q)-1); dy = ((double) ($SIZE(m)-1)) / ($SIZE(p)-1); for(i=0,x=0;i<$SIZE(q);i++,x+=dx) { for(j=0,y=0;j<$SIZE(p);j++,y+=dy) { ii = (int) floor(x); if (ii>=($SIZE(n)-1)) ii = $SIZE(n)-2; jj = (int) floor(y); if (jj>=($SIZE(m)-1)) jj = $SIZE(m)-2; ii1 = ii+1; jj1 = jj+1; y1 = $I(n=>ii,m=>jj); y2 = $I(n=>ii1,m=>jj); y3 = $I(n=>ii1,m=>jj1); y4 = $I(n=>ii,m=>jj1); t = x-ii; u = y-jj; $O(q=>i,p=>j) += (1-t)*(1-u)*y1 + t*(1-u)*y2 + t*u*y3 + (1-t)*u*y4; } } %} } else { barf("the second matrix must be greater than first! (bilin2d)"); } '); pp_def('rescale2d', HandleBad => 0, Pars => 'I(m,n); O(p,q)', Doc=><<'EOD', =for ref The first piddle is rescaled to the dimensions of the second (expanding or meaning values as needed) and then added to it in place. Nothing useful is returned. If you want photometric accuracy or automatic FITS header metadata tracking, consider using L instead: it does these things, at some speed penalty compared to rescale2d. =cut EOD , Code =>' int ix,iy,ox,oy,i,j,lx,ly,cx,cy,xx,yy,num; double kx,ky,temp; ix = $SIZE(m); iy = $SIZE(n); ox = $SIZE(p); oy = $SIZE(q); if(ox >= ix && oy >= iy) { threadloop %{ kx = ((double) (ox)) / (ix); ky = ((double) (oy)) / (iy); lx = 0; for(i=0;ixx,q=>yy) += $I(m=>i,n=>j); } ly = cy + 1; } lx = cx + 1; } %} } else if(ox < ix && oy < iy) { threadloop %{ kx = ((double) (ix)) / (ox); ky = ((double) (iy)) / (oy); lx = 0; for(i=0;iyy,m=>xx); num++; } $O(p=>i,q=>j) += temp/num; ly = cy + 1; } lx = cx + 1; } %} } else if(ox >= ix && oy < iy) { threadloop %{ kx = ((double) (ox)) / (ix); ky = ((double) (iy)) / (oy); lx = 0; for(i=0;iyy,m=>i); num++; } for(xx=lx;xx<=cx;xx++) { /* fprintf(stderr,"2 i: %d, j: %d, xx: %d, yy: %d\n",i,j,xx,yy); */ $O(p=>xx,q=>j) += temp/num; } ly = cy + 1; } lx = cx + 1; } %} } else if(ox < ix && oy >= iy) { threadloop %{ kx = ((double) (ix)) / (ox); ky = ((double) (oy)) / (iy); lx = 0; for(i=0;ij,m=>xx); num++; } for(yy=ly;yy<=cy;yy++) { /* fprintf(stderr,"2 i: %d, j: %d, xx: %d, yy: %d\n",i,j,xx,yy); */ $O(p=>i,q=>yy) += temp/num; } ly = cy + 1; } lx = cx + 1; } %} } else barf("I am not supposed to be here, please report the bug to "); '); # functions to make handling 2D polynomial mappings a bit easier # pp_add_exported('', 'fitwarp2d applywarp2d'); pp_addpm( ' =head2 fitwarp2d =for ref Find the best-fit 2D polynomial to describe a coordinate transformation. =for usage ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, $nf. { options } ) Given a set of points in the output plane (C<$u,$v>), find the best-fit (using singular-value decomposition) 2D polynomial to describe the mapping back to the image plane (C<$x,$y>). The order of the fit is controlled by the C<$nf> parameter (the maximum power of the polynomial is C<$nf - 1>), and you can restrict the terms to fit using the C option. C<$px> and C<$py> are C by C element piddles which describe a polynomial mapping (of order C) from the I C<(u,v)> image to the I C<(x,y)> image: x = sum(j=0,np-1) sum(i=0,np-1) px(i,j) * u^i * v^j y = sum(j=0,np-1) sum(i=0,np-1) py(i,j) * u^i * v^j The transformation is returned for the reverse direction (ie output to input image) since that is what is required by the L routine. The L routine can be used to convert a set of C<$u,$v> points given C<$px> and C<$py>. Options: =for options FIT - which terms to fit? default ones(byte,$nf,$nf) THRESH - in svd, remove terms smaller than THRESH * max value default is 1.0e-5 =over 4 =item FIT C allows you to restrict which terms of the polynomial to fit: only those terms for which the FIT piddle evaluates to true will be evaluated. If a 2D piddle is sent in, then it is used for the x and y polynomials; otherwise C<$fit-Eslice(":,:,(0)")> will be used for C<$px> and C<$fit-Eslice(":,:,(1)")> will be used for C<$py>. =item THRESH Remove all singular values whose valus is less than C times the largest singular value. =back The number of points must be at least equal to the number of terms to fit (C<$nf*$nf> points for the default value of C). =for example # points in original image $x = pdl( 0, 0, 100, 100 ); $y = pdl( 0, 100, 100, 0 ); # get warped to these positions $u = pdl( 10, 10, 90, 90 ); $v = pdl( 10, 90, 90, 10 ); # # shift of origin + scale x/y axis only $fit = byte( [ [1,1], [0,0] ], [ [1,0], [1,0] ] ); ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2, { FIT => $fit } ); print "px = ${px}py = $py"; px = [ [-12.5 1.25] [ 0 0] ] py = [ [-12.5 0] [ 1.25 0] ] # # Compared to allowing all 4 terms ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2 ); print "px = ${px}py = $py"; px = [ [ -12.5 1.25] [ 1.110223e-16 -1.1275703e-17] ] py = [ [ -12.5 1.6653345e-16] [ 1.25 -5.8546917e-18] ] =head2 applywarp2d =for ref Transform a set of points using a 2-D polynomial mapping =for usage ( $x, $y ) = applywarp2d( $px, $py, $u, $v ) Convert a set of points (stored in 1D piddles C<$u,$v>) to C<$x,$y> using the 2-D polynomial with coefficients stored in C<$px> and C<$py>. See L for more information on the format of C<$px> and C<$py>. =cut # use SVD to fit data. Assuming no errors. sub _svd ($$$) { my $basis = shift; my $y = shift; my $thresh = shift; # if we had errors for these points, would normalise the # basis functions, and the output array, by these errors here # perform the SVD my ( $svd_u, $svd_w, $svd_v ) = svd( $basis ); # remove any singular values $svd_w *= ( $svd_w >= ($svd_w->max * $thresh ) ); # perform the back substitution # my $tmp = $y x $svd_u; if ( $PDL::Bad::Status ) { $tmp /= $svd_w->setvaltobad(0.0); $tmp->inplace->setbadtoval(0.0); } else { # not checked my $mask = ($svd_w == 0.0); $tmp /= ( $svd_w + $mask ); $tmp *= ( 1 - $mask ); } my $ans = sumover( $svd_v * $tmp ); return $ans; } # sub: _svd() sub _mkbasis ($$$$) { my $fit = shift; my $npts = shift; my $u = shift; my $v = shift; my $n = $fit->getdim(0) - 1; my $ncoeff = sum( $fit ); my $basis = zeroes( $u->type, $ncoeff, $npts ); my $k = 0; foreach my $j ( 0 .. $n ) { my $tmp_v = $v**$j; foreach my $i ( 0 .. $n ) { if ( $fit->at($i,$j) ) { my $tmp = $basis->slice("($k),:"); $tmp .= $tmp_v * $u**$i; $k++; } } } return $basis; } # sub: _mkbasis() sub PDL::fitwarp2d { croak "Usage: (\$px,\$py) = fitwarp2d(x(m);y(m);u(m);v(m);\$nf; { options })" if $#_ < 4 or ( $#_ >= 5 and ref($_[5]) ne "HASH" ); my $x = shift; my $y = shift; my $u = shift; my $v = shift; my $nf = shift; my $opts = PDL::Options->new( { FIT => ones(byte,$nf,$nf), THRESH => 1.0e-5 } ); $opts->options( $_[0] ) if $#_ > -1; my $oref = $opts->current(); # safety checks my $npts = $x->nelem; croak "fitwarp2d: x, y, u, and v must be the same size (and 1D)" unless $npts == $y->nelem and $npts == $u->nelem and $npts == $v->nelem and $x->getndims == 1 and $y->getndims == 1 and $u->getndims == 1 and $v->getndims == 1; my $svd_thresh = $$oref{THRESH}; croak "fitwarp2d: THRESH option must be >= 0." if $svd_thresh < 0; my $fit = $$oref{FIT}; my $fit_ndim = $fit->getndims(); croak "fitwarp2d: FIT option must be sent a (\$nf,\$nf[,2]) element piddle" unless UNIVERSAL::isa($fit,"PDL") and ($fit_ndim == 2 or ($fit_ndim == 3 and $fit->getdim(2) == 2)) and $fit->getdim(0) == $nf and $fit->getdim(1) == $nf; # how many coeffs to fit (first we ensure $fit is either 0 or 1) $fit = convert( $fit != 0, byte ); my ( $fitx, $fity, $ncoeffx, $ncoeffy, $ncoeff ); if ( $fit_ndim == 2 ) { $fitx = $fit; $fity = $fit; $ncoeff = $ncoeffx = $ncoeffy = sum( $fit ); } else { $fitx = $fit->slice(",,(0)"); $fity = $fit->slice(",,(1)"); $ncoeffx = sum($fitx); $ncoeffy = sum($fity); $ncoeff = $ncoeffx > $ncoeffy ? $ncoeffx : $ncoeffy; } croak "fitwarp2d: number of points must be >= \$ncoeff" unless $npts >= $ncoeff; # create the basis functions for the SVD fitting my ( $basisx, $basisy ); $basisx = _mkbasis( $fitx, $npts, $u, $v ); if ( $fit_ndim == 2 ) { $basisy = $basisx; } else { $basisy = _mkbasis( $fity, $npts, $u, $v ); } my $px = _svd( $basisx, $x, $svd_thresh ); my $py = _svd( $basisy, $y, $svd_thresh ); # convert into $nf x $nf element piddles, if necessary my $nf2 = $nf * $nf; return ( $px->reshape($nf,$nf), $py->reshape($nf,$nf) ) if $ncoeff == $nf2 and $ncoeffx == $ncoeffy; # re-create the matrix my $xtmp = zeroes( $nf, $nf ); my $ytmp = zeroes( $nf, $nf ); my $kx = 0; my $ky = 0; foreach my $i ( 0 .. ($nf - 1) ) { foreach my $j ( 0 .. ($nf - 1) ) { if ( $fitx->at($i,$j) ) { $xtmp->set($i,$j, $px->at($kx) ); $kx++; } if ( $fity->at($i,$j) ) { $ytmp->set($i,$j, $py->at($ky) ); $ky++; } } } return ( $xtmp, $ytmp ) } # sub: fitwarp2d *fitwarp2d = \&PDL::fitwarp2d; sub PDL::applywarp2d { # checks croak "Usage: (\$x,\$y) = applywarp2d(px(nf,nf);py(nf,nf);u(m);v(m);)" if $#_ != 3; my $px = shift; my $py = shift; my $u = shift; my $v = shift; my $npts = $u->nelem; # safety check croak "applywarp2d: u and v must be the same size (and 1D)" unless $npts == $u->nelem and $npts == $v->nelem and $u->getndims == 1 and $v->getndims == 1; my $nf = $px->getdim(0); my $nf2 = $nf * $nf; # could remove terms with 0 coeff here # (would also have to remove them from px/py for # the matrix multiplication below) # my $mat = _mkbasis( ones(byte,$nf,$nf), $npts, $u, $v ); my $x = reshape( $mat x $px->clump(-1)->transpose(), $npts ); my $y = reshape( $mat x $py->clump(-1)->transpose(), $npts ); return ( $x, $y ); } # sub: applywarp2d *applywarp2d = \&PDL::applywarp2d; ' ); ## resampling routines taken from v3.6-0 of the Eclipse package ## http://www.eso.org/eclipse by Nicolas Devillard ## pp_addhdr( '#include "resample.h"' . "\n" ); # pod for warp2d # and support routine # pp_addpm( <<'EOD'); =head2 warp2d =for sig Signature: (img(m,n); double px(np,np); double py(np,np); [o] warp(m,n); { options }) =for ref Warp a 2D image given a polynomial describing the I mapping. =for usage $out = warp2d( $img, $px, $py, { options } ); Apply the polynomial transformation encoded in the C<$px> and C<$py> piddles to warp the input image C<$img> into the output image C<$out>. The format for the polynomial transformation is described in the documentation for the L routine. At each point C, the closest 16 pixel values are combined with an interpolation kernel to calculate the value at C. The interpolation is therefore done in the image, rather than Fourier, domain. By default, a C kernel is used, but this can be changed using the C option discussed below (the choice of kernel depends on the frequency content of the input image). The routine is based on the C command from the Eclipse data-reduction package - see http://www.eso.org/eclipse/ - and for further details on image resampling see Wolberg, G., "Digital Image Warping", 1990, IEEE Computer Society Press ISBN 0-8186-8944-7). Currently the output image is the same size as the input one, which means data will be lost if the transformation reduces the pixel scale. This will (hopefully) be changed soon. =for example $img = rvals(byte,501,501); imag $img, { JUSTIFY => 1 }; # # use a not-particularly-obvious transformation: # x = -10 + 0.5 * $u - 0.1 * $v # y = -20 + $v - 0.002 * $u * $v # $px = pdl( [ -10, 0.5 ], [ -0.1, 0 ] ); $py = pdl( [ -20, 0 ], [ 1, 0.002 ] ); $wrp = warp2d( $img, $px, $py ); # # see the warped image imag $warp, { JUSTIFY => 1 }; The options are: =for options KERNEL - default value is tanh NOVAL - default value is 0 C is used to specify which interpolation kernel to use (to see what these kernels look like, use the L routine). The options are: =over 4 =item tanh Hyperbolic tangent: the approximation of an ideal box filter by the product of symmetric tanh functions. =item sinc For a correctly sampled signal, the ideal filter in the fourier domain is a rectangle, which produces a C interpolation kernel in the spatial domain: sinc(x) = sin(pi * x) / (pi * x) However, it is not ideal for the C<4x4> pixel region used here. =item sinc2 This is the square of the sinc function. =item lanczos Although defined differently to the C kernel, the result is very similar in the spatial domain. The Lanczos function is defined as L(x) = sinc(x) * sinc(x/2) if abs(x) < 2 = 0 otherwise =item hann This kernel is derived from the following function: H(x) = a + (1-a) * cos(2*pi*x/(N-1)) if abs(x) < 0.5*(N-1) = 0 otherwise with C and N currently equal to 2001. =item hamming This kernel uses the same C as the Hann filter, but with C. =back C gives the value used to indicate that a pixel in the output image does not map onto one in the input image. =cut # support routine { my %warp2d = map { ($_,1) } qw( tanh sinc sinc2 lanczos hamming hann ); # note: convert to lower case sub _check_kernel ($$) { my $kernel = lc shift; my $code = shift; barf "Unknown kernel $kernel sent to $code\n" . "\tmust be one of [" . join(',',keys %warp2d) . "]\n" unless exists $warp2d{$kernel}; return $kernel; } } EOD pp_def( 'warp2d', Doc=> undef, HandleBad => 0, Pars => 'img(m,n); double px(np,np); double py(np,np); [o] warp(m,n);', OtherPars => 'char *kernel_type; double noval;', GenericTypes => [ 'F', 'D' ], PMCode => ' sub PDL::warp2d { my $opts = PDL::Options->new( { KERNEL => "tanh", NOVAL => 0 } ); $opts->options( pop(@_) ) if ref($_[$#_]) eq "HASH"; die "Usage: warp2d( in(m,n), px(np,np); py(np,np); [o] out(m,n), {Options} )" if $#_<2 || $#_>3; my $img = shift; my $px = shift; my $py = shift; my $out = $#_ == -1 ? PDL->null() : shift; # safety checks my $copt = $opts->current(); my $kernel = _check_kernel( $$copt{KERNEL}, "warp2d" ); &PDL::_warp2d_int( $img, $px, $py, $out, $kernel, $$copt{NOVAL} ); return $out; } ', Code => ' int i, j, k ; int ncoeff, lx_out, ly_out ; int lx_3, ly_3 ; double cur ; double neighbors[16] ; double rsc[8], sumrs ; double x, y ; int px, py ; int tabx, taby ; double *kernel, *poly ; int da[16], db[16] ; /* Generate default interpolation kernel */ kernel = generate_interpolation_kernel( $COMP(kernel_type) ) ; if (kernel == NULL) { croak( "Ran out of memory building kernel\n" ); } /* Compute sizes */ ncoeff = $SIZE(np); lx_out = $SIZE(m); /* is this right? */ ly_out = $SIZE(n); lx_3 = lx_out - 3; ly_3 = ly_out - 3; /* Pre compute leaps for 16 closest neighbors positions */ da[0] = -1; db[0] = -1; da[1] = 0; db[1] = -1; da[2] = 1; db[2] = -1; da[3] = 2; db[3] = -1; da[4] = -1; db[4] = 0; da[5] = 0; db[5] = 0; da[6] = 1; db[6] = 0; da[7] = 2; db[7] = 0; da[8] = -1; db[8] = 1; da[9] = 0; db[9] = 1; da[10] = 1; db[10] = 1; da[11] = 2; db[11] = 1; da[12] = -1; db[12] = 2; da[13] = 0; db[13] = 2; da[14] = 1; db[14] = 2; da[15] = 2; db[15] = 2; /* allocate memory for polynomial */ poly = malloc( ncoeff * sizeof(double) ); if ( poly == NULL ) { croak( "Ran out of memory\n" ); } poly[0] = 1.0; /* Loop over the output image */ threadloop %{ loop(n) %{ /* fill in poly array */ for ( k = 1; k < ncoeff; k++ ) { poly[k] = (double) n * poly[k-1]; } loop(m) %{ /* Compute the original source for this pixel */ x = poly2d_compute( ncoeff, $P(px), (double) m, poly ); y = poly2d_compute( ncoeff, $P(py), (double) m, poly ); /* Which is the closest integer positioned neighbor? */ px = (int)x ; py = (int)y ; if ((px < 1) || (px > lx_3) || (py < 1) || (py > ly_3)) $warp() = ($GENERIC()) $COMP(noval); else { /* Now feed the positions for the closest 16 neighbors */ for (k=0 ; k<16 ; k++) { i = px + da[k]; j = py + db[k]; neighbors[k] = (double) $img( m => i, n => j ); } /* Which tabulated value index shall we use? */ tabx = (x - (double)px) * (double)(TABSPERPIX) ; taby = (y - (double)py) * (double)(TABSPERPIX) ; /* Compute resampling coefficients */ /* rsc[0..3] in x, rsc[4..7] in y */ rsc[0] = kernel[TABSPERPIX + tabx] ; rsc[1] = kernel[tabx] ; rsc[2] = kernel[TABSPERPIX - tabx] ; rsc[3] = kernel[2 * TABSPERPIX - tabx] ; rsc[4] = kernel[TABSPERPIX + taby] ; rsc[5] = kernel[taby] ; rsc[6] = kernel[TABSPERPIX - taby] ; rsc[7] = kernel[2 * TABSPERPIX - taby] ; sumrs = (rsc[0]+rsc[1]+rsc[2]+rsc[3]) * (rsc[4]+rsc[5]+rsc[6]+rsc[7]) ; /* Compute interpolated pixel now */ cur = rsc[4] * ( rsc[0]*neighbors[0] + rsc[1]*neighbors[1] + rsc[2]*neighbors[2] + rsc[3]*neighbors[3] ) + rsc[5] * ( rsc[0]*neighbors[4] + rsc[1]*neighbors[5] + rsc[2]*neighbors[6] + rsc[3]*neighbors[7] ) + rsc[6] * ( rsc[0]*neighbors[8] + rsc[1]*neighbors[9] + rsc[2]*neighbors[10] + rsc[3]*neighbors[11] ) + rsc[7] * ( rsc[0]*neighbors[12] + rsc[1]*neighbors[13] + rsc[2]*neighbors[14] + rsc[3]*neighbors[15] ) ; /* Copy the value to the output image */ $warp() = ($GENERIC()) (cur/sumrs); } /* if: edge or interior */ %} /* loop(m) */ %} /* loop(n) */ %} /* threadloop */ free(poly); free(kernel) ; ', ); # pp_def: warp2d pp_addxs( ' int _get_kernel_size() PROTOTYPE: CODE: RETVAL = KERNEL_SAMPLES; OUTPUT: RETVAL '); pp_add_exported('', 'warp2d_kernel'); pp_addpm( ' =head2 warp2d_kernel =for ref Return the specified kernel, as used by L =for usage ( $x, $k ) = warp2d_kernel( $name ) The valid values for C<$name> are the same as the C option of L. =for example line warp2d_kernel( "hamming" ); =cut '); # pp_addpm # this is not very clever, but it's a pain to create a valid # piddle in XS code # pp_def( 'warp2d_kernel', Doc => undef, HandleBad => 0, PMCode => ' sub PDL::warp2d_kernel ($) { my $kernel = _check_kernel( shift, "warp2d_kernel" ); my $nelem = _get_kernel_size(); my $x = zeroes( $nelem ); my $k = zeroes( $nelem ); &PDL::_warp2d_kernel_int( $x, $k, $kernel ); return ( $x, $k ); # return _get_kernel( $kernel ); } *warp2d_kernel = \&PDL::warp2d_kernel; ', Pars => '[o] x(n); [o] k(n);', OtherPars => 'char *name;', GenericTypes => [ 'D' ], Code => ' double *kernel, xx; if ( $SIZE(n) != KERNEL_SAMPLES ) { croak( "Internal error in warp2d_kernel - mismatch in kernel size\n" ); } kernel = generate_interpolation_kernel($COMP(name)); if ( kernel == NULL ) { croak( "unable to allocate memory for kernel" ); } /* fill in piddles */ xx = 0.0; threadloop %{ loop (n) %{ $x() = xx; $k() = kernel[n]; xx += 1.0 / (double) TABSPERPIX; %} %} /* free the kernel */ free( kernel ); '); # pp_addpm pp_done(); PDL-2.018/Lib/Image2D/Makefile.PL0000644060175006010010000000145612562522364014301 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["image2d.pd", qw(Image2D PDL::Image2D)]); my %hash = pdlpp_stdargs_int( @pack ); $hash{LIBS} = [ '-lm' ]; # On windows we do not have an rint function (at least on VC++) # Should do a proper test for rint similar to that done for # PDL::Math. For now, simply test architecture if ($^O =~ /MSWin/i) { $hash{DEFINE} = " -DNEEDS_RINT"; } # what code do we want compiled and linked in? # rotate.c is included directly into image2d.pd # # for $file ( qw( rotate resample ) ) { for my $file ( qw( resample ) ) { my $n = "$file\$(OBJ_EXT)"; $hash{OBJECT} .= " $n"; $hash{clean}{FILES} .= " $n"; } # Add genpp rule undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile( %hash ); PDL-2.018/Lib/Image2D/resample.c0000644060175006010010000002220212562522364014273 0ustar chmNone/* * resample.c * - a hacked version of * ipow.c, poly2d.c, and resampling.c * from version 3.6-0 of the Eclipse library (ESO) * by Nicolas Devillard * * see http://www.eso.org/eclipse for further details */ #include "resample.h" /*-------------------------------------------------------------------------*/ /** @name ipow @memo Same as pow(x,y) but for integer values of y only (faster). @param x A double number. @param p An integer power. @return x to the power p. @doc This is much faster than the math function due to the integer. Some compilers make this optimization already, some do not. p can be positive, negative or null. */ /*--------------------------------------------------------------------------*/ double ipow(double x, int p) { double r, recip ; /* Get rid of trivial cases */ switch (p) { case 0: return 1.00 ; case 1: return x ; case 2: return x*x ; case 3: return x*x*x ; case -1: return 1.00 / x ; case -2: return (1.00 / x) * (1.00 / x) ; } if (p>0) { r = x ; while (--p) r *= x ; } else { r = recip = 1.00 / x ; while (++p) r *= recip ; } return r; } /* * compute the value of a 2D polynomial at a point * - it assumes that ncoeff is a small number, so there's * little point in pre-calculating ipow(u,i) */ double poly2d_compute( int ncoeff, double *c, double u, double *vpow ) { double out; int i, j, k; out = 0.00; k = 0; for( j = 0; j < ncoeff; j++ ) { for( i = 0; i < ncoeff; i++ ) { out += c[k] * ipow( u, i ) * vpow[j]; k++; } } return out; } /*-------------------------------------------------------------------------*/ /** @name sinc @memo Cardinal sine. @param x double value. @return 1 double. @doc Compute the value of the function sinc(x)=sin(pi*x)/(pi*x) at the requested x. */ /*--------------------------------------------------------------------------*/ double sinc(double x) { if (fabs(x)<1e-4) return (double)1.00 ; else return ((sin(x * (double)PI_NUMB)) / (x * (double)PI_NUMB)) ; } /* sinc() */ /** @name reverse_tanh_kernel @memo Bring a hyperbolic tangent kernel from Fourier to normal space. @param data Kernel samples in Fourier space. @param nn Number of samples in the input kernel. @return void @doc Bring back a hyperbolic tangent kernel from Fourier to normal space. Do not try to understand the implementation and DO NOT MODIFY THIS FUNCTION. */ /*--------------------------------------------------------------------------*/ #define KERNEL_SW(a,b) tempr=(a);(a)=(b);(b)=tempr static void reverse_tanh_kernel(double * data, int nn) { unsigned long n, mmax, m, i, j, istep ; double wtemp, wr, wpr, wpi, wi, theta; double tempr, tempi; n = (unsigned long)nn << 1; j = 1; for (i=1 ; i i) { KERNEL_SW(data[j-1],data[i-1]); KERNEL_SW(data[j],data[i]); } m = n >> 1; while (m>=2 && j>m) { j -= m; m >>= 1; } j += m; } mmax = 2; while (n > mmax) { istep = mmax << 1; theta = 2 * M_PI / mmax; wtemp = sin(0.5 * theta); wpr = -2.0 * wtemp * wtemp; wpi = sin(theta); wr = 1.0; wi = 0.0; for (m=1 ; m #include #include #ifndef NULL #define NULL (0L) #endif /* Number of tabulations in kernel */ #define TABSPERPIX (1000) #define KERNEL_WIDTH (2.0) #define KERNEL_SAMPLES (1+(int)(TABSPERPIX * KERNEL_WIDTH)) #define TANH_STEEPNESS (5.0) #ifndef PI_NUMB #define PI_NUMB (3.1415926535897932384626433832795) #endif #ifndef M_PI #define M_PI PI_NUMB #endif /* declare functions */ double poly2d_compute( int ncoeff, double *c, double u, double *vpow ); double * generate_interpolation_kernel(char * kernel_type); #endif PDL-2.018/Lib/Image2D/rotate.c0000644060175006010010000001533412562522364013771 0ustar chmNone/* rotate.c - code modified from pnmrotate.c which included the following copyright notice */ /* pnmrotate.c - read a portable anymap and rotate it by some angle ** ** Copyright (C) 1989, 1991 by Jef Poskanzer. ** ** Permission to use, copy, modify, and distribute this software and its ** documentation for any purpose and without fee is hereby granted, provided ** that the above copyright notice appear in all copies and that both that ** copyright notice and this permission notice appear in supporting ** documentation. This software is provided "as is" without express or ** implied warranty. */ #include #include #ifndef M_PI #define M_PI 3.14159265358979323846 #endif /*M_PI*/ #define SCALE 4096 #define HALFSCALE 2048 typedef unsigned char imT; /* image type */ static imT* my_allocarray(int cols, int rows) { imT *arr = NULL; if ((arr = malloc(sizeof(imT)*cols*rows)) == NULL) croak("error getting memory for temporary array"); return arr; } int getnewsize(int cols, int rows, float fangle, int *newcols, int *newrows) { float xshearfac, yshearfac, new0; int tempcols, yshearjunk, x2shearjunk; if ( fangle < -90.0 || fangle > 90.0 ) /* error( "angle must be between -90 and 90 degrees" ); */ return -1; fangle = fangle * M_PI / 180.0; /* convert to radians */ xshearfac = tan( fangle / 2.0 ); if ( xshearfac < 0.0 ) xshearfac = -xshearfac; yshearfac = sin( fangle ); if ( yshearfac < 0.0 ) yshearfac = -yshearfac; tempcols = rows * xshearfac + cols + 0.999999; yshearjunk = ( tempcols - cols ) * yshearfac; *newrows = tempcols * yshearfac + rows + 0.999999; x2shearjunk = ( *newrows - rows - yshearjunk ) * xshearfac; *newrows -= 2 * yshearjunk; *newcols = *newrows * xshearfac + tempcols + 0.999999 - 2 * x2shearjunk; /* printf("oldrows: %d, oldcols: %d\n",rows,cols); printf("newrows: %d, newcols: %d\n",*newrows,*newcols); */ return 0; /* OK */ } int rotate(imT *im, imT *out, int cols, int rows, int nc, int nr, float fangle, imT bgval, int antialias) { float xshearfac, yshearfac, new0; int intnew0; imT *xelrow, *newxelrow, *temp1xels, *temp2xels, *nxP, *xP, prevxel, x; int tempcols, newcols, yshearjunk, x2shearjunk, row, col, new, newrows; register long fracnew0, omfracnew0; /* other angles should do a simple multiple of 90 degrees rotate before calling this one */ if ( fangle < -90.0 || fangle > 90.0 ) /* error( "angle must be between -90 and 90 degrees" ); */ return -1; fangle = fangle * M_PI / 180.0; /* convert to radians */ xshearfac = tan( fangle / 2.0 ); if ( xshearfac < 0.0 ) xshearfac = -xshearfac; yshearfac = sin( fangle ); if ( yshearfac < 0.0 ) yshearfac = -yshearfac; tempcols = rows * xshearfac + cols + 0.999999; yshearjunk = ( tempcols - cols ) * yshearfac; newrows = tempcols * yshearfac + rows + 0.999999; x2shearjunk = ( newrows - rows - yshearjunk ) * xshearfac; newrows -= 2 * yshearjunk; newcols = newrows * xshearfac + tempcols + 0.999999 - 2 * x2shearjunk; /* check that the output has the right size */ if (nc != newcols || nr != newrows) return -2; /* First shear X into temp1xels. */ temp1xels = my_allocarray( tempcols, rows ); for ( row = 0; row < rows; ++row ) { xelrow = im + row * cols; /* current row to process */ if ( fangle > 0 ) new0 = row * xshearfac; else new0 = ( rows - row ) * xshearfac; intnew0 = (int) new0; if ( antialias ) { fracnew0 = ( new0 - intnew0 ) * SCALE; omfracnew0 = SCALE - fracnew0; for ( col = 0, nxP = temp1xels+row*tempcols; col < tempcols; ++col, ++nxP ) *nxP = bgval; prevxel = bgval; for ( col = 0, nxP = temp1xels+row*tempcols+intnew0, xP = xelrow; col < cols; ++col, ++nxP, ++xP ) { *nxP = (fracnew0 * prevxel + omfracnew0 * *xP + HALFSCALE ) / SCALE; prevxel = *xP; } if ( fracnew0 > 0 && intnew0 + cols < tempcols ) { *nxP = ( fracnew0 * prevxel + omfracnew0 * bgval + HALFSCALE ) / SCALE; } } else { for ( col = 0, nxP = temp1xels+row*tempcols; col < intnew0; ++col, ++nxP ) *nxP = bgval; for ( col = 0, xP = xelrow; col < cols; ++col, ++nxP, ++xP ) *nxP = *xP; for ( col = intnew0 + cols; col < tempcols; ++col, ++nxP ) *nxP = bgval; } } /* Now inverse shear Y from temp1 into temp2. */ temp2xels = my_allocarray( tempcols, newrows ); for ( col = 0; col < tempcols; ++col ) { if ( fangle > 0 ) new0 = ( tempcols - col ) * yshearfac; else new0 = col * yshearfac; intnew0 = (int) new0; fracnew0 = ( new0 - intnew0 ) * SCALE; omfracnew0 = SCALE - fracnew0; intnew0 -= yshearjunk; for ( row = 0; row < newrows; ++row ) temp2xels[row*tempcols+col] = bgval; if ( antialias ) { prevxel = bgval; for ( row = 0; row < rows; ++row ) { new = row + intnew0; if ( new >= 0 && new < newrows ) { nxP = temp2xels+new*tempcols+col; x = temp1xels[row*tempcols+col]; *nxP = ( fracnew0 * prevxel + omfracnew0 * x + HALFSCALE ) / SCALE; prevxel = x; } } if ( fracnew0 > 0 && intnew0 + rows < newrows ) { nxP = temp2xels+(intnew0 + rows)*tempcols+col; *nxP = ( fracnew0 * prevxel + omfracnew0 * bgval + HALFSCALE ) / SCALE ; } } else { for ( row = 0; row < rows; ++row ) { new = row + intnew0; if ( new >= 0 && new < newrows ) temp2xels[new*tempcols+col] = temp1xels[row*tempcols+col]; } } } free(temp1xels); for ( row = 0; row < newrows; ++row ) { newxelrow = out + row*newcols;; if ( fangle > 0 ) new0 = row * xshearfac; else new0 = ( newrows - row ) * xshearfac; intnew0 = (int) new0; fracnew0 = ( new0 - intnew0 ) * SCALE; omfracnew0 = SCALE - fracnew0; intnew0 -= x2shearjunk; for ( col = 0, nxP = newxelrow; col < newcols; ++col, ++nxP ) *nxP = bgval; if ( antialias ) { prevxel = bgval; for ( col = 0, xP = temp2xels+row*tempcols; col < tempcols; ++col, ++xP ) { new = intnew0 + col; if ( new >= 0 && new < newcols ) { nxP = &(newxelrow[new]); *nxP = ( fracnew0 * prevxel + omfracnew0 * *xP + HALFSCALE ) / SCALE; prevxel = *xP; } } if ( fracnew0 > 0 && intnew0 + tempcols < newcols ) { nxP = &(newxelrow[intnew0 + tempcols]); *nxP = ( fracnew0 * prevxel + omfracnew0 * bgval + HALFSCALE ) / SCALE; } } else { for ( col = 0, xP = temp2xels+row*tempcols; col < tempcols; ++col, ++xP ) { new = intnew0 + col; if ( new >= 0 && new < newcols ) newxelrow[new] = *xP; } } } free(temp2xels); return 0; /* OK */ } PDL-2.018/Lib/ImageND/0000755060175006010010000000000013110402045012334 5ustar chmNonePDL-2.018/Lib/ImageND/imagend.pd0000644060175006010010000005422212562522364014313 0ustar chmNone pp_addpm({At=>'Top'},<<'EOD'); =head1 NAME PDL::ImageND - useful image processing in N dimensions =head1 DESCRIPTION These routines act on PDLs as N-dimensional objects, not as threaded sets of 0-D or 1-D objects. The file is sort of a catch-all for broadly functional routines, most of which could legitimately be filed elsewhere (and probably will, one day). ImageND is not a part of the PDL core (v2.4) and hence must be explicitly loaded. =head1 SYNOPSIS use PDL::ImageND; $b = $a->convolveND($kernel,{bound=>'periodic'}); $b = $a->rebin(50,30,10); =cut EOD pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHORS Copyright (C) Karl Glazebrook and Craig DeForest, 1997, 2003 All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD # N-dim utilities pp_addhdr(' /* Compute offset of (x,y,z,...) position in row-major list */ PDL_Indx ndim_get_offset(PDL_Indx* pos, PDL_Indx* dims, PDL_Long ndims) { PDL_Long i; PDL_Indx result,size; size = 1; result = 0; for (i=0; i0) size = size*dims[i-1]; result = result + pos[i]*size; } return result; } /* Increrement a position pointer array by one row */ void ndim_row_plusplus ( PDL_Indx* pos, PDL_Indx* dims, PDL_Long ndims ) { PDL_Long noescape; PDL_Indx i; i=1; noescape=1; while(noescape) { (pos[i])++; if (pos[i]==dims[i]) { /* Carry */ if (i>=(ndims)-1) { noescape = 0; /* Exit */ }else{ pos[i]=0; i++; } }else{ noescape = 0; /* Exit */ } } } '); pp_addpm(<<'EOD'); use Carp; EOD pp_add_exported('','kernctr'); pp_def('convolve',Doc=><<'EOD', =for ref N-dimensional convolution (Deprecated; use convolveND) =for usage $new = convolve $a, $kernel Convolve an array with a kernel, both of which are N-dimensional. This routine does direct convolution (by copying) but uses quasi-periodic boundary conditions: each dim "wraps around" to the next higher row in the next dim. This routine is kept for backwards compatibility with earlier scripts; for most purposes you want L instead: it runs faster and handles a variety of boundary conditions. =cut EOD Pars => 'a(m); b(n); indx adims(p); indx bdims(q); [o]c(m);', PMCode => ' # Custom Perl wrapper sub PDL::convolve{ my($a,$b,$c) = @_; barf("Usage: convolve(a(*), b(*), [o]c(*)") if $#_<1 || $#_>2; $c = PDL->null if $#_<2; &PDL::_convolve_int( $a->clump(-1), $b->clump(-1), long([$a->dims]), long([$b->dims]), ($c->getndims>1? $c->clump(-1) : $c) ); $c->setdims([$a->dims]); if($a->is_inplace) { $a .= $c; $a->set_inplace(0); return $a; } return $c; } ', Code => ' PDL_Indx *dimsa = $P(adims); PDL_Indx *dimsb = $P(bdims); PDL_Indx andims = $SIZE(p); PDL_Indx bndims = $SIZE(q); PDL_Indx anvals = $SIZE(m); PDL_Indx bnvals = $SIZE(n); PDL_Indx *pos,*off; double cc; PDL_Indx i,i2,j,k,n,offcen,cen,ncen,nrow; if (andims != bndims) barf("Arguments do not have the same dimensionality"); for(i=0; idimsa[i]) barf("Second argument must be smaller in all dimensions that first" ); pos = (PDL_Indx*) malloc( andims * sizeof(PDL_Indx) ); /* Init pos[] */ if (pos==NULL) barf("Out of Memory\n"); for (i=0; i i2 ) * $b(n=>j) ; } $c(m=>i) = cc; } free(pos); free(off); '); pp_add_exported('',"ninterpol"); pp_addpm(<<'EOD'); =head2 ninterpol() =for ref N-dimensional interpolation routine =for sig Signature: ninterpol(point(),data(n),[o]value()) =for usage $value = ninterpol($point, $data); C uses C to find a linearly interpolated value in N dimensions, assuming the data is spread on a uniform grid. To use an arbitrary grid distribution, need to find the grid-space point from the indexing scheme, then call C -- this is far from trivial (and ill-defined in general). See also L, which includes boundary conditions and allows you to switch the method of interpolation, but which runs somewhat slower. =cut *ninterpol = \&PDL::ninterpol; sub PDL::ninterpol { use PDL::Math 'floor'; use PDL::Primitive 'interpol'; print 'Usage: $a = ninterpolate($point(s), $data);' if $#_ != 1; my ($p, $y) = @_; my ($ip) = floor($p); # isolate relevant N-cube $y = $y->slice(join (',',map($_.':'.($_+1),list $ip))); for (list ($p-$ip)) { $y = interpol($_,$y->xvals,$y); } $y; } EOD pp_def('rebin',Doc=><<'EOD', =for ref N-dimensional rebinning algorithm =for usage $new = rebin $a, $dim1, $dim2,..;. $new = rebin $a, $template; $new = rebin $a, $template, {Norm => 1}; Rebin an N-dimensional array to newly specified dimensions. Specifying `Norm' keeps the sum constant, otherwise the intensities are kept constant. If more template dimensions are given than for the input pdl, these dimensions are created; if less, the final dimensions are maintained as they were. So if C<$a> is a 10 x 10 pdl, then C is a 15 x 10 pdl, while C is a 15 x 16 x 17 pdl (where the values along the final dimension are all identical). Expansion is performed by sampling; reduction is performed by averaging. If you want different behavior, use L instead. PDL::Transform::map runs slower but is more flexible. =cut EOD Pars => 'a(m); [o]b(n);', OtherPars => 'int ns => n', PMCode => ' # Custom Perl wrapper sub PDL::rebin { my($a) = shift; my($opts) = ref $_[-1] eq "HASH" ? pop : {}; my(@idims) = $a->dims; my(@odims) = ref $_[0] ? $_[0]->dims : @_; my($i,$b); foreach $i (0..$#odims) { if ($i > $#idims) { # Just dummy extra dimensions $a = $a->dummy($i,$odims[$i]); next; # rebin_int can cope with all cases, but code # 1->n and n->1 separately for speed } elsif ($odims[$i] != $idims[$i]) { # If something changes if (!($odims[$i] % $idims[$i])) { # Cells map 1 -> n my ($r) = $odims[$i]/$idims[$i]; $b = $a->mv($i,0)->dummy(0,$r)->clump(2); } elsif (!($idims[$i] % $odims[$i])) { # Cells map n -> 1 my ($r) = $idims[$i]/$odims[$i]; $a = $a->mv($i,0); # -> copy so won\'t corrupt input PDL $b = $a->slice("0:-1:$r")->copy; foreach (1..$r-1) { $b += $a->slice("$_:-1:$r"); } $b /= $r; } else { # Cells map n -> m &PDL::_rebin_int($a->mv($i,0), $b = null, $odims[$i]); } $a = $b->mv(0,$i); } } if (exists $opts->{Norm} and $opts->{Norm}) { my ($norm) = 1; for $i (0..$#odims) { if ($i > $#idims) { $norm /= $odims[$i]; } else { $norm *= $idims[$i]/$odims[$i]; } } return $a * $norm; } else { # Explicit copy so i) can\'t corrupt input PDL through this link # ii) don\'t waste space on invisible elements return $a -> copy; } } ', Code => ' int ms = $SIZE(m); int nv = $PRIV(ns); int i; double u, d; $GENERIC(a) av; threadloop %{ i = 0; d = -1; loop (n) %{ $b() = 0; %} loop (m) %{ av = $a(); u = nv*((m+1.)/ms)-1; while (i <= u) { $b(n => i) += (i-d)*av; d = i; i++; } if (i < nv) $b(n => i) += (u-d)*av; d = u; %} %} '); pp_addpm(<<'EOD'); =head2 circ_mean_p =for ref Calculates the circular mean of an n-dim image and returns the projection. Optionally takes the center to be used. =for usage $cmean=circ_mean_p($im); $cmean=circ_mean_p($im,{Center => [10,10]}); =cut sub circ_mean_p { my ($a,$opt) = @_; my ($rad,$sum,$norm); if (defined $opt) { $rad = long PDL::rvals($a,$opt); } else { $rad = long rvals $a; } $sum = zeroes($rad->max+1); PDL::indadd $a->clump(-1), $rad->clump(-1), $sum; # this does the real work $norm = zeroes($rad->max+1); PDL::indadd pdl(1), $rad->clump(-1), $norm; # equivalent to get norm $sum /= $norm; return $sum; } =head2 circ_mean =for ref Smooths an image by applying circular mean. Optionally takes the center to be used. =for usage circ_mean($im); circ_mean($im,{Center => [10,10]}); =cut sub circ_mean { my ($a,$opt) = @_; my ($rad,$sum,$norm,$a1); if (defined $opt) { $rad = long PDL::rvals($a,$opt); } else { $rad = long rvals $a; } $sum = zeroes($rad->max+1); PDL::indadd $a->clump(-1), $rad->clump(-1), $sum; # this does the real work $norm = zeroes($rad->max+1); PDL::indadd pdl(1), $rad->clump(-1), $norm; # equivalent to get norm $sum /= $norm; $a1 = $a->clump(-1); $a1 .= $sum->index($rad->clump(-1)); return $a; } EOD pp_add_exported('','circ_mean circ_mean_p'); pp_addpm(<<'EOPM'); =head2 kernctr =for ref `centre' a kernel (auxiliary routine to fftconvolve) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); kernctr centres a small kernel to emulate the behaviour of the direct convolution routines. =cut *kernctr = \&PDL::kernctr; sub PDL::kernctr { # `centre' the kernel, to match kernel & image sizes and # emulate convolve/conv2d. FIX: implement with phase shifts # in fftconvolve, with option tag barf "Must have image & kernel for kernctr" if $#_ != 1; my ($imag, $kern) = @_; my (@ni) = $imag->dims; my (@nk) = $kern->dims; barf "Kernel and image must have same number of dims" if $#ni != $#nk; my ($newk) = zeroes(double,@ni); my ($k,$n,$d,$i,@stri,@strk,@b); for ($i=0; $i <= $#ni; $i++) { $k = $nk[$i]; $n = $ni[$i]; barf "Kernel must be smaller than image in all dims" if ($n < $k); $d = int(($k-1)/2); $stri[$i][0] = "0:$d,"; $strk[$i][0] = (-$d-1).":-1,"; $stri[$i][1] = $d == 0 ? '' : ($d-$k+1).':-1,'; $strk[$i][1] = $d == 0 ? '' : '0:'.($k-$d-2).','; } # kernel is split between the 2^n corners of the cube my ($nchunk) = 2 << $#ni; CHUNK: for ($i=0; $i < $nchunk; $i++) { my ($stri,$strk); for ($n=0, $b=$i; $n <= $#ni; $n++, $b >>= 1) { next CHUNK if $stri[$n][$b & 1] eq ''; $stri .= $stri[$n][$b & 1]; $strk .= $strk[$n][$b & 1]; } chop ($stri); chop ($strk); ($t = $newk->slice($stri)) .= $kern->slice($strk); } $newk; } EOPM pp_def( 'convolveND', Doc=><<'EOD', =for ref Speed-optimized convolution with selectable boundary conditions =for usage $new = convolveND($a, $kernel, [ {options} ]); Conolve an array with a kernel, both of which are N-dimensional. If the kernel has fewer dimensions than the array, then the extra array dimensions are threaded over. There are options that control the boundary conditions and method used. The kernel's origin is taken to be at the kernel's center. If your kernel has a dimension of even order then the origin's coordinates get rounded up to the next higher pixel (e.g. (1,2) for a 3x4 kernel). This mimics the behavior of the earlier L and L routines, so convolveND is a drop-in replacement for them. The kernel may be any size compared to the image, in any dimension. The kernel and the array are not quite interchangeable (as in mathematical convolution): the code is inplace-aware only for the array itself, and the only allowed boundary condition on the kernel is truncation. convolveND is inplace-aware: say C to modify a variable in-place. You don't reduce the working memory that way -- only the final memory. OPTIONS Options are parsed by PDL::Options, so unique abbreviations are accepted. =over 3 =item boundary (default: 'truncate') The boundary condition on the array, which affects any pixel closer to the edge than the half-width of the kernel. The boundary conditions are the same as those accepted by L, because this option is passed directly into L. Useful options are 'truncate' (the default), 'extend', and 'periodic'. You can select different boundary conditions for different axes -- see L for more detail. The (default) truncate option marks all the near-boundary pixels as BAD if you have bad values compiled into your PDL and the array's badflag is set. =item method (default: 'auto') The method to use for the convolution. Acceptable alternatives are 'direct', 'fft', or 'auto'. The direct method is an explicit copy-and-multiply operation; the fft method takes the Fourier transform of the input and output kernels. The two methods give the same answer to within double-precision numerical roundoff. The fft method is much faster for large kernels; the direct method is faster for tiny kernels. The tradeoff occurs when the array has about 400x more pixels than the kernel. The default method is 'auto', which chooses direct or fft convolution based on the size of the input arrays. =back NOTES At the moment there's no way to thread over kernels. That could/should be fixed. The threading over input is cheesy and should probably be fixed: currently the kernel just gets dummy dimensions added to it to match the input dims. That does the right thing tersely but probably runs slower than a dedicated threadloop. The direct copying code uses PP primarily for the generic typing: it includes its own threadloops. =cut EOD PMCode => <<'EOD', use PDL::Options; # Perl wrapper conditions the data to make life easier for the PP sub. sub PDL::convolveND { my($a0,$k,$opt0) = @_; my $inplace = $a0->is_inplace; my $a = $a0->new_or_inplace; barf("convolveND: kernel (".join("x",$k->dims).") has more dims than source (".join("x",$a->dims).")\n") if($a->ndims < $k->ndims); # Coerce stuff all into the same type. Try to make sense. # The trivial conversion leaves dataflow intact (nontrivial conversions # don't), so the inplace code is OK. Non-inplace code: let the existing # PDL code choose what type is best. my $type; if($inplace) { $type = $a0->get_datatype; } else { my $z = $a->flat->index(0) + $k->flat->index(0); $type = $z->get_datatype; } $a = $a->convert($type); $k = $k->convert($type); ## Handle options -- $def is a static variable so it only gets set up once. our $def; unless(defined($def)) { $def = new PDL::Options( { Method=>'a', Boundary=>'t' } ); $def->minmatch(1); $def->casesens(0); } my $opt = $def->options(PDL::Options::ifhref($opt0)); ### # If the kernel has too few dimensions, we thread over the other # dims -- this is the same as supplying the kernel with dummy dims of # order 1, so, er, we do that. $k = $k->dummy($a->dims - 1, 1) if($a->ndims > $k->ndims); my $kdims = pdl($k->dims); ### # Decide whether to FFT or directly convolve: if we're in auto mode, # choose based on the relative size of the image and kernel arrays. my $fft = ( ($opt->{Method} =~ m/^a/i) ? ( $a->nelem > 2500 and ($a->nelem) <= ($k->nelem * 500) ) : ( $opt->{Method} !~ m/^[ds]/i ) ); ### # Pad the array to include boundary conditions my $adims = pdl($a->dims); my $koff = ($kdims/2)->ceil - 1; my $aa = $a->range( -$koff, $adims + $kdims, $opt->{Boundary} ) ->sever; if($fft) { # The eval here keeps conflicts from happening at compile time eval "use PDL::FFT" ; print "convolveND: using FFT method\n" if($PDL::debug); # FFT works best on doubles; do our work there then cast back # at the end. $aa = double($aa); my $aai = $aa->zeroes; my $kk = $aa->zeroes; my $kki = $aa->zeroes; my $tmp; # work around new perl -d "feature" ($tmp = $kk->range( - ($kdims/2)->floor, $kdims, 'p')) .= $k; PDL::fftnd($kk, $kki); PDL::fftnd($aa, $aai); { my($ii) = $kk * $aai + $aa * $kki; $aa = $aa * $kk - $kki * $aai; $aai .= $ii; } PDL::ifftnd($aa,$aai); $a .= $aa->range( $koff, $adims); } else { print "convolveND: using direct method\n" if($PDL::debug); ### The first argument is a dummy to set $GENERIC. &PDL::_convolveND_int( $k->flat->index(0), $k, $aa, $a ); } $a; } EOD Pars=>'k0()', OtherPars=>'SV *k; SV *aa; SV *a;', Code => <<'EOD' /* * Direct convolution * * Because the kernel is usually the smaller of the two arrays to be convolved, * we thread kernel-first to keep it in the processor's cache. The strategy: * work on a padded copy of the original image, so that (even with boundary * conditions) the geometry of the kernel is linearly related to the input * array. Otherwise, follow the path blazed by Karl in convolve(): keep track * of the offsets for each kernel element in a flattened original PDL. * * The first (PP) argument is a dummy that's only used to set the GENERIC() * macro. The other three arguments should all have the same type as the * first arguments, and are all passed in as SVs. They are: the kernel, * the padded copy of the input PDL, and a pre-allocated output PDL. The * input PDL should be padded by the dimensionality of the kernel. * */ short ndims; PDL_Indx *koffs, *koff; /* the "s" variables are static */ $GENERIC() *kvals, *kval; /* scratchspace designed to avoid dynamic */ static PDL_Indx skoffs[256]; /* allocation. The cost ia about 2k per */ static $GENERIC() skvals[256]; /* datatype, or about 20k of memory. */ $GENERIC() *aptr; $GENERIC() *aaptr; PDL_Indx *ivec; static PDL_Indx sivec[16]; PDL_Indx i,j; pdl *k = PDL->SvPDLV($COMP(k)); pdl *a = PDL->SvPDLV($COMP(a)); pdl *aa = PDL->SvPDLV($COMP(aa)); if(!k || !a || !aa) barf("convolveND: Can't convert args to PDLs (should never happen)\n"); PDL->make_physical(aa); PDL->make_physical(a); PDL->make_physical(k); ndims = aa->ndims; if(ndims != k->ndims || ndims != aa->ndims) barf("convolveND: dims don't agree (should never happen)\n"); /* Allocate scratchpads if necessary */ /* This is done in boneheaded but safe manner ('coz we can't be sure */ /* of the relationship between the size of GENERIC and the size of */ /* a pointer). */ if(k->nvals <= 256) { koffs = skoffs; kvals = skvals; } else { koffs = (PDL_Indx *) (PDL->smalloc((STRLEN) (k->nvals * sizeof(PDL_Indx)))); kvals = ($GENERIC() *)(PDL->smalloc((STRLEN) (k->nvals * sizeof($GENERIC())))); } if(ndims < 16) { ivec = sivec; } else { ivec = (PDL_Indx *) (PDL->smalloc((STRLEN) (ndims * sizeof(PDL_Indx)))); } if(!ivec || !koffs || !kvals) barf("convolveND: out of memory\n"); /************************************/ /* Fill up the koffs & kvals arrays */ /* koffs gets relative offsets into aa for each kernel value; */ /* kvals gets the kernel values in the same order (flattened) */ for(i=0;idata + k->nvals - 1; do { PDL_Indx acc; *(kval++) = *aptr; /* Copy kernel value into kernel list */ *(koff++) = j; /* Copy current aa offset into koffs list */ /* Advance k-vector */ for(i=0; (i < ndims) && (aptr -= k->dimincs[i]) && /* Funky pre-test part of loop */ (j += aa->dimincs[i]) && /* Funky pre-test part of loop */ (++(ivec[i]) >= k->dims[i]); i++) { ivec[i] = 0; aptr += k->dimincs[i] * k->dims[i]; j -= aa->dimincs[i] * k->dims[i]; } } while(idata; aaptr = aa->data; do { $GENERIC() acc = 0; koff = koffs; kval = kvals; for(i=0;invals;i++) acc += aaptr[*(koff++)] * (*(kval++)); *aptr = acc; /* Advance a-vector and aa-vector */ for(i=0; (idimincs[i]) && /* Funky pre-test part of loop */ (aaptr += aa->dimincs[i]) && /* Funky pre-test part of loop */ (++(ivec[i]) >= a->dims[i]); i++) { ivec[i] = 0; aptr -= a->dimincs[i] * ( a->dims[i]); aaptr -= aa->dimincs[i] * ( a->dims[i]); /* sic */ } } while(iTop},<<'EOD'); =head1 NAME PDL::ImageRGB -- some utility functions for RGB image data handling =head1 DESCRIPTION Collection of a few commonly used routines involved in handling of RGB, palette and grayscale images. Not much more than a start. Should be a good place to exercise some of the thread/map/clump PP stuff. Other stuff that should/could go here: =over 3 =item * color space conversion =item * common image filters =item * image rebinning =back =head1 SYNOPSIS use PDL::ImageRGB; =cut use vars qw( $typecheck $EPS ); use PDL::Core; use PDL::Basic; use PDL::Primitive; use PDL::Types; use Carp; use strict 'vars'; $PDL::ImageRGB::EPS = 1e-7; # there is probably a more portable way =head1 FUNCTIONS =head2 cquant =for ref quantize and reduce colours in 8-bit images =for usage ($out, $lut) = cquant($image [,$ncols]); This function does color reduction for <=8bit displays and accepts 8bit RGB and 8bit palette images. It does this through an interface to the ppm_quant routine from the pbmplus package that implements the median cut routine which intellegently selects the 'best' colors to represent your image on a <= 8bit display (based on the median cut algorithm). Optional args: $ncols sets the maximum nunmber of colours used for the output image (defaults to 256). There are images where a different color reduction scheme gives better results (it seems this is true for images containing large areas with very smoothly changing colours). Returns a list containing the new palette image (type PDL_Byte) and the RGB colormap. =cut # full threading support intended *cquant = \&PDL::cquant; sub PDL::cquant { barf 'Usage: ($out,$olut) = cquant($image[,$ncols])' if $#_<0 || $#_>1; my $image = shift; my $ncols; if ($#_ >= 0 ) { $ncols=shift; } else { $ncols = 256; }; my @Dims = $image->dims; my ($out, $olut) = (null,null); barf "input must be byte (3,x,x)" if (@Dims < 2) || ($Dims[0] != 3) || ($image->get_datatype != $PDL_B); cquant_c($image,$out,$olut,$ncols); return ($out,$olut); } =head2 interlrgb =for ref Make an RGB image from a palette image and its lookup table. =for usage $rgb = $palette_im->interlrgb($lut) Input should be of an integer type and the lookup table (3,x,...). Will perform the lookup for any N-dimensional input pdl (i.e. 0D, 1D, 2D, ...). Uses the index command but will not dataflow by default. If you want it to dataflow the dataflow_forward flag must be set in the $lut piddle (you can do that by saying $lut->set_dataflow_f(1)). =cut # interlace a palette image, input as 8bit-image, RGB-lut (3,x,..) to # (R,G,B) format for each pixel in the image # should already support threading *interlrgb=\&PDL::interlrgb; sub PDL::interlrgb { my ($pdl,$lut) = @_; my $res; # for our purposes $lut should be (3,z) where z is the number # of colours in the lut barf "expecting (3,x) input" if ($lut->dims)[0] != 3; # do the conversion as an implicitly threaded index lookup if ($lut->fflows) { $res = $lut->xchg(0,1)->index($pdl->dummy(0)); } else { $res = $lut->xchg(0,1)->index($pdl->dummy(0))->sever; } return $res; } =head2 rgbtogr =for ref Converts an RGB image to a grey scale using standard transform =for usage $gr = $rgb->rgbtogr Performs a conversion of an RGB input image (3,x,....) to a greyscale image (x,.....) using standard formula: Grey = 0.301 R + 0.586 G + 0.113 B =cut # convert interlaced rgb image to grayscale # will convert any (3,...) dim pdl, i.e. also single lines, # stacks of RGB images, etc since implicit threading takes care of this # should already support threading *rgbtogr = \&PDL::rgbtogr; sub PDL::rgbtogr { barf "Usage: \$im->rgbtogr" if $#_ < 0; my $im = shift; barf "rgbtogr: expecting RGB (3,...) input" if (($im->dims)[0] != 3); my $type = $im->get_datatype; my $rgb = float([77,150,29])/256; # vector for rgb conversion my $oim = null; # flag PP we want it to allocate inner($im,$rgb,$oim); # do the conversion as a threaded inner prod return $oim->convert($type); # convert back to original type } =head2 bytescl =for ref Scales a pdl into a specified data range (default 0-255) =for usage $scale = $im->bytescl([$top]) By default $top=255, otherwise you have to give the desired top value as an argument to C. Normally C doesn't rescale data that fits already in the bounds 0..$top (it only does the type conversion if required). If you want to force it to rescale so that the max of the output is at $top and the min at 0 you give a negative $top value to indicate this. =cut # scale any pdl linearly so that its data fits into the range # 0<=x<=$ncols where $ncols<=255 # returns scaled data with type converted to byte # doesn't rescale but just typecasts if data already fits into range, i.e. # data ist not necessarily stretched to 0..$ncols # needs some changes for full threading support ?? (explicit threading?) *bytescl = \&PDL::bytescl; sub PDL::bytescl { barf 'Usage: bytescl $im[,$top]' if $#_ < 0; my $pdl = shift; my ($top,$force) = (255,0); $top = shift if $#_ > -1; if ($top < 0) { $force=1; $top *= -1; } $top = 255 if $top > 255; print "bytescl: scaling from 0..$top\n" if $PDL::debug; my ($max, $min); $max = max $pdl; $min = min $pdl; return byte $pdl if ($min >= 0 && $max <= $top && !$force); # check for pathological cases if (($max-$min) < $EPS) { print "bytescl: pathological case\n" if $PDL::debug; return byte $pdl if (abs($max) < $EPS) || ($max >= 0 && $max <= $top); return byte ($pdl/$max); } my $type = $pdl->get_datatype > $PDL_F ? $PDL_D : $PDL_F; return byte ($top*($pdl->convert($type)-$min)/($max-$min)+0.5); } ;# Exit with OK status 1; =head1 BUGS This package doesn't yet contain enough useful functions! =head1 AUTHOR Copyright 1997 Christian Soeller All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD ################################ XS CODE ################################# # a is the input image # b is the output image and c the output lut pp_def( 'cquant_c',Doc=>undef, Pars => 'a(m,n,o); [o]b(n,o); [o]c(m,p);', GenericTypes => [B], OtherPars => 'int psz => p', Code => 'int status; if ($SIZE(m) != 3) barf("need RGB data (3,x,...)"); status = ppm_quant($P(a), NULL, NULL, $SIZE(n), $SIZE(o),$P(b), NULL, $P(c), 0, $SIZE(p), 1); if (!status) barf("ppm_quant returned error status");' ); pp_done(); PDL-2.018/Lib/ImageRGB/Makefile.PL0000644060175006010010000000070012562522364014435 0ustar chmNoneuse strict; use warnings; # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; my @pack = ([qw(imagergb.pd ImageRGB PDL::ImageRGB)]); my %hash = pdlpp_stdargs_int(@pack); $hash{'OBJECT'} .= ' ppm_quant$(OBJ_EXT)'; $hash{'clean'}{FILES} .= ' ppm_quant$(OBJ_EXT)'; # Add genpp rule undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.018/Lib/ImageRGB/pdlppm.h0000644060175006010010000000040312562522364014130 0ustar chmNone/* prototypes of functions in ppm_quant.c */ int ppm_quant(unsigned char *rin, unsigned char *gin, unsigned char *bin, int cols, int rows, unsigned char *pic8, unsigned char *ilut, unsigned char *olut, int ilen, int newcolors, int mode); PDL-2.018/Lib/ImageRGB/ppm_quant.c0000644060175006010010000004302512562522364014642 0ustar chmNone/* going to turn it into a standalone module (cut out of xv24to8.c) * final goal: turn into call_external module for idl */ #include #include /* qsort */ #ifdef DEBUG_OUT #define StartCursor() fprintf(stderr,"%%idlppm_quant: choosing colors") #define WaitCursor() fputc('.',stderr) #define FinishCursor() fputc('\n',stderr) #define FatalError(x) { fprintf(stderr,x); return(NULL); } #else #define StartCursor() #define WaitCursor() #define FinishCursor() #define FatalError(x) return(0) #endif typedef unsigned char byte; /***************************************************************/ /* The following code based on code from the 'pbmplus' package */ /* written by Jef Poskanzer */ /***************************************************************/ /* ppmquant.c - quantize the colors in a pixmap down to a specified number ** ** Copyright (C) 1989, 1991 by Jef Poskanzer. ** ** Permission to use, copy, modify, and distribute this software and its ** documentation for any purpose and without fee is hereby granted, provided ** that the above copyright notice appear in all copies and that both that ** copyright notice and this permission notice appear in supporting ** documentation. This software is provided "as is" without express or ** implied warranty. */ typedef unsigned char pixval; #define PPM_MAXMAXVAL 255 typedef struct { pixval r, g, b; } pixel; #define PPM_GETR(p) ((p).r) #define PPM_GETG(p) ((p).g) #define PPM_GETB(p) ((p).b) #define PPM_ASSIGN(p,red,grn,blu) \ { (p).r = (red); (p).g = (grn); (p).b = (blu); } #define PPM_EQUAL(p,q) ( (p).r == (q).r && (p).g == (q).g && (p).b == (q).b ) /* Color scaling macro -- to make writing ppmtowhatever easier. */ #define PPM_DEPTH(newp,p,oldmaxval,newmaxval) \ PPM_ASSIGN( (newp), \ (int) PPM_GETR(p) * (newmaxval) / ((int)oldmaxval), \ (int) PPM_GETG(p) * (newmaxval) / ((int)oldmaxval), \ (int) PPM_GETB(p) * (newmaxval) / ((int)oldmaxval) ) /* Luminance macro. */ /* * #define PPM_LUMIN(p) \ * ( 0.299 * PPM_GETR(p) + 0.587 * PPM_GETG(p) + 0.114 * PPM_GETB(p) ) */ /* Luminance macro, using only integer ops. Returns an int (*256) JHB */ #define PPM_LUMIN(p) \ ( 77 * PPM_GETR(p) + 150 * PPM_GETG(p) + 29 * PPM_GETB(p) ) /* Color histogram stuff. */ typedef struct chist_item* chist_vec; struct chist_item { pixel color; int value; }; typedef struct chist_list_item* chist_list; struct chist_list_item { struct chist_item ch; chist_list next; }; typedef chist_list* chash_table; typedef struct box* box_vector; struct box { int index; int colors; int sum; }; #define MAXCOLORS 32767 #define CLUSTER_MAXVAL 63 #define LARGE_LUM #define REP_AVERAGE_PIXELS #define FS_SCALE 1024 #define HASH_SIZE 6553 #define ppm_hashpixel(p) ((((int) PPM_GETR(p) * 33023 + \ (int) PPM_GETG(p) * 30013 + \ (int) PPM_GETB(p) * 27011) & 0x7fffffff) \ % HASH_SIZE) /*** function defs ***/ #define PARM(x) x static chist_vec mediancut PARM((chist_vec, int, int, int, int)); static int redcompare PARM((const void *, const void *)); static int greencompare PARM((const void *, const void *)); static int bluecompare PARM((const void *, const void *)); static int sumcompare PARM((const void *, const void *)); static chist_vec ppm_computechist PARM((pixel **, int,int,int,int *)); static chash_table ppm_computechash PARM((pixel **, int,int,int,int *)); static chist_vec ppm_chashtochist PARM((chash_table, int)); static chash_table ppm_allocchash PARM((void)); static void ppm_freechist PARM((chist_vec)); static void ppm_freechash PARM((chash_table)); int ppm_quant(byte *rin, byte *gin, byte *bin, int cols, int rows, byte *pic8, byte *imap, byte *omap, int len, int newcolors, int mode); static int DEBUG=0; #define SEPARATE 0 #define PACKED 1 #define PALETTE 2 /* rmap, gmap, bmap 256 byte arrays ** pic24 rows*cols*3 size byte array ** pic8 rows*cols byte array ** newcolors number of new colors to put into look-up table */ /****************************************************************************/ int ppm_quant(byte *rin, byte *gin, byte *bin, int cols, int rows, byte *pic8, byte *imap, byte *omap, int len, int newcolors, int mode) { byte *map; pixel** pixels; register pixel* pP; int row; register int col, limitcol; pixval maxval, newmaxval; int colors; register int index; chist_vec chv, colormap; chash_table cht; int i; unsigned char *picptr; static char *fn = "ppmquant()"; index = 0; maxval = 255; /* * reformat 24-bit image (3 bytes per pixel) into 2-dimensional * array of pixel structures */ if (DEBUG) fprintf(stderr,"%s: remapping to ppm-style internal fmt\n", fn); WaitCursor(); pixels = (pixel **) malloc(rows * sizeof(pixel *)); if (!pixels) FatalError("couldn't allocate 'pixels' array"); for (row=0; rowr = *rin++; pP->g = *gin++; pP->b = *bin++; } break; case PACKED: for (col=0, pP=pixels[row]; colr = *rin++; pP->g = *rin++; pP->b = *rin++; } break; case PALETTE: for (col=0, pP=pixels[row]; colr = imap[*rin*3]; pP->g = imap[*rin*3+1]; pP->b = imap[*rin*3+2]; } break; default: return 0; break; } } if (DEBUG) fprintf(stderr,"%s: done format remapping\n", fn); /* * attempt to make a histogram of the colors, unclustered. * If at first we don't succeed, lower maxval to increase color * coherence and try again. This will eventually terminate, with * maxval at worst 15, since 32^3 is approximately MAXCOLORS. */ WaitCursor(); for ( ; ; ) { if (DEBUG) fprintf(stderr, "%s: making histogram\n", fn); chv = ppm_computechist(pixels, cols, rows, MAXCOLORS, &colors); if (chv != (chist_vec) 0) break; if (DEBUG) fprintf(stderr, "%s: too many colors!\n", fn); newmaxval = maxval / 2; if (DEBUG) fprintf(stderr, "%s: rescaling colors (maxval=%d) %s\n", fn, newmaxval, "to improve clustering"); for (row=0; rownext) if (PPM_EQUAL(chl->ch.color, *pP)) {index = chl->ch.value; break;} if (!chl /*index = -1*/) {/* No; search colormap for closest match. */ register int i, r1, g1, b1, r2, g2, b2; register long dist, newdist; r1 = PPM_GETR( *pP ); g1 = PPM_GETG( *pP ); b1 = PPM_GETB( *pP ); dist = 2000000000; for (i=0; ich.color = *pP; chl->ch.value = index; chl->next = cht[hash]; cht[hash] = chl; } *picptr++ = index; ++col; ++pP; } while (col != limitcol); } /* rescale the colormap */ map = omap; for (i=0; i maxr) maxr = v; v = PPM_GETG( chv[indx + i].color ); if (v < ming) ming = v; if (v > maxg) maxg = v; v = PPM_GETB( chv[indx + i].color ); if (v < minb) minb = v; if (v > maxb) maxb = v; } /* ** Find the largest dimension, and sort by that component. I have ** included two methods for determining the "largest" dimension; ** first by simply comparing the range in RGB space, and second ** by transforming into luminosities before the comparison. You ** can switch which method is used by switching the commenting on ** the LARGE_ defines at the beginning of this source file. */ { /* LARGE_LUM version */ pixel p; int rl, gl, bl; PPM_ASSIGN(p, maxr - minr, 0, 0); rl = PPM_LUMIN(p); PPM_ASSIGN(p, 0, maxg - ming, 0); gl = PPM_LUMIN(p); PPM_ASSIGN(p, 0, 0, maxb - minb); bl = PPM_LUMIN(p); if (rl >= gl && rl >= bl) qsort((char*) &(chv[indx]), (size_t) clrs, sizeof(struct chist_item), redcompare ); else if (gl >= bl) qsort((char*) &(chv[indx]), (size_t) clrs, sizeof(struct chist_item), greencompare ); else qsort((char*) &(chv[indx]), (size_t) clrs, sizeof(struct chist_item), bluecompare ); } /* ** Now find the median based on the counts, so that about half the ** pixels (not colors, pixels) are in each subdivision. */ lowersum = chv[indx].value; halfsum = sm / 2; for (i=1; i= halfsum) break; lowersum += chv[indx + i].value; } /* ** Split the box, and sort to bring the biggest boxes to the top. */ bv[bi].colors = i; bv[bi].sum = lowersum; bv[boxes].index = indx + i; bv[boxes].colors = clrs - i; bv[boxes].sum = sm - lowersum; ++boxes; qsort((char*) bv, (size_t) boxes, sizeof(struct box), sumcompare); } /* while (boxes ... */ /* ** Ok, we've got enough boxes. Now choose a representative color for ** each box. There are a number of possible ways to make this choice. ** One would be to choose the center of the box; this ignores any structure ** within the boxes. Another method would be to average all the colors in ** the box - this is the method specified in Heckbert's paper. A third ** method is to average all the pixels in the box. You can switch which ** method is used by switching the commenting on the REP_ defines at ** the beginning of this source file. */ for (bi=0; bimaxval) r = maxval; /* avoid math errors */ g = g / sum; if (g>maxval) g = maxval; b = b / sum; if (b>maxval) b = maxval; PPM_ASSIGN( colormap[bi].color, r, g, b ); } free(bv); return colormap; } /**********************************/ static int redcompare(p1, p2) const void *p1, *p2; { return (int) PPM_GETR( ((chist_vec)p1)->color ) - (int) PPM_GETR( ((chist_vec)p2)->color ); } /**********************************/ static int greencompare(p1, p2) const void *p1, *p2; { return (int) PPM_GETG( ((chist_vec)p1)->color ) - (int) PPM_GETG( ((chist_vec)p2)->color ); } /**********************************/ static int bluecompare(p1, p2) const void *p1, *p2; { return (int) PPM_GETB( ((chist_vec)p1)->color ) - (int) PPM_GETB( ((chist_vec)p2)->color ); } /**********************************/ static int sumcompare(p1, p2) const void *p1, *p2; { return ((box_vector) p2)->sum - ((box_vector) p1)->sum; } /****************************************************************************/ static chist_vec ppm_computechist(pixels, cols, rows, maxcolors, colorsP) pixel** pixels; int cols, rows, maxcolors; int* colorsP; { chash_table cht; chist_vec chv; cht = ppm_computechash(pixels, cols, rows, maxcolors, colorsP); if (!cht) return (chist_vec) 0; chv = ppm_chashtochist(cht, maxcolors); ppm_freechash(cht); return chv; } /****************************************************************************/ static chash_table ppm_computechash(pixels, cols, rows, maxcolors, colorsP ) pixel** pixels; int cols, rows, maxcolors; int* colorsP; { chash_table cht; register pixel* pP; chist_list chl; int col, row, hash; cht = ppm_allocchash( ); *colorsP = 0; /* Go through the entire image, building a hash table of colors. */ for (row=0; rownext) if (PPM_EQUAL(chl->ch.color, *pP)) break; if (chl != (chist_list) 0) ++(chl->ch.value); else { if ((*colorsP)++ > maxcolors) { ppm_freechash(cht); return (chash_table) 0; } chl = (chist_list) malloc(sizeof(struct chist_list_item)); if (!chl) FatalError("ran out of memory computing hash table"); chl->ch.color = *pP; chl->ch.value = 1; chl->next = cht[hash]; cht[hash] = chl; } } return cht; } /****************************************************************************/ static chash_table ppm_allocchash() { chash_table cht; int i; cht = (chash_table) malloc( HASH_SIZE * sizeof(chist_list) ); if (!cht) FatalError("ran out of memory allocating hash table"); for (i=0; inext) { /* Add the new entry. */ chv[j] = chl->ch; ++j; } return chv; } /****************************************************************************/ static void ppm_freechist( chv ) chist_vec chv; { free( (char*) chv ); } /****************************************************************************/ static void ppm_freechash( cht ) chash_table cht; { int i; chist_list chl, chlnext; for (i=0; inext; free( (char*) chl ); } free( (char*) cht ); } PDL-2.018/Lib/Interpolate/0000755060175006010010000000000013110402046013357 5ustar chmNonePDL-2.018/Lib/Interpolate/Interpolate.pm0000644060175006010010000003354513036512175016231 0ustar chmNone =head1 NAME PDL::Interpolate - provide a consistent interface to the interpolation routines available in PDL =head1 SYNOPSIS use PDL::Interpolate; my $i = new PDL::Interpolate( x => $x, y = $y ); my $y = $i->interpolate( $xi ); =head1 DESCRIPTION This module aims to provide a relatively-uniform interface to the various interpolation methods available to PDL. The idea is that a different interpolation scheme can be used just by changing the C call. At present, PDL::Interpolate itself just provides a somewhat-convoluted interface to the C function of L. However, it is expected that derived classes, such as L, will actually be used in real-world situations. To use, create a PDL::Interpolate (or a derived class) object, supplying it with its required attributes. =head1 LIBRARIES Currently, the available classes are =over 4 =item PDL::Interpolate Provides an interface to the interpolation routines of PDL. At present this is the linear interpolation routine L. =item PDL::Interpolate::Slatec The SLATEC library contains several approaches to interpolation: piecewise cubic Hermite functions and B-splines. At present, only the former method is available. =back It should be relatively easy to provide an interface to other interpolation routines, such as those provided by the Gnu Scientific Library (GSL). =head1 ATTRIBUTES The attributes (or options) of an object are as follows; derived classes may modify this list. Attribute Flag Description x sgr x positions of data y sgr function values at x positions bc g boundary conditions err g error flag type g type of interpolation A flag of C means that a user can set this attribute with the L or L methods, a flag of C means that the user can obtain the value of this attribute using L, and a flag of C means that the attribute is required when an object is created (see the L method). Attribute Default value bc "none" type "linear" If a routine is sent an attribute it does not understand, then it ignores that attribute, except for L, which returns C for that value. =head1 METHODS The default methods are described below. However, defined classes may extend them as they see fit, and add new methods. Throughout this documentation, C<$x> and C<$y> refer to the function to be interpolated whilst C<$xi> and C<$yi> are the interpolated values. =head1 THREADING The class will thread properly if the routines it calls do so. See the SYNOPSIS section of L (if available) for an example. =cut package PDL::Interpolate; use Carp; use strict; #################################################################### ## Public routines: =head2 new =for usage $obj = new PDL::Interpolate( x => $x, y => $y ); =for ref Create a PDL::Interpolate object. The required L are C and C. At present the only available interpolation method is C<"linear"> - which just uses L - and there are no options for boundary conditions, which is why the C and C attributes can not be changed. =cut # meaning of types: # required - required, if this attr is changed, we need to re-initialise # settable - can be changed with a new() or set() command # gettable - can be read with a get() command # sub new { my $this = shift; my $class = ref($this) || $this; # class structure my $self = { attributes => {}, values => {}, types => { required => 0, settable => 0, gettable => 0 }, flags => { library => "PDL", status => 1, routine => "none", changed => 1 }, }; # make $self into an object bless $self, $class; # set up default attributes # $self->_add_attr( x => { required => 1, settable => 1, gettable => 1 }, y => { required => 1, settable => 1, gettable => 1 }, bc => { gettable => 1 }, err => { gettable => 1 }, type => { gettable => 1 }, ); $self->_set_value( bc => "none", type => "linear", ); # set variables # - expect sub-classes to call this new with no variables, so $#_ == -1 $self->set( @_ ) if ( @_ ); # return the object return $self; } # sub: new() ##################################################################### # in _add_attr(), _change_attr() and _add_attr_type() # we set flags->changed to 1 when something changes. It's # a bit over the top to do this, as these should only be called when # creating the object, when the changed flag should be set to 1 anyway # add attributes to the object and sets value to undef # # supply a hash array, keys == variable name, # values are a hash array with keys matching # $self->{values}, which also gives the default value # for the type # # this can only be used to create an attribute - # see _change_attr() to change an already exsiting attribute. # # the fields are set to the default values, then filled in with the supplied values # any value that is unknown is ignored # sub _add_attr { my $self = shift; my %attrs = ( @_ ); foreach my $attr ( keys %attrs ) { croak "ERROR: adding an attribute ($attr) which is already known.\n" if defined $self->{attributes}->{$attr}; # set default values foreach my $type ( keys %{$self->{types}} ) { $self->{attributes}->{$attr}->{$type} = $self->{types}->{$type}; } # change the values to those supplied foreach my $type ( keys %{$attrs{$attr}} ) { $self->{attributes}->{$attr}->{$type} = $attrs{$attr}->{$type} if exists $self->{types}->{$type}; } # set value to undef $self->{values}->{$attr} = undef; } $self->{flags}->{changed} = 1; } # sub: _add_attr() # changes attributes of the object # # the given attributes MUST already exist # sub _change_attr { my $self = shift; my %attrs = ( @_ ); foreach my $attr ( keys %attrs ) { croak "ERROR: changing an attribute ($attr) which is not known.\n" unless defined $self->{attributes}->{$attr}; # change the values to those supplied foreach my $type ( keys %{$attrs{$attr}} ) { if ( exists $self->{types}->{$type} ) { $self->{attributes}->{$attr}->{$type} = $attrs{$attr}->{$type}; $self->{flags}->{changed} = 1; } } } } # sub: _change_attr() # adds the given types to the allowed list, and # updates all attributes to contain the default value # # Useful for sub-classes which add new types # sub _add_attr_type { my $self = shift; my %types = ( @_ ); foreach my $type ( keys %types ) { croak "ERROR: adding type ($type) that is already known.\n" if exists $self->{types}->{$type}; $self->{types}->{$type} = $types{$type}; # loop through each attribute, adding this type foreach my $attr ( keys %{$self->{attributes}} ) { $self->{attributes}->{$attr}->{$type} = $types{$type}; } $self->{flags}->{changed} = 1; } } # sub: _add_attr_type() #################################################################### # if an attribute has changed, check all required attributes # still exist and re-initialise the object (for PDL::Interpolate # this is a nop) # sub _check_attr { my $self = shift; return unless $self->{flags}->{changed}; my @emsg; foreach my $name ( keys %{ $self->{attributes} } ) { if( $self->{attributes}->{$name}->{required} ) { push @emsg, $name unless defined($self->{values}->{$name}); } } croak "ERROR - the following attributes must be supplied:\n [ @emsg ]\n" unless $#emsg == -1; $self->{flags}->{routine} = "none"; $self->{flags}->{status} = 1; $self->_initialise; $self->{flags}->{new} = 0; } # sub: check_attr() #################################################################### # # method to be over-ridden by sub-classes # PDL::Interpolate needs no initialisation # sub _initialise {} #################################################################### # a version of set that ignores the settable flag # - for use by the class, not by the public # # it still ignores unknown attributes # sub _set_value { my $self = shift; my %attrs = ( @_ ); foreach my $attr ( keys %attrs ) { if ( exists($self->{values}->{$attr}) ) { $self->{values}->{$attr} = $attrs{$attr}; $self->{flags}->{changed} = 1; } } } # sub: _set_value() # a version of get that ignores the gettable flag # - for use by the class, not by the public # # an unknown attribute returns an undef # sub _get_value { my $self = shift; my @ret; foreach my $name ( @_ ) { if ( exists $self->{values}->{$name} ) { push @ret, $self->{values}->{$name}; } else { push @ret, undef; } } return wantarray ? @ret : $ret[0]; } # sub: _get_value() #################################################################### =head2 set =for usage my $nset = $obj->set( x = $newx, $y => $newy ); =for ref Set attributes for a PDL::Interpolate object. The return value gives the number of the supplied attributes which were actually set. =cut sub set { my $self = shift; my %vals = ( @_ ); my $ctr = 0; foreach my $name ( keys %vals ) { if ( exists $self->{attributes}->{$name}->{settable} ) { $self->{values}->{$name} = $vals{$name}; $ctr++; } } $self->{flags}->{changed} = 1 if $ctr; return $ctr; } # sub: set() #################################################################### =head2 get =for usage my $x = $obj->get( x ); my ( $x, $y ) = $obj->get( qw( x y ) ); =for ref Get attributes from a PDL::Interpolate object. Given a list of attribute names, return a list of their values; in scalar mode return a scalar value. If the supplied list contains an unknown attribute, C returns a value of C for that attribute. =cut sub get { my $self = shift; my @ret; foreach my $name ( @_ ) { if ( exists $self->{attributes}->{$name}->{gettable} ) { push @ret, $self->{values}->{$name}; } else { push @ret, undef; } } return wantarray ? @ret : $ret[0]; } # sub: get() #################################################################### =head2 interpolate =for usage my $yi = $obj->interpolate( $xi ); =for ref Returns the interpolated function at a given set of points. A status value of -1, as returned by the C method, means that some of the C<$xi> points lay outside the range of the data. The values for these points were calculated using linear extrapolation. =cut sub interpolate { my $self = shift; my $xi = shift; croak 'Usage: $obj->interpolate( $xi )' . "\n" unless defined $xi; # check everything is fine $self->_check_attr(); # get values in one go my ( $x, $y ) = $self->_get_value( qw( x y ) ); my ( $yi, $err ) = PDL::Primitive::interpolate( $xi, $x, $y ); if ( any $err ) { $self->{flags}->{status} = -1; } else { $self->{flags}->{status} = 1; } $self->_set_value( err => $err ); $self->{flags}->{routine} = "interpolate"; return $yi; } #################################################################### # # access to flags - have individual methods for these =head2 status =for usage my $status = $obj->status; =for ref Returns the status of a PDL::Interpolate object Returns B<1> if everything is okay, B<0> if there has been a serious error since the last time C was called, and B<-1> if there was a problem which was not serious. In the latter case, C<$obj-Eget("err")> may provide more information, depending on the particular class. =cut sub status { my $self = shift; return $self->{flags}->{status}; } =head2 library =for usage my $name = $obj->library; =for ref Returns the name of the library used by a PDL::Interpolate object For PDL::Interpolate, the library name is C<"PDL">. =cut sub library { my $self = shift; return $self->{flags}->{library}; } =head2 routine =for usage my $name = $obj->routine; =for ref Returns the name of the last routine called by a PDL::Interpolate object. For PDL::Interpolate, the only routine used is C<"interpolate">. This will be more useful when calling derived classes, in particular when trying to decode the values stored in the C attribute. =cut sub routine { my $self = shift; return $self->{flags}->{routine}; } =head2 attributes =for usage $obj->attributes; PDL::Interpolate::attributes; =for ref Print out the flags for the attributes of an object. Useful in case the documentation is just too opaque! =for example PDL::Interpolate->attributes; Flags Attribute SGR x SGR y G err G type G bc =cut # note, can be called with the class, rather than just # an object # # to allow this, I've used a horrible hack - we actually # create an object and then print out the attributes from that # Ugh! # sub attributes { my $self = shift; # ugh $self = $self->new unless ref($self); print "Flags Attribute\n"; while ( my ( $attr, $hashref ) = each %{$self->{attributes}} ) { my $flag = ""; $flag .= "S" if $hashref->{settable}; $flag .= "G" if $hashref->{gettable}; $flag .= "R" if $hashref->{required}; printf " %-3s %s\n", $flag, $attr; } return; } #################################################################### =head1 AUTHOR Copyright (C) 2000 Doug Burke (burke@ifa.hawaii.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. =head1 SEE ALSO L, perltoot(1). =cut #################################################################### # End with a true 1; PDL-2.018/Lib/Interpolate/Makefile.PL0000644060175006010010000000030212562522364015344 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => "PDL::Interpolate", VERSION_FROM => "../../Basic/Core/Version.pm", DIR => [ 'Slatec' ], ); PDL-2.018/Lib/Interpolate/Slatec/0000755060175006010010000000000013110402046014572 5ustar chmNonePDL-2.018/Lib/Interpolate/Slatec/Makefile.PL0000644060175006010010000000127712562522364016573 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; # do we build PDL::Interpolate::Slatec ? my $msg = "\n Will skip build of PDL::Interpolate::Slatec\n"; my $build=0; if ($^O =~ /win32/i) { $msg = "\n Win32 systems not yet supported: no build of PDL::Interpolate::Slatec\n"; } elsif (defined $PDL::Config{WITH_SLATEC} and $PDL::Config{WITH_SLATEC} != 0 ) { $build=1; } if ($build==0) { write_dummy_make( $msg ); return; } else { print "\n Building PDL::Interpolate::Slatec.\n\n"; } WriteMakefile( NAME => "PDL::Interpolate::Slatec", VERSION_FROM => "../../../Basic/Core/Version.pm", ); PDL-2.018/Lib/Interpolate/Slatec/Slatec.pm0000644060175006010010000002462612562522364016375 0ustar chmNone =head1 NAME PDL::Interpolate::Slatec - simple interface to SLATEC interpolation routines =head1 SYNOPSIS use PDL::Interpolate::Slatec; use PDL::Math; # somewhat pointless way to estimate cos and sin, # but is shows that you can thread if you want to # my $x = pdl( 0 .. 45 ) * 4 * 3.14159 / 180; my $y = cat( sin($x), cos($x) ); # my $obj = new PDL::Interpolate::Slatec( x => $x, y = $y ); # my $xi = pdl( 0.5, 1.5, 2.5 ); my $yi = $obj->interpolate( $xi ); # print "cos( $xi ) equals ", $yi->slice(':,(0)'), "\n"; cos( [0.5 1.5 2.5] ) equals [0.87759844 0.070737667 -0.80115622] # print "sin( $xi ) equals ", $yi->slice(':,(1)'), "\n"; sin( [0.5 1.5 2.5] ) equals [ 0.4794191 0.99768655 0.59846449] # print cos($xi), "\n", sin($xi), "\n"; [0.87758256 0.070737202 -0.80114362] [0.47942554 0.99749499 0.59847214] =head1 DESCRIPTION Use the interface defined by L to provide a simple way to use the SLATEC interpolation routines (e.g. see L). Hence the name for this library - as returned by the C method - is C<"Slatec">. Currently, only the L are available (C). =head2 Attributes The following changes are made to the attributes of L: Attribute Flag Description bc sgr boundary conditions g g estimated gradient at x positions Attribute Default Allowed values bc "simple" see Boundary conditions section type "pch" Given the initial set of points C<(x,y)>, the C<"pch"> library estimates the gradient at these points using the given boundary conditions (as specified by the C attribute). The estimated gradient can be obtained using $gradient = $obj->get( 'g' ); As described in the L method, the C<"pch"> routines can also estimate the gradient, as well as the function value, for a set of C<$xi>. =head2 Boundary conditions for the pch routines If your data is monotonic, and you are not too bothered about edge effects, then the default value of C of C<"simple"> is for you. Otherwise, take a look at the description of L and use a hash reference for the C attribute, with the following keys: =over 3 =item monotonic 0 if the interpolant is to be monotonic in each interval (so the gradient will be 0 at each switch point), otherwise the gradient is calculated using a 3-point difference formula at switch points. If E 0 then the interpolant is forced to lie close to the data, if E 0 no such control is imposed. Default = B<0>. =item start A perl list of one or two elements. The first element defines how the boundary condition for the start of the array is to be calculated; it has a range of C<-5 .. 5>, as given for the C parameter of L. The second element, only used if options 2, 1, -1, or 2 are chosen, contains the value of the C parameter. Default = B<[ 0 ]>. =item end As for C, but for the end of the data. =back An example would be $obj->set( bc => { start => [ 1, 0 ], end => [ 1, -1 ] } which sets the first derivative at the first point to 0, and at the last point to -1. =head2 Errors The C method provides a simple mechanism to check if the previous method was successful. The C attribute contains the C<$ierr> piddle returned by the Slatec routine if a more precise diagnostic is required. To find out which routine was called, use the C method. =cut package PDL::Interpolate::Slatec; use PDL::Interpolate; use PDL::Slatec; use Carp; use strict; use vars qw( @ISA ); @ISA = qw ( PDL::Interpolate ); #################################################################### # #################################################################### # ## Public routines: sub new { my $this = shift; my $class = ref($this) || $this; my $self = $class->SUPER::new(); # note: do not send in values # change from PDL::Interpolate to PDL::Interpolate::Slatec bless ($self, $class); # change class attributes $self->_change_attr( bc => { required => 1, settable => 1 }, # already gettable ); $self->_set_value( bc => "simple", type => "pch" ); $self->_add_attr( g => { gettable => 1 }, ); $self->{flags}->{library} = "Slatec"; $self->{flags}->{routine} = "none"; # set variables $self->set( @_ ); return $self; } # sub: new #################################################################### # set up the interpolation # sub _initialise { my $self = shift; # set up error flags $self->{flags}->{status} = 0; $self->{flags}->{routine} = "none"; # get values in one go my ( $x, $y, $g, $bc ) = $self->_get_value( qw( x y g bc ) ); # check 1st dimention of x and y are the same # ie allow the possibility of threading my $xdim = $x->getdim( 0 ); my $ydim = $y->getdim( 0 ); croak "ERROR: x and y piddles must have the same first dimension.\n" unless $xdim == $ydim; # if a gradient has been specified, then we don't need to do anything # - other than check the dimensions if ( defined $g ) { croak "ERROR: gradient piddle must have the same first dimension as x and y.\n" unless $g->getdim( 0 ) == $xdim; $self->{flags}->{status} = 1; return; } my $ierr; if ( ref($bc) eq "HASH" ) { my $monotonic = $bc->{monotonic} || 0; my $start = $bc->{start} || [ 0 ]; my $end = $bc->{end} || [ 0 ]; my $ic = $x->short( $start->[0], $end->[0] ); my $vc = $x->float( 0, 0 ); # it will get promoted if required if ( $#$start == 1 ) { $vc->set( 0, $start->[1] ); } if ( $#$end == 1 ) { $vc->set( 1, $end->[1] ); } my $wk = $x->zeroes( $x->float, 2*$xdim ); ( $g, $ierr ) = chic( $ic, $vc, $monotonic, $x, $y, $wk ); $self->{flags}->{routine} = "chic"; } elsif ( $bc eq "simple" ) { # chim ( $g, $ierr ) = chim( $x, $y ); $self->{flags}->{routine} = "chim"; } else { # Unknown boundary condition croak "ERROR: unknown boundary condition <$bc>.\n"; # return; } $self->_set_value( g => $g, err => $ierr ); if ( all $ierr == 0 ) { # everything okay $self->{flags}->{status} = 1; } elsif ( any $ierr < 0 ) { # a problem $self->{flags}->{status} = 0; } else { # there were switches in monotonicity $self->{flags}->{status} = -1; } } # sub: _initialise #################################################################### =head2 interpolate =for usage my $yi = $obj->interpolate( $xi ); my ( $yi, $gi ) = $obj->interpolate( $xi ); =for ref Returns the interpolated function and derivative at a given set of points. If evaluated in scalar mode, it returns only the interpolated function values. =cut sub interpolate { my $self = shift; my $xi = shift; croak 'Usage: $obj->interpolate( $xi )' . "\n" unless defined $xi; # check everything is fine $self->_check_attr(); # get values in one go my ( $x, $y, $g ) = $self->_get_value( qw( x y g ) ); my ( $yi, $gi, $ierr ); if ( wantarray ) { ( $yi, $gi, $ierr ) = chfd( $x, $y, $g, 0, $xi ); $self->{flags}->{routine} = "chfd"; } else { ( $yi, $ierr ) = chfe( $x, $y, $g, 0, $xi ); $self->{flags}->{routine} = "chfe"; } # set err/status info $self->_set_value( err => $ierr ); if ( all $ierr == 0 ) { # everything okay $self->{flags}->{status} = 1; } elsif ( all $ierr > 0 ) { # extrapolation was required $self->{flags}->{status} = -1; } else { # a problem $self->{flags}->{status} = 0; } return wantarray ? ( $yi, $gi ) : $yi; } # sub: interpolate =head2 integrate =for usage my $ans = $obj->integrate( index => pdl( 2, 5 ) ); my $ans = $obj->integrate( x => pdl( 2.3, 4.5 ) ); =for ref Integrate the function stored in the PDL::Interpolate::Slatec object. The integration can either be between points of the original C array (C), or arbitrary x values (C). For both cases, a two element piddle should be given, to specify the start and end points of the integration. =over 7 =item index The values given refer to the indices of the points in the C array. =item x The array contains the actual values to integrate between. =back If the C method returns a value of -1, then one or both of the integration limits did not lie inside the C array. I with the result in such a case. The reason for using piddles, rather than arrays, is that it allows for threading. =cut sub integrate { my $self = shift; croak 'Usage: $obj->integrate( $type => $limits )' . "\n" unless $#_ == 1; # check everything is fine $self->_check_attr(); $self->{flags}->{status} = 0; $self->{flags}->{routine} = "none"; my ( $type, $indices ) = ( @_ ); croak "Unknown type ($type) sent to integrate method.\n" unless $type eq "x" or $type eq "index"; my $fdim = $indices->getdim(0); croak "Indices must have a first dimension of 2, not $fdim.\n" unless $fdim == 2; my $lo = $indices->slice('(0)'); my $hi = $indices->slice('(1)'); my ( $x, $y, $g ) = $self->_get_value( qw( x y g ) ); my ( $ans, $ierr ); if ( $type eq "x" ) { ( $ans, $ierr ) = chia( $x, $y, $g, 0, $lo, $hi ); $self->{flags}->{routine} = "chia"; if ( all $ierr == 0 ) { # everything okay $self->{flags}->{status} = 1; } elsif ( any $ierr < 0 ) { # a problem $self->{flags}->{status} = 0; } else { # out of range $self->{flags}->{status} = -1; } } else { ( $ans, $ierr ) = chid( $x, $y, $g, 0, $lo, $hi ); $self->{flags}->{routine} = "chid"; if ( all $ierr == 0 ) { # everything okay $self->{flags}->{status} = 1; } elsif ( all $ierr != -4 ) { # a problem $self->{flags}->{status} = 0; } else { # out of range (ierr == -4) $self->{flags}->{status} = -1; } } $self->_set_value( err => $ierr ); return $ans; } =head1 AUTHOR Copyright (C) 2000 Doug Burke (burke@ifa.hawaii.edu). All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. =head1 SEE ALSO L, L, perltoot(1). =cut #################################################################### # End with a true 1; PDL-2.018/Lib/Makefile.PL0000644060175006010010000000127512562522364013070 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; # Note Slatec now handles f77 availability itself # Func contains the Interpolate code undef &MY::postamble; # suppress warning *MY::postamble = sub { '' }; WriteMakefile( NAME => 'PDL::Lib', VERSION_FROM => '../Basic/Core/Version.pm', DIR => [ qw/Simplex ImageRGB Fit FFT Filter Image2D ImageND CallExt Slatec GSL GIS Transform Minuit Compression / ], PM => { map {($_ => '$(INST_LIBDIR)/'.$_)} grep { !defined $PDL::Config{WITH_SLATEC} || $PDL::Config{WITH_SLATEC}==1 || !($_ eq 'Gaussian.pm') } <*.pm> }, NO_MYMETA => 1, # Interpolate # Interpolate is broken ); PDL-2.018/Lib/Minuit/0000755060175006010010000000000013110402046012336 5ustar chmNonePDL-2.018/Lib/Minuit/FCN.c0000644060175006010010000000540012562522364013127 0ustar chmNone#ifdef NO_TRAILING_USCORE #define MNINIT mninit #define MNSETI mnseti #define MNPARM mnparm #define MNPARS mnpars #define MNEXCM mnexcm #define MNCOMD mncomd #define MNPOUT mnpout #define MNSTAT mnstat #define MNEMAT mnemat #define MNERRS mnerrs #define MNCONT mncont #define ABRE abre #define CIERRA cierra #else #define MNINIT mninit_ #define MNSETI mnseti_ #define MNPARM mnparm_ #define MNPARS mnpars_ #define MNEXCM mnexcm_ #define MNCOMD mncomd_ #define MNPOUT mnpout_ #define MNSTAT mnstat_ #define MNEMAT mnemat_ #define MNERRS mnerrs_ #define MNCONT mncont_ #define ABRE abre_ #define CIERRA cierra_ #endif static SV* mnfunname; static int ene; void FCN(int* npar,double* grad,double* fval,double* xval,int* iflag,double* futil); void FCN(int* npar,double* grad,double* fval,double* xval,int* iflag,double* futil){ SV* funname; int count,i; double* x; I32 ax ; pdl* pgrad; SV* pgradsv; pdl* pxval; SV* pxvalsv; int ndims; PDL_Indx *pdims; dSP; ENTER; SAVETMPS; /* get name of function on the Perl side */ funname = mnfunname; ndims = 1; pdims = (PDL_Indx *) PDL->smalloc( (STRLEN) ((ndims) * sizeof(*pdims)) ); pdims[0] = (PDL_Indx) ene; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pxvalsv = POPs; PUTBACK; pxval = PDL->SvPDLV(pxvalsv); PDL->converttype( &pxval, PDL_D, PDL_PERM ); PDL->children_changesoon(pxval,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (pxval,pdims,ndims); pxval->state &= ~PDL_NOMYDIMS; pxval->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(pxval,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("PDL", 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; pgradsv = POPs; PUTBACK; pgrad = PDL->SvPDLV(pgradsv); PDL->converttype( &pgrad, PDL_D, PDL_PERM ); PDL->children_changesoon(pgrad,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED); PDL->setdims (pgrad,pdims,ndims); pgrad->state &= ~PDL_NOMYDIMS; pgrad->state |= PDL_ALLOCATED | PDL_DONTTOUCHDATA; PDL->changed(pgrad,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0); pxval->data = (void *) xval; pgrad->data = (void *) grad; PUSHMARK(SP); XPUSHs(sv_2mortal(newSViv(*npar))); XPUSHs(pgradsv); XPUSHs(sv_2mortal(newSVnv(*fval))); XPUSHs(pxvalsv); XPUSHs(sv_2mortal(newSViv(*iflag))); PUTBACK; count=call_sv(funname,G_ARRAY); SPAGAIN; SP -= count ; ax = (SP - PL_stack_base) + 1 ; if (count!=2) croak("error calling perl function\n"); pgradsv = ST(1); pgrad = PDL->SvPDLV(pgradsv); x = (double *) pgrad->data; for(i=0;iimport; }; # Might want "ExtUtils::F77->import(qw(generic f2c))" if ($@ ne "") { $msg = "ExtUtils::F77 module not found. Ought not build PDL::Minuit"; goto skip unless $forcebuild; } else { $f77 = 'ExtUtils::F77'; print "(ExtUtils Version $ExtUtils::F77::VERSION)\n"; if ($ExtUtils::F77::VERSION < 1.03 ) { $msg = "Need a version of ExtUtils::F77 >= 1.03. Ought not build PDL::Minuit\n" ; goto skip unless $forcebuild; } } # end if ($@ ne "") } # if (exists $PDL::Config{F77CONF}... if (!$f77->testcompiler) { $msg = "No f77 compiler found. Ought to skip PDL::Minuit on this system"; $PDL::Config{WITH_MINUIT} = 0; } else { $PDL::Config{WITH_MINUIT} = 1; } skip: if ($msg ne "" && !$forcebuild) { write_dummy_make( $msg ); $PDL::Config{WITH_MINUIT} = 0; $donot = 1; } else { print "Building PDL::Minuit. Turn off WITH_MINUIT if there are any problems\n"; $PDL::Config{WITH_MINUIT} = 1; } return if $donot; my @pack = (["minuit.pd", qw(Minuit PDL::Minuit)]); if (defined($PDL::Config{MINUIT_LIB})){ # If libraries are specified, just need to build futils print "Using compiled CERN library: ".$PDL::Config{MINUIT_LIB}."...\n"; @minuitfiles = ("futils"); } else{ # Otherwise, we need to build the Minuit library as well print "Stand alone Minuit library will be built...\n"; @minuitfiles = ("futils", "minuit", "intracfalse"); } my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} .= join '', map {" minuitlib/${_}$Config{obj_ext} "} @minuitfiles; if($Config{cc} eq 'cl') { # Link to MinGW's libg2c.a and libgcc.a, if appropriate # First check that ExtUtils::F77 is available eval{require ExtUtils::F77}; unless($@) { my @f = (); my $drive = (split /:/, `gcc -v 2>&1`)[0]; $drive = substr($drive, -1, 1); for(split ' ', ExtUtils::F77->runtime) { if($_ =~ /^\-L/) { $_ =~ s#^\-L##; unless($_ =~ /:/) {$_ = $drive . ':' . $_} if(-e $_ . '/libg2c.a') {push @f, $_ . '/libg2c.a'} if(-e $_ . '/libgcc.a') {push @f, $_ . '/libgcc.a'} } } $hash{LDFROM} = $hash{OBJECT}; for(@f) {$hash{LDFROM} .= ' ' . $_} } } $hash{LIBS}[0] .= $f77->runtime ; $hash{clean}{FILES} .= join '', map {" minuitlib/$_.o "} @minuitfiles; # Handle multiple compilers $f2cbased = ($f77->runtime =~ /-lf2c/); $g2cbased = ($f77->runtime =~ /-lg2c/) unless $f2cbased; $hash{DEFINE} .= $f77->trail_ ? "" : "-DNO_TRAILING_USCORE"; ### unless($^O =~ /mswin32/i) { ### if (defined($PDL::Config{MINUIT_LIB})){ ### $hash{MYEXTLIB} .= (" ".$PDL::Config{MINUIT_LIB}." "); ### } ### else{ ### $hash{MYEXTLIB} .= " ./minuitlib/libminuit$Config::Config{lib_ext} "; ### $hash{clean}{FILES} .= " ./minuitlib/libminuit$Config::Config{lib_ext} "; ### } ### } undef &MY::postamble; # suppress warning *MY::postamble = sub { my $mycompiler = $f77->compiler(); my $mycflags = $f77->cflags(); my $orig = pdlpp_postamble_int(@pack); my $hack_64bit = ($Config{archname}=~m/x86_64/ ?" -fPIC " : ""); $orig =~ s/:\s*minuit\.pd/: minuit.pd/; $orig .= join "\n",map { (" minuitlib/$_\$(OBJ_EXT): minuitlib/$_.f $mycompiler -c $hack_64bit -o minuitlib/$_\$(OBJ_EXT) $mycflags minuitlib/$_.f " )} @minuitfiles; if (!defined($PDL::Config{MINUIT_LIB})){ my $libbuild; if($Config::Config{cc} eq 'cl') { $libbuild = " minuitlib/libminuit\$(LIB_EXT): minuitlib/minuit\$(OBJ_EXT) minuitlib/intracfalse\$(OBJ_EXT) \$(AR) -out:minuitlib/libminuit\$(LIB_EXT) minuitlib/minuit\$(OBJ_EXT) minuitlib/intracfalse\$(OBJ_EXT) \$(RANLIB) minuitlib/libminuit\$(LIB_EXT) "; } else { $libbuild = " minuitlib/libminuit\$(LIB_EXT): minuitlib/minuit\$(OBJ_EXT) minuitlib/intracfalse\$(OBJ_EXT) \$(AR) rv minuitlib/libminuit\$(LIB_EXT) minuitlib/minuit\$(OBJ_EXT) minuitlib/intracfalse\$(OBJ_EXT) \$(RANLIB) minuitlib/libminuit\$(LIB_EXT) "; } $orig .= $libbuild; } return $orig; }; # Remove i386 option for OS X recent versions for better build, dual arch does not work anyway. KG 25/Oct/2015 my %items; if ($Config{osname} =~ /darwin/ && version->parse($Config{osvers}) >=version->parse("14")) { # OS X Mavericks+ print "Forcing single arch build for MINUIT\n"; $items{LDDLFLAGS} = $Config{lddlflags}; $items{LDDLFLAGS} =~ s/-arch i386/ /g; } WriteMakefile( %hash, VERSION => "0.1", # This is overridden by VERSION_FROM in %hash %items ); PDL-2.018/Lib/Minuit/minuit.pd0000644060175006010010000004617113036512175014215 0ustar chmNonepp_bless('PDL::Minuit'); pp_add_exported('','mn_init mn_def_pars mn_excm mn_pout mn_stat mn_err mn_contour mn_emat'); pp_addhdr(' #include #include "FCN.c" extern void MNINIT(int*,int*,int*); extern void MNSETI(char*,int); extern void MNPARM(int*,char*,double*,double*,double*,double*,int*,int); extern void MNEXCM(void* f,char*,double*,int*,int*,double* futil,int); extern void MNPOUT(int*,char*,double*,double*,double*,double*,int*,int); extern void MNSTAT(double*,double*,double*,int*,int*,int*); extern void MNEMAT(double*,int*); /* Matrix here! */ extern void MNERRS(int*,double*,double*,double*,double*); extern void MNCONT(void* f,int*,int*,int*,double*,double*,int*,double* futil); extern void ABRE(int*,char*,char*,int,int); extern void CIERRA(int*); '); # add C code to the section preceding # the first MODULE keyword pp_addpm({At=>Top},<<'EOD'); # add perl code to the perl module that PP will create =head1 NAME PDL::Minuit -- a PDL interface to the Minuit library =head1 DESCRIPTION This package implements an interface to the Minuit minimization routines (part of the CERN Library) =head1 SYNOPSIS A basic fit with Minuit will call three functions in this package. First, a basic initialization is done with mn_init(). Then, the parameters are defined via the function mn_def_pars(), which allows setting upper and lower bounds. Then the function mn_excm() can be used to issue many Minuit commands, including simplex and migrad minimization algorithms (see Minuit manual for more details). See the test file minuit.t in the test (t/) directory for a basic example. EOD pp_addpm(' # Package variable my $mn_options; '); pp_addpm(' sub mn_init{ my $fun_ref = shift; $mn_options = { Log => undef, Title => \'Minuit Fit\', N => undef, Unit => undef, Function => $fun_ref, }; if ( @_ ){ my $args = $_[0]; for my $key (qw/ Log Title Unit/){ $mn_options->{$key} = $args->{$key} if exists $args->{$key}; } } # Check if there was a valid F77 available and barf # if there was not and the user is trying to pass Log if (defined($mn_options->{Log})) { $mn_options->{Unit} = 88 unless defined $mn_options->{Unit}; } else { $mn_options->{Unit} = 6; } if (defined (my $logfile = $mn_options->{Log})){ if (-e $logfile) { unlink $logfile; } PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,\'new\'); print STDERR "# Opening file $logfile....\n"; } PDL::Minuit::mninit(5,$mn_options->{Unit},$mn_options->{Unit}); PDL::Minuit::mnseti($mn_options->{Title}); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } } '); pp_def('mninit', Pars => 'int a();int b(); int c();', Code => 'MNINIT($P(a),$P(b),$P(c)); '); pp_addxs('',' void mnseti(str) char* str; CODE: int largo; largo = strlen(str); MNSETI(str,largo); '); # pp_def('mnseti', # Pars => '', # OtherPars => "char* str", # Code => 'int largo; largo = strlen($COMP(str)); # MNSETI($COMP(str),largo); # '); pp_def('mn_abre', Pars => 'int l();', OtherPars => 'char* nombre; char* mode;', Code => ' int l1,l2; l1 = strlen($COMP(nombre)); l2 = strlen($COMP(mode)); ABRE($P(l),$COMP(nombre),$COMP(mode),l1,l2); '); pp_def('mn_cierra', Pars => 'int l();', Code => 'CIERRA($P(l));' ); pp_addpm(' sub mn_def_pars{ my $pars = shift; my $steps = shift; my $n = nelem($pars); $mn_options->{N} = $n; #print "Unit :".$mn_options->{Unit}."\n"; my @names = (); for (my $i=0; $i < $n; $i++) { $names[$i] = "Par_$i"; } my $lo_bounds = zeroes($n); my $up_bounds = zeroes($n); if ( @_ ) { my $opts = $_[0]; $lo_bounds = $opts->{Lower_bounds} if defined $opts->{Lower_bounds}; $up_bounds = $opts->{Upper_bounds} if defined $opts->{Upper_bounds}; if (defined($opts->{Names})){ $names_t = $opts->{Names}; barf " Names has to be an array reference" unless ref($names_t) eq \'ARRAY\'; @names = @$names_t; barf " Names has to have as many elements as there are parameters " unless ( @names == $n); } } my $iflag = 0; if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,\'old\'); } foreach my $i ( 0..(nelem($pars)-1) ){ my $ii = $i + 1; $iflag = PDL::Minuit::mnparm($ii,$pars->slice("($i)"), $steps->slice("($i)"), $lo_bounds->slice("($i)"), $up_bounds->slice("($i)"), $names[$i]); barf "Problem initializing parameter $i in Minuit " unless ($iflag == 0); } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } } '); pp_def('mnparm', Pars => 'int a(); double b(); double c(); double d(); double e(); int [o] ia()', OtherPars => "char* str", Code => ' int largo; largo=strlen($COMP(str)); MNPARM($P(a),$COMP(str),$P(b),$P(c),$P(d),$P(e),$P(ia),largo); '); pp_addpm(' sub mn_excm{ my $command = shift; my $fun_ref = $mn_options->{Function}; my ($arglis,$narg); if ( @_ ) { $arglis = shift; $narg = nelem($arglis);} else { $arglis = pdl(0); $narg = 0; } if ( @_ ) { barf "Usage : mn_excm($command, [$arglis]) \n"; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,\'old\'); } my $iflag = pdl(0); $iflag = PDL::Minuit::mnexcm($arglis, $narg, $command, $fun_ref,$mn_options->{N}); warn "Problem executing command \'$command\' " unless ($iflag == 0); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return $iflag; } '); pp_def('mnexcm', Pars =>'double a(n); int ia(); int [o] ib();', OtherPars => 'char* str; SV* function; int numelem;', Code => 'double zero; int largo; largo=strlen($COMP(str)); ene = $COMP(numelem); zero = 0.0; mnfunname = $COMP(function); MNEXCM(FCN,$COMP(str),$P(a),$P(ia),$P(ib),&zero,largo); '); pp_addpm(' sub mn_pout{ barf "Usage: mn_pout(par_number)" unless ($#_ == 0); my $par_num = shift; my $n = $mn_options->{N}; if (($par_num < 1) || ($par_num > $n)) { barf "Parameter numbers range from 1 to $n "; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,\'old\'); } my $val = pdl(0); my $err = pdl(0); my $bnd1 = pdl(0); my $bnd2 = pdl(0); my $ivarbl = pdl(0); my $par_name = " "; PDL::Minuit::mnpout($par_num,$val,$err,$bnd1,$bnd2,$ivarbl,\$par_name); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($val,$err,$bnd1,$bnd2,$ivarbl,$par_name); } '); pp_def('mnpout', Pars => 'int ia(); double [o] a(); double [o] b(); double [o] c(); double [o] d();int [o] ib();', OtherPars => 'SV* str;', Code => 'STRLEN largo; SV* tempo; char* uuu; tempo = SvRV($COMP(str)); uuu = SvPV(tempo,largo); MNPOUT($P(ia),uuu,$P(a),$P(b),$P(c),$P(d),$P(ib),largo); sv_setpv(tempo,uuu); '); pp_addpm(' sub mn_stat{ if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,\'old\'); } my ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = PDL::Minuit::mnstat(); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($fmin,$fedm,$errdef,$npari,$nparx,$istat); } '); pp_def('mnstat', Pars => 'double [o] a(); double [o] b(); double [o] c(); int [o] ia(); int [o] ib(); int [o] ic();', Code => 'MNSTAT($P(a),$P(b),$P(c),$P(ia),$P(ib),$P(ic)); '); #OK pp_addpm(' sub mn_emat{ if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,\'old\'); } my ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = PDL::Minuit::mnstat(); my $n = $npari->sum; my $mat = zeroes($n,$n); PDL::Minuit::mnemat($mat); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return $mat; } '); pp_def('mnemat', Pars => 'double [o] mat(n,n);', Code => 'int numrows; numrows = $SIZE(n); MNEMAT($P(mat),&numrows); '); pp_addpm(' sub mn_err{ barf "Usage: mn_err(par_number)" unless ($#_ == 0); my $par_num = shift; my $n = $mn_options->{N}; if (($par_num < 1) || ($par_num > $n)) { barf "Parameter numbers range from 1 to $n "; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,\'old\'); } my ($eplus,$eminus,$eparab,$globcc) = PDL::Minuit::mnerrs($par_num); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($eplus,$eminus,$eparab,$globcc); } '); pp_def('mnerrs', Pars => 'int ia(); double [o] a(); double [o] b(); double [o] c(); double [o] d();', Code => 'MNERRS($P(ia),$P(a),$P(b),$P(c),$P(d)); '); pp_addpm(' sub mn_contour{ barf "Usage: mn_contour(par_number_1,par_number_2,npt)" unless ($#_ == 2); my $par_num_1 = shift; my $par_num_2 = shift; my $npt = shift; my $fun_ref = $mn_options->{Function}; my $n = $mn_options->{N}; if (($par_num_1 < 1) || ($par_num_1 > $n)) { barf "Parameter numbers range from 1 to $n "; } if (($par_num_2 < 1) || ($par_num_2 > $n)) { barf "Parameter numbers range from 1 to $n "; } if ($npt < 5) { barf "Have to specify at least 5 points in routine contour "; } my $xpt = zeroes($npt); my $ypt = zeroes($npt); my $nfound = pdl->new; PDL::Minuit::mncont($par_num_1,$par_num_2,$npt,$xpt,$ypt,$nfound,$fun_ref,$n); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($xpt,$ypt,$nfound); } '); pp_def('mncont', Pars => 'int ia(); int ib(); int ic(); double [o] a(n); double [o] b(n); int [o] id();', OtherPars => 'SV* function; int numelem;', Code => ' double zero; zero = 0.0; mnfunname = $COMP(function); ene = $COMP(numelem); MNCONT(FCN,$P(ia),$P(ib),$P(ic),$P(a),$P(b),$P(id),&zero); '); pp_addpm(<<'EOD'); # the rest of the FUNCTIONS documentation part =head2 mn_init() =for ref The function mn_init() does the basic initialization of the fit. The first argument has to be a reference to the function to be minimized. The function to be minimized has to receive five arguments ($npar,$grad,$fval,$xval,$iflag). The first is the number of parameters currently variable. The second is the gradient of the function (which is not necessarily used, see the Minuit documentation). The third is the current value of the function. The fourth is a piddle with the values of the parameters. The fifth is an integer flag, which indicates what the function is supposed to calculate. The function has to return the values ($fval,$grad), the function value and the function gradient. There are three optional arguments to mn_init(). By default, the output of Minuit will come through STDOUT unless a filename $logfile is given in the Log option. Note that this will mercilessly erase $logfile if it already exists. Additionally, a title can be given to the fit by the Title option, the default is 'Minuit Fit'. If the output is written to a logfile, this is assigned Fortran unit number 88. If for whatever reason you want to have control over the unit number that Fortran associates to the logfile, you can pass the number through the Unit option. =for usage Usage: mn_init($function_ref,{Log=>$logfile,Title=>$title,Unit=>$unit}) =for example Example: mn_init(\&my_function); #same as above but outputting to a file 'log.out'. #title for fit is 'My fit' mn_init(\&my_function, {Log => 'log.out', Title => 'My fit'}); sub my_function{ # the five variables input to the function to be minimized # xval is a piddle containing the current values of the parameters my ($npar,$grad,$fval,$xval,$iflag) = @_; # Here is code computing the value of the function # and potentially also its gradient # ...... # return the two variables. If no gradient is being computed # just return the $grad that came as input return ($fval, $grad); } =head2 mn_def_pars() =for ref The function mn_def_pars() defines the initial values of the parameters of the function to be minimized and the value of the initial steps around these values that the minimizer will use for the first variations of the parameters in the search for the minimum. There are several optional arguments. One allows assigning names to these parameters which otherwise get names (Par_0, Par_1,....,Par_n) by default. Another two arguments can give lower and upper bounds for the parameters via two piddles. If the lower and upper bound for a given parameter are both equal to 0 then the parameter is unbound. By default these lower and upper bound piddles are set to zeroes(n), where n is the number of parameters, i.e. the parameters are unbound by default. The function needs two input variables: a piddle giving the initial values of the parameters and another piddle giving the initial steps. An optional reference to a perl array with the variable names can be passed, as well as piddles with upper and lower bounds for the parameters (see example below). It returns an integer variable which is 0 upon success. =for usage Usage: $iflag = mn_def_pars($pars, $steps,{Names => \@names, Lower_bounds => $lbounds, Upper_bounds => $ubounds}) =for example Example: #initial parameter values my $pars = pdl(2.5,3.0); #steps my $steps = pdl(0.3,0.5); #parameter names my @names = ('intercept','slope'); #use mn_def_pars with default parameter names (Par_0,Par_1,...) my $iflag = mn_def_pars($pars,$steps); #use of mn_def_pars explicitly specify parameter names $iflag = mn_def_pars($pars,$steps,{Names => \@names}); # specify lower and upper bounds for the parameters. # The example below leaves parameter 1 (intercept) unconstrained # and constrains parameter 2 (slope) to be between 0 and 100 my $lbounds = pdl(0, 0); my $ubounds = pdl(0, 100); $iflag = mn_def_pars($pars,$steps,{Names => \@names, Lower_bounds => $lbounds, Upper_bounds => $ubounds}}); #same as above because $lbounds is by default zeroes(n) $iflag = mn_def_pars($pars,$steps,{Names => \@names, Upper_bounds => $ubounds}}); =head2 mn_excm() The function mn_excm() executes a Minuit command passed as a string. The first argument is the command string and an optional second argument is a piddle with arguments to the command. The available commands are listed in Chapter 4 of the Minuit manual (see url below). It returns an integer variable which is 0 upon success. =for usage Usage: $iflag = mn_excm($command_string, {$arglis}) =for example Example: #start a simplex minimization my $iflag = mn_excm('simplex'); #same as above but specify the maximum allowed numbers of #function calls in the minimization my $arglist = pdl(1000); $iflag = mn_excm('simplex',$arglist); #start a migrad minimization $iflag = mn_excm('migrad') #set Minuit strategy in order to get the most reliable results $arglist = pdl(2) $iflag = mn_excm('set strategy',$arglist); # each command can be specified by a minimal string that uniquely # identifies it (see Chapter 4 of Minuit manual). The comannd above # is equivalent to: $iflag = mn_excm('set stra',$arglis); =head2 mn_pout() The function mn_pout() gets the current value of a parameter. It takes as input the parameter number and returns an array with the parameter value, the current estimate of its uncertainty (0 if parameter is constant), lower bound on the parameter, if any (otherwise 0), upper bound on the parameter, if any (otherwise 0), integer flag (which is equal to the parameter number if variable, zero if the parameter is constant and negative if parameter is not defined) and the parameter name. =for usage Usage: ($val,$err,$bnd1,$bnd2,$ivarbl,$par_name) = mn_pout($par_number); =head2 mn_stat() The function mn_stat() gets the current status of the minimization. It returns an array with the best function value found so far, the estimated vertical distance remaining to minimum, the value of UP defining parameter uncertainties (default is 1), the number of currently variable parameters, the highest parameter defined and an integer flag indicating how good the covariance matrix is (0=not calculated at all; 1=diagonal approximation, not accurate; 2=full matrix, but forced positive definite; 3=full accurate matrix) =for usage Usage: ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = mn_stat(); =head2 mn_emat() The function mn_emat returns the covariance matrix as a piddle. =for usage Usage: $emat = mn_emat(); =head2 mn_err() The function mn_err() returns the current existing values for the error in the fitted parameters. It returns an array with the positive error, the negative error, the "parabolic" parameter error from the error matrix and the global correlation coefficient, which is a number between 0 and 1 which gives the correlation between the requested parameter and that linear combination of all other parameters which is most strongly correlated with it. Unless the command 'MINOS' has been issued via the function mn_excm(), the first three values will be equal. =for usage Usage: ($eplus,$eminus,$eparab,$globcc) = mn_err($par_number); =head2 mn_contour() The function mn_contour() finds contours of the function being minimized with respect to two chosen parameters. The contour level is given by F_min + UP, where F_min is the minimum of the function and UP is the ERRordef specified by the user, or 1.0 by default (see Minuit manual). The contour calculated by this function is dynamic, in the sense that it represents the minimum of the function being minimized with respect to all the other NPAR-2 parameters (if any). The function takes as input the parameter numbers with respect to which the contour is to be determined (two) and the number of points $npt required on the contour (>4). It returns an array with piddles $xpt,$ypt containing the coordinates of the contour and a variable $nfound indicating the number of points actually found in the contour. If all goes well $nfound will be equal to $npt, but it can be negative if the input arguments are not valid, zero if less than four points have been found or <$npt if the program could not find $npt points. =for usage Usage: ($xpt,$ypt,$nfound) = mn_contour($par_number_1,$par_number_2,$npt) =head1 SEE ALSO L The Minuit documentation is online at http://wwwasdoc.web.cern.ch/wwwasdoc/minuit/minmain.html =head1 AUTHOR This file copyright (C) 2007 Andres Jordan . All rights reserved. There is no warranty. You are allowed to redistribute this software/documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); # you will need this to finish pp processing PDL-2.018/Lib/Minuit/minuitlib/0000755060175006010010000000000013110402046014332 5ustar chmNonePDL-2.018/Lib/Minuit/minuitlib/futils.f0000644060175006010010000000035712562522364016034 0ustar chmNone subroutine abre(n,nombre,mode) integer n character*(*) nombre character*(*) mode open(unit=n,file=nombre,status=mode) end subroutine cierra(n) integer n close(n) end PDL-2.018/Lib/Minuit/minuitlib/intracfalse.f0000644060175006010010000000015312562522364017013 0ustar chmNone logical function intrac() c logical intrac intrac = .false. return end PDL-2.018/Lib/Minuit/minuitlib/minuit.f0000644060175006010010000106307112562522364016036 0ustar chmNonecdeck id>, minuit. subroutine minuit(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c c cpnam parameter name (10 characters) c u external (visible to user in fcn) value of parameter c alim, blim lower and upper parameter limits. if both zero, no limits. c erp,ern positive and negative minos errors, if calculated. c werr external parameter error (standard deviation, defined by up) c globcc global correlation coefficient c nvarl =-1 if parameter undefined, =0 if constant, c = 1 if variable without limits, =4 if variable with limits c (note that if parameter has been fixed, nvarl=1 or =4, and niofex=0) c niofex internal parameter number, or zero if not currently variable c nexofi external parameter number for currently variable parameters c x, xt internal parameter values (x are sometimes saved in xt) c dirin (internal) step sizes for current step c variables with names ending in ..s are saved values for fixed params c vhmat (internal) error matrix stored as half matrix, since c it is symmetric c vthmat vhmat is sometimes saved in vthmat, especially in mnmnot c c isw definitions: c isw(1) =0 normally, =1 means call limit exceeded c isw(2) =0 means no error matrix c =1 means only approximate error matrix c =2 means full error matrix, but forced pos-def. c =3 means good normal full error matrix exists c isw(3) =0 if minuit is calculating the first derivatives c =1 if first derivatives calculated inside fcn c isw(4) =-1 if most recent minimization did not converge. c = 0 if problem redefined since most recent minimization. c =+1 if most recent minimization did converge. c isw(5) is the print level. see sho printlevel c isw(6) = 0 for batch mode, =1 for interactive mode c c lwarn is true if warning messges are to be put out (default=true) c set warn turns it on, set nowarn turns it off c lrepor is true if exceptional conditions are put out (default=false) c set debug turns it on, set nodebug turns it off c limset is true if a parameter is up against limits (for minos) c lnolim is true if there are no limits on any parameters (not yet used) c lnewmn is true if the previous process has unexpectedly improved fcn c lphead is true if a heading should be put out for the next parameter c definition, false if a parameter has just been defined c external fcn,futil character*40 cwhyxt data cwhyxt/'for unknown reasons '/ data jsysrd,jsyswr,jsyssa/5,6,7/ c . . . . . . . . . . initialize minuit write (jsyswr,'(1x,75(1h*))') call mninit (jsysrd,jsyswr,jsyssa) c . . . . initialize new data block 100 continue write (isyswr,'(1x,75(1h*))') nblock = nblock + 1 write (isyswr,'(26x,a,i4)') 'minuit data block no.',nblock write (isyswr,'(1x,75(1h*))') c . . . . . . . . . . . set parameter lists to undefined call mncler c . . . . . . . . read title call mnread(fcn,1,iflgut,futil) if (iflgut .eq. 2) go to 500 if (iflgut .eq. 3) go to 600 c . . . . . . . . read parameters call mnread(fcn,2,iflgut,futil) if (iflgut .eq. 2) go to 500 if (iflgut .eq. 3) go to 600 if (iflgut .eq. 4) go to 700 c . . . . . . verify fcn not time-dependent write (isyswr,'(/a,a)') ' minuit: first call to user function,', + ' with iflag=1' nparx = npar call mninex(x) fzero = undefi call fcn(nparx,gin,fzero,u,1,futil) first = undefi call fcn(nparx,gin,first,u,4,futil) nfcn = 2 if (fzero.eq.undefi .and. first.eq.undefi) then cwhyxt = 'by error in user function. ' write (isyswr,'(/a,a/)') ' user has not calculated function', + ' value when iflag=1 or 4' go to 800 endif amin = first if (first .eq. undefi) amin=fzero call mnprin(1,amin) nfcn = 2 if (first .eq. fzero) go to 300 fnew = 0.0 call fcn(nparx,gin,fnew,u,4,futil) if (fnew .ne. amin) write (isyswr,280) amin, fnew 280 format (/' minuit warning: probable error in user function.'/ + ' for fixed values of parameters, fcn is time-dependent'/ + ' f =',e22.14,' for first call'/ + ' f =',e22.14,' for second call.'/) nfcn = 3 300 fval3 = 2.0*amin+1.0 c . . . . . . . . . . . read commands call mnread(fcn,3,iflgut,futil) if (iflgut .eq. 2) go to 500 if (iflgut .eq. 3) go to 600 if (iflgut .eq. 4) go to 700 cwhyxt = 'by minuit command: '//cword if (index(cword,'stop').gt. 0) go to 800 if (index(cword,'exi') .gt. 0) go to 800 if (index(cword,'ret') .eq. 0) go to 100 cwhyxt = 'and returns to user program. ' write (isyswr,'(a,a)') ' ..........minuit terminated ',cwhyxt return c . . . . . . stop conditions 500 continue cwhyxt = 'by end-of-data on primary input file. ' go to 800 600 continue cwhyxt = 'by unrecoverable read error on input. ' go to 800 700 continue cwhyxt = ': fatal error in parameter definitions. ' 800 write (isyswr,'(a,a)') ' ..........minuit terminated ',cwhyxt stop c c ......................entry to set unit numbers - - - - - - - - - - entry mintio(i1,i2,i3) jsysrd = i1 jsyswr = i2 jsyssa = i3 return end cdeck id>, mnamin. subroutine mnamin(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from many places. initializes the value of amin by cc calling the user function. prints out the function value and cc parameter values if print flag value is high enough. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil nparx = npar if (isw(5) .ge. 1) write (isyswr,'(/a,a)') ' first call to ', + 'user function at new start point, with iflag=4.' call mnexin(x) call fcn(nparx,gin,fnew,u,4,futil) nfcn = nfcn + 1 amin = fnew edm = bigedm return end cdeck id>, mnbins. subroutine mnbins(a1,a2,naa,bl,bh,nb,bwid) c ************ double precision version ************* implicit double precision (a-h,o-z) c subroutine to determine reasonable histogram intervals c given absolute upper and lower bounds a1 and a2 c and desired maximum number of bins naa c program makes reasonable binning from bl to bh of width bwid c f. james, august, 1974 , stolen for minuit, 1988 parameter (zero=0.0) al = min(a1,a2) ah = max(a1,a2) if (al.eq.ah) ah = al + 1. c if naa .eq. -1 , program uses bwid input from calling routine if (naa .eq. -1) go to 150 10 na = naa - 1 if (na .lt. 1) na = 1 c get nominal bin width in expon form 20 awid = (ah-al)/float(na) log = int(log10(awid)) if (awid .le. 1.0) log=log-1 sigfig = awid * (10.00 **(-log)) c round mantissa up to 2, 2.5, 5, or 10 if(sigfig .gt. 2.0) go to 40 sigrnd = 2.0 go to 100 40 if (sigfig .gt. 2.5) go to 50 sigrnd = 2.5 go to 100 50 if(sigfig .gt. 5.0) go to 60 sigrnd =5.0 go to 100 60 sigrnd = 1.0 log = log + 1 100 continue bwid = sigrnd*10.0**log go to 200 c get new bounds from new width bwid 150 if (bwid .le. zero) go to 10 200 continue alb = al/bwid lwid=alb if (alb .lt. zero) lwid=lwid-1 bl = bwid*float(lwid) alb = ah/bwid + 1.0 kwid = alb if (alb .lt. zero) kwid=kwid-1 bh = bwid*float(kwid) nb = kwid-lwid if (naa .gt. 5) go to 240 if (naa .eq. -1) return c request for one bin is difficult case if (naa .gt. 1 .or. nb .eq. 1) return bwid = bwid*2.0 nb = 1 return 240 if (2*nb .ne. naa) return na = na + 1 go to 20 end cdeck id>, mncalf. subroutine mncalf(fcn,pvec,ycalf,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called only from mnimpr. transforms the function fcn cc by dividing out the quadratic part in order to find further cc minima. calculates ycalf = (f-fmin)/(x-xmin)*v*(x-xmin) cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension pvec(15) nparx = npar call mninex(pvec) call fcn(nparx,gin,f,u,4,futil) nfcn = nfcn + 1 do 200 i= 1, npar grd(i) = 0. do 200 j= 1, npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n 200 grd(i) = grd(i) + vthmat(ndex) * (xt(j)-pvec(j)) denom = 0. do 210 i= 1, npar 210 denom = denom + grd(i) * (xt(i)-pvec(i)) if (denom .le. zero) then dcovar = 1. isw(2) = 0 denom = 1.0 endif ycalf = (f-apsi) / denom return end cdeck id>, mncler. subroutine mncler c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from minuit and by option from mnexcm cc resets the parameter list to undefined parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead npfix = 0 nu = 0 npar = 0 nfcn = 0 nwrmes(1) = 0 nwrmes(2) = 0 do 10 i= 1, maxext u(i) = 0.0 cpnam(i) = cundef nvarl(i) = -1 10 niofex(i) = 0 call mnrset(1) cfrom = 'clear ' nfcnfr = nfcn cstatu ='undefined ' lnolim = .true. lphead = .true. return end cdeck id>, mncntr. subroutine mncntr(fcn,ke1,ke2,ierrf,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc to print function contours in two variables, on line printer cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil parameter (numbcs=20,nxmax=115) dimension contur(numbcs), fcna(nxmax),fcnb(nxmax) character clabel*(numbcs) character chln*(nxmax),chmid*(nxmax),chzero*(nxmax) data clabel/'0123456789abcdefghij'/ c input arguments: parx, pary, devs, ngrid if (ke1.le.0 .or. ke2.le.0) go to 1350 if (ke1.gt.nu .or. ke2.gt.nu) go to 1350 ki1 = niofex(ke1) ki2 = niofex(ke2) if (ki1.le.0 .or. ki2.le.0) go to 1350 if (ki1 .eq. ki2) go to 1350 c if (isw(2) .lt. 1) then call mnhess(fcn,futil) call mnwerr endif nparx = npar xsav = u(ke1) ysav = u(ke2) devs = word7(3) if (devs .le. zero) devs=2. xlo = u(ke1) - devs*werr(ki1) xup = u(ke1) + devs*werr(ki1) ylo = u(ke2) - devs*werr(ki2) yup = u(ke2) + devs*werr(ki2) ngrid = word7(4) if (ngrid .le. 0) then ngrid=25 nx = min(npagwd-15,ngrid) ny = min(npagln-7, ngrid) else nx = ngrid ny = ngrid endif if (nx .lt. 11) nx=11 if (ny .lt. 11) ny=11 if (nx .ge. nxmax) nx=nxmax-1 c ask if parameter outside limits if (nvarl(ke1) .gt. 1) then if (xlo .lt. alim(ke1)) xlo = alim(ke1) if (xup .gt. blim(ke1)) xup = blim(ke1) endif if (nvarl(ke2) .gt. 1) then if (ylo .lt. alim(ke2)) ylo = alim(ke2) if (yup .gt. blim(ke2)) yup = blim(ke2) endif bwidx = (xup-xlo)/real(nx) bwidy = (yup-ylo)/real(ny) ixmid = int((xsav-xlo)*real(nx)/(xup-xlo)) + 1 if (amin .eq. undefi) call mnamin(fcn,futil) do 185 i= 1, numbcs contur(i) = amin + up*float(i-1)**2 185 continue contur(1) = contur(1) + 0.01*up c fill fcnb to prepare first row, and find column zero u(ke2) = yup ixzero = 0 xb4 = one do 200 ix= 1, nx+1 u(ke1) = xlo + real(ix-1)*bwidx call fcn(nparx,gin,ff,u,4,futil) fcnb(ix) = ff if (xb4.lt.zero .and. u(ke1).gt.zero) ixzero = ix-1 xb4 = u(ke1) chmid(ix:ix) = '*' chzero(ix:ix)= '-' 200 continue write (isyswr,'(a,i3,a,a)') ' y-axis: parameter ', + ke2,': ',cpnam(ke2) if (ixzero .gt. 0) then chzero(ixzero:ixzero) = '+' chln = ' ' write (isyswr,'(12x,a,a)') chln(1:ixzero),'x=0' endif c loop over rows do 280 iy= 1, ny unext = u(ke2) - bwidy c prepare this line's background pattern for contour chln = ' ' chln(ixmid:ixmid) = '*' if (ixzero .ne. 0) chln(ixzero:ixzero) = ':' if (u(ke2).gt.ysav .and. unext.lt.ysav) chln=chmid if (u(ke2).gt.zero .and. unext.lt.zero) chln=chzero u(ke2) = unext ylabel = u(ke2) + 0.5*bwidy c move fcnb to fcna and fill fcnb with next row do 220 ix= 1, nx+1 fcna(ix) = fcnb(ix) u(ke1) = xlo + real(ix-1)*bwidx call fcn(nparx,gin,ff,u,4,futil) fcnb(ix) = ff 220 continue c look for contours crossing the fcnxy squares do 250 ix= 1, nx fmx = max(fcna(ix),fcnb(ix),fcna(ix+1),fcnb(ix+1)) fmn = min(fcna(ix),fcnb(ix),fcna(ix+1),fcnb(ix+1)) do 230 ics= 1, numbcs if (contur(ics) .gt. fmn) go to 240 230 continue go to 250 240 if (contur(ics) .lt. fmx) chln(ix:ix)=clabel(ics:ics) 250 continue c print a row of the contour plot write (isyswr,'(1x,g12.4,1x,a)') ylabel,chln(1:nx) 280 continue c contours printed, label x-axis chln = ' ' chln( 1: 1) = 'i' chln(ixmid:ixmid) = 'i' chln(nx:nx) = 'i' write (isyswr,'(14x,a)') chln(1:nx) c the hardest of all: print x-axis scale! chln = ' ' if (nx .le. 26) then nl = max(nx-12,2) nl2 = nl/2 write (isyswr,'(8x,g12.4,a,g12.4)') xlo,chln(1:nl),xup write (isyswr,'(14x,a,g12.4)') chln(1:nl2),xsav else nl = max(nx-24,2)/2 nl2 = nl if (nl .gt. 10) nl2=nl-6 write (isyswr,'(8x,g12.4,a,g12.4,a,g12.4)') xlo, + chln(1:nl),xsav,chln(1:nl2),xup endif write (isyswr,'(6x,a,i3,a,a,a,g12.4)') ' x-axis: parameter', + ke1,': ',cpnam(ke1),' one column=',bwidx write (isyswr,'(a,g12.4,a,g12.4,a)') ' function values: f(i)=', + amin,' +',up,' *i**2' c finished. reset input values u(ke1) = xsav u(ke2) = ysav ierrf = 0 return 1350 write (isyswr,1351) 1351 format (' invalid parameter number(s) requested. ignored.' /) ierrf = 1 return end cdeck id>, mncont. subroutine mncont(fcn,ke1,ke2,nptu,xptu,yptu,ierrf,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc find nptu points along a contour where the function cc fmin (x(ke1),x(ke2)) = amin+up cc where fmin is the minimum of fcn with respect to all cc the other npar-2 variable parameters (if any). cc ierrf on return will be equal to the number of points found: cc nptu if normal termination with nptu points found cc -1 if errors in the calling sequence (ke1, ke2 not variable) cc 0 if less than four points can be found (using mnmnot) cc n>3 if only n points can be found (n < nptu) cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension xptu(nptu), yptu(nptu), w(mni),gcc(mni) character chere*10 parameter (chere='mncontour ') logical ldebug external fcn,futil c input arguments: parx, pary, devs, ngrid ldebug = (idbg(6) .ge. 1) if (ke1.le.0 .or. ke2.le.0) go to 1350 if (ke1.gt.nu .or. ke2.gt.nu) go to 1350 ki1 = niofex(ke1) ki2 = niofex(ke2) if (ki1.le.0 .or. ki2.le.0) go to 1350 if (ki1 .eq. ki2) go to 1350 if (nptu .lt. 4) go to 1400 c nfcnco = nfcn nfcnmx = 100*(nptu+5)*(npar+1) c the minimum call mncuve(fcn,futil) u1min = u(ke1) u2min = u(ke2) ierrf = 0 cfrom = chere nfcnfr = nfcnco if (isw(5) .ge. 0) then write (isyswr,'(1x,a,i4,a)') + 'start mncontour calculation of',nptu,' points on contour.' if (npar .gt. 2) then if (npar .eq. 3) then ki3 = 6 - ki1 - ki2 ke3 = nexofi(ki3) write (isyswr,'(1x,a,i3,2x,a)') + 'each point is a minimum with respect to parameter ', + ke3, cpnam(ke3) else write (isyswr,'(1x,a,i3,a)') + 'each point is a minimum with respect to the other', + npar-2, ' variable parameters.' endif endif endif c c find the first four points using mnmnot c ........................ first two points call mnmnot(fcn,ke1,ke2,val2pl,val2mi,futil) if (ern(ki1) .eq. undefi) then xptu(1) = alim(ke1) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (ern(ki1) .ge. zero) go to 1500 xptu(1) = u1min+ern(ki1) endif yptu(1) = val2mi c if (erp(ki1) .eq. undefi) then xptu(3) = blim(ke1) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (erp(ki1) .le. zero) go to 1500 xptu(3) = u1min+erp(ki1) endif yptu(3) = val2pl scalx = 1.0/(xptu(3) - xptu(1)) c ........................... next two points call mnmnot(fcn,ke2,ke1,val2pl,val2mi,futil) if (ern(ki2) .eq. undefi) then yptu(2) = alim(ke2) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (ern(ki2) .ge. zero) go to 1500 yptu(2) = u2min+ern(ki2) endif xptu(2) = val2mi if (erp(ki2) .eq. undefi) then yptu(4) = blim(ke2) call mnwarn('w',chere,'contour squeezed by parameter limits.') else if (erp(ki2) .le. zero) go to 1500 yptu(4) = u2min+erp(ki2) endif xptu(4) = val2pl scaly = 1.0/(yptu(4) - yptu(2)) nowpts = 4 next = 5 if (ldebug) then write (isyswr,'(a)') ' plot of four points found by minos' xpt(1) = u1min ypt(1) = u2min chpt(1) = ' ' nall = min(nowpts+1,maxcpt) do 85 i= 2, nall xpt(i) = xptu(i-1) ypt(i) = yptu(i-1) 85 continue chpt(2)= 'a' chpt(3)= 'b' chpt(4)= 'c' chpt(5)= 'd' call mnplot(xpt,ypt,chpt,nall,isyswr,npagwd,npagln) endif c c ..................... save some values before fixing isw2 = isw(2) isw4 = isw(4) sigsav = edm istrav = istrat dc = dcovar apsi = epsi*0.5 abest=amin mpar=npar nfmxin = nfcnmx do 125 i= 1, mpar 125 xt(i) = x(i) do 130 j= 1, mpar*(mpar+1)/2 130 vthmat(j) = vhmat(j) do 135 i= 1, mpar gcc(i) = globcc(i) 135 w(i) = werr(i) c fix the two parameters in question kints = niofex(ke1) call mnfixp (kints,ierr) kints = niofex(ke2) call mnfixp (kints,ierr) c ......................fill in the rest of the points do 900 inew= next, nptu c find the two neighbouring points with largest separation bigdis = 0. do 200 iold = 1, inew-1 i2 = iold + 1 if (i2 .eq. inew) i2 = 1 dist = (scalx*(xptu(iold)-xptu(i2)))**2 + + (scaly*(yptu(iold)-yptu(i2)))**2 if (dist .gt. bigdis) then bigdis = dist idist = iold endif 200 continue i1 = idist i2 = i1 + 1 if (i2 .eq. inew) i2 = 1 c next point goes between i1 and i2 a1 = half a2 = half 300 xmidcr = a1*xptu(i1) + a2*xptu(i2) ymidcr = a1*yptu(i1) + a2*yptu(i2) xdir = yptu(i2) - yptu(i1) ydir = xptu(i1) - xptu(i2) sclfac = max(abs(xdir*scalx), abs(ydir*scaly)) xdircr = xdir/sclfac ydircr = ydir/sclfac ke1cr = ke1 ke2cr = ke2 c find the contour crossing point along dir amin = abest call mncros(fcn,aopt,iercr,futil) if (iercr .gt. 1) then c if cannot find mid-point, try closer to point 1 if (a1 .gt. half) then write (isyswr,'(a,a,i3,a)') ' mncont cannot find next', + ' point on contour. only ',nowpts,' points found.' go to 950 endif call mnwarn('w',chere,'cannot find midpoint, try closer.') a1 = 0.75 a2 = 0.25 go to 300 endif c contour has been located, insert new point in list do 830 move= nowpts,i1+1,-1 xptu(move+1) = xptu(move) yptu(move+1) = yptu(move) 830 continue nowpts = nowpts + 1 xptu(i1+1) = xmidcr + xdircr*aopt yptu(i1+1) = ymidcr + ydircr*aopt 900 continue 950 continue c ierrf = nowpts cstatu = 'successful' if (nowpts .lt. nptu) cstatu = 'incomplete' c make a lineprinter plot of the contour if (isw(5) .ge. 0) then xpt(1) = u1min ypt(1) = u2min chpt(1) = ' ' nall = min(nowpts+1,maxcpt) do 1000 i= 2, nall xpt(i) = xptu(i-1) ypt(i) = yptu(i-1) chpt(i)= 'x' 1000 continue write (isyswr,'(a,i3,2x,a)') ' y-axis: parameter ',ke2, + cpnam(ke2) call mnplot(xpt,ypt,chpt,nall,isyswr,npagwd,npagln) write (isyswr,'(25x,a,i3,2x,a)') 'x-axis: parameter ', + ke1,cpnam(ke1) endif c print out the coordinates around the contour if (isw(5) .ge. 1) then npcol = (nowpts+1)/2 nfcol = nowpts/2 write (isyswr,'(/i5,a,g13.5,a,g11.3)') nowpts, + ' points on contour. fmin=',abest,' errdef=',up write (isyswr,'(9x,a,3x,a,18x,a,3x,a)') + cpnam(ke1),cpnam(ke2),cpnam(ke1),cpnam(ke2) do 1050 line = 1, nfcol lr = line + npcol write (isyswr,'(1x,i5,2g13.5,10x,i5,2g13.5)') + line,xptu(line),yptu(line),lr,xptu(lr),yptu(lr) 1050 continue if (nfcol .lt. npcol) write (isyswr,'(1x,i5,2g13.5)') + npcol,xptu(npcol),yptu(npcol) endif c . . contour finished. reset v itaur = 1 call mnfree(1) call mnfree(1) do 1100 j= 1, mpar*(mpar+1)/2 1100 vhmat(j) = vthmat(j) do 1120 i= 1, mpar globcc(i) = gcc(i) werr(i) = w(i) 1120 x(i) = xt(i) call mninex (x) edm = sigsav amin = abest isw(2) = isw2 isw(4) = isw4 dcovar = dc itaur = 0 nfcnmx = nfmxin istrat = istrav u(ke1) = u1min u(ke2) = u2min go to 2000 c error returns 1350 write (isyswr,'(a)') ' invalid parameter numbers.' go to 1450 1400 write (isyswr,'(a)') ' less than four points requested.' 1450 ierrf = -1 cstatu = 'user error' go to 2000 1500 write (isyswr,'(a)') ' mncont unable to find four points.' u(ke1) = u1min u(ke2) = u2min ierrf = 0 cstatu = 'failed' 2000 continue cfrom = chere nfcnfr = nfcnco return end cdeck id>, mncrck. subroutine mncrck(crdbuf,maxcwd,comand,lnc, + mxp, plist, llist,ierr,isyswr) c ************ double precision version ************* implicit double precision (a-h,o-z) cc cc called from mnread. cc cracks the free-format input, expecting zero or more cc alphanumeric fields (which it joins into comand(1:lnc)) cc followed by one or more numeric fields separated by cc blanks and/or one comma. the numeric fields are put into cc the llist (but at most mxp) elements of plist. cc ierr = 0 if no errors, cc = 1 if error(s). cc diagnostic messages are written to isyswr cc parameter (maxelm=25, mxlnel=19) character*(*) comand, crdbuf character cnumer*13, celmnt(maxelm)*(mxlnel), cnull*15 dimension lelmnt(maxelm),plist(mxp) data cnull /')null string '/ data cnumer/'123456789-.0+'/ ielmnt = 0 lend = len(crdbuf) nextb = 1 ierr = 0 c . . . . loop over words celmnt 10 continue do 100 ipos= nextb,lend ibegin = ipos if (crdbuf(ipos:ipos).eq.' ') go to 100 if (crdbuf(ipos:ipos).eq.',') go to 250 go to 150 100 continue go to 300 150 continue c found beginning of word, look for end do 180 ipos = ibegin+1,lend if (crdbuf(ipos:ipos).eq.' ') go to 250 if (crdbuf(ipos:ipos).eq.',') go to 250 180 continue ipos = lend+1 250 iend = ipos-1 ielmnt = ielmnt + 1 if (iend .ge. ibegin) then celmnt(ielmnt) = crdbuf(ibegin:iend) else celmnt(ielmnt) = cnull endif lelmnt(ielmnt) = iend-ibegin+1 if (lelmnt(ielmnt) .gt. mxlnel) then write (isyswr, 253) crdbuf(ibegin:iend),celmnt(ielmnt) 253 format (' minuit warning: input data word too long.' + /' original:',a + /' truncated to:',a) lelmnt(ielmnt) = mxlnel endif if (ipos .ge. lend) go to 300 if (ielmnt .ge. maxelm) go to 300 c look for comma or beginning of next word do 280 ipos= iend+1,lend if (crdbuf(ipos:ipos) .eq. ' ') go to 280 nextb = ipos if (crdbuf(ipos:ipos) .eq. ',') nextb = ipos+1 go to 10 280 continue c all elements found, join the alphabetic ones to c form a command 300 continue nelmnt = ielmnt comand = ' ' lnc = 1 plist(1) = 0. llist = 0 if (ielmnt .eq. 0) go to 900 kcmnd = 0 do 400 ielmnt = 1, nelmnt if (celmnt(ielmnt) .eq. cnull) go to 450 do 350 ic= 1, 13 if (celmnt(ielmnt)(1:1) .eq. cnumer(ic:ic)) go to 450 350 continue if (kcmnd .ge. maxcwd) go to 400 left = maxcwd-kcmnd ltoadd = lelmnt(ielmnt) if (ltoadd .gt. left) ltoadd=left comand(kcmnd+1:kcmnd+ltoadd) = celmnt(ielmnt)(1:ltoadd) kcmnd = kcmnd + ltoadd if (kcmnd .eq. maxcwd) go to 400 kcmnd = kcmnd + 1 comand(kcmnd:kcmnd) = ' ' 400 continue lnc = kcmnd go to 900 450 continue lnc = kcmnd c . . . . we have come to a numeric field llist = 0 do 600 ifld= ielmnt,nelmnt llist = llist + 1 if (llist .gt. mxp) then nreq = nelmnt-ielmnt+1 write (isyswr,511) nreq,mxp 511 format (/' minuit warning in mncrck: '/ ' command has input',i5, + ' numeric fields, but minuit can accept only',i3) go to 900 endif if (celmnt(ifld) .eq. cnull) then plist(llist) = 0. else read (celmnt(ifld), '(bn,f19.0)',err=575) plist(llist) endif go to 600 575 write (isyswr,'(a,a,a)') ' format error in numeric field: "', + celmnt(ifld)(1:lelmnt(ifld)),'"' ierr = 1 plist(llist) = 0. 600 continue c end loop over numeric fields 900 continue if (lnc .le. 0) lnc=1 return end cdeck id>, mncros. subroutine mncros(fcn,aopt,iercr,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc find point where mneval=amin+up, along the line through cc xmid,ymid with direction xdir,ydir, where x and y are cc parameters ke1 and ke2. if ke2=0 (from minos), then cc only ke1 is varied. from mncont, both are varied. cc crossing point is at cc (u(ke1),u(ke2)) = (xmid,ymid) + aopt*(xdir,ydir) cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead character chere*10, charal*28, chsign*4 parameter (chere='mncontour ', mlsb=3, maxitr=15, tlr=0.01) dimension flsb(mlsb),alsb(mlsb), coeff(3) logical ldebug external fcn,futil data charal/' .abcdefghijklmnopqrstuvwxyz'/ ldebug = (idbg(6) .ge. 1) aminsv = amin aim = amin + up tlf = tlr*up tla = tlr*0.1 xpt(1) = 0.0 ypt(1) = aim chpt(1) = ' ' xpt(2) = -1.0 ypt(2) = amin chpt(2) = '.' ipt = 2 c find the largest allowed a aulim = 100. do 100 ik= 1, 2 if (ik .eq. 1) then kex = ke1cr zmid = xmidcr zdir = xdircr else if (ke2cr .eq. 0) go to 100 kex = ke2cr zmid = ymidcr zdir = ydircr endif if (nvarl(kex) .le. 1) go to 100 if (zdir .eq. zero) go to 100 zlim = alim(kex) if (zdir .gt. zero) zlim = blim(kex) aulim = min(aulim,(zlim-zmid)/zdir) 100 continue c lsb = line search buffer c first point anext = 0. aopt = anext limset = .false. if (aulim .lt. aopt+tla) limset = .true. call mneval(fcn,anext,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 if (limset .and. fnext .le. aim) go to 930 ipt = ipt + 1 xpt(ipt) = anext ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) alsb(1) = anext flsb(1) = fnext fnext = max(fnext,aminsv+0.1*up) aopt = dsqrt((up)/(fnext-aminsv)) - 1.0 if (abs(fnext-aim) .lt. tlf) go to 800 c if (aopt .lt. -0.5) aopt = -0.5 limset = .false. if (aopt .gt. aulim) then aopt = aulim limset = .true. endif call mneval(fcn,aopt,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 if (limset .and. fnext .le. aim) go to 930 alsb(2) = aopt ipt = ipt + 1 xpt(ipt) = alsb(2) ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) flsb(2) = fnext dfda = (flsb(2)-flsb(1))/ (alsb(2)-alsb(1)) ilsb = 2 c dfda must be positive on the contour if (dfda .gt. zero) go to 460 300 call mnwarn('d',chere,'looking for slope of the right sign') maxlk = maxitr - ipt do 400 it= 1, maxlk alsb(1) = alsb(2) flsb(1) = flsb(2) aopt = alsb(1) + 0.2*real(it) limset = .false. if (aopt .gt. aulim) then aopt = aulim limset = .true. endif call mneval(fcn,aopt,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 if (limset .and. fnext .le. aim) go to 930 alsb(2) = aopt ipt = ipt + 1 xpt(ipt) = alsb(2) ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) flsb(2) = fnext dfda = (flsb(2)-flsb(1))/ (alsb(2)-alsb(1)) if (dfda .gt. zero) go to 450 400 continue call mnwarn('w',chere,'cannot find slope of the right sign') go to 950 450 continue c we have two points with the right slope 460 aopt = alsb(2) + (aim-flsb(2))/dfda if (min(abs(aopt-alsb(1)),abs(aopt-alsb(2))).lt. tla) go to 800 if (ipt .ge. maxitr) go to 950 bmin = min(alsb(1),alsb(2)) - 1.0 if (aopt .lt. bmin) aopt = bmin bmax = max(alsb(1),alsb(2)) + 1.0 if (aopt .gt. bmax) aopt = bmax c try a third point call mneval(fcn,aopt,fnext,ierev,futil) c debug printout: if (ldebug) write (isyswr,'(a,i8,a,f10.5,a,2f10.5)') + ' mncros: calls=',nfcn,' aim=',aim,' f,a=',fnext,aopt if (ierev .gt. 0) go to 900 alsb(3) = aopt ipt = ipt + 1 xpt(ipt) = alsb(3) ypt(ipt) = fnext chpt(ipt)= charal(ipt:ipt) flsb(3) = fnext inew = 3 c now we have three points, ask how many , mncuve. subroutine mncuve(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc makes sure that the current point is a local cc minimum and that the error matrix exists, cc or at least something good enough for minos and mncont cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil if (isw(4) .lt. 1) then write (isyswr,'(/a,a)') + ' function must be minimized before calling ',cfrom apsi = epsi call mnmigr(fcn,futil) endif if (isw(2) .lt. 3) then call mnhess(fcn,futil) if (isw(2) .lt. 1) then call mnwarn('w',cfrom,'no error matrix. will improvise.') do 555 i=1,npar ndex = i*(i-1)/2 do 554 j=1,i-1 ndex = ndex + 1 554 vhmat(ndex) = 0. ndex = ndex + 1 if (g2(i) .le. zero) then wint = werr(i) iext = nexofi(i) if (nvarl(iext) .gt. 1) then call mndxdi(x(i),i,dxdi) if (abs(dxdi) .lt. .001) then wint = .01 else wint = wint/abs(dxdi) endif endif g2(i) = up/wint**2 endif vhmat(ndex) = 2./g2(i) 555 continue isw(2) = 1 dcovar = 1. else call mnwerr endif endif return end cdeck id>, mnderi. subroutine mnderi(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the first derivatives of fcn (grd), cc either by finite differences or by transforming the user- cc supplied derivatives to internal coordinates, cc according to whether isw(3) is zero or one. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil logical ldebug character cbf1*22 nparx = npar ldebug = (idbg(2) .ge. 1) if (amin .eq. undefi) call mnamin(fcn,futil) if (isw(3) .eq. 1) go to 100 if (ldebug) then c make sure starting at the right place call mninex(x) nparx = npar call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 if (fs1 .ne. amin) then df = amin - fs1 write (cbf1(1:12),'(g12.3)') df call mnwarn('d','mnderi', + 'function value differs from amin by '//cbf1(1:12) ) amin = fs1 endif write + (isyswr,'(/'' first derivative debug printout. mnderi''/ + '' par deriv step minstep optstep '', + '' d1-d2 2nd drv'')') endif dfmin = 8. * epsma2*(abs(amin)+up) if (istrat .le. 0) then ncyc = 2 tlrstp = 0.5 tlrgrd = 0.1 else if (istrat .eq. 1) then ncyc = 3 tlrstp = 0.3 tlrgrd = 0.05 else ncyc = 5 tlrstp = 0.1 tlrgrd = 0.02 endif c loop over variable parameters do 60 i=1,npar epspri = epsma2 + abs(grd(i)*epsma2) c two-point derivatives always assumed necessary c maximum number of cycles over step size depends on strategy xtf = x(i) stepb4 = 0. c loop as little as possible here! do 45 icyc= 1, ncyc c ........ theoretically best step optstp = dsqrt(dfmin/(abs(g2(i))+epspri)) c step cannot decrease by more than a factor of ten step = max(optstp, abs(0.1*gstep(i))) c but if parameter has limits, max step size = 0.5 if (gstep(i).lt.zero .and. step.gt.0.5) step=0.5 c and not more than ten times the previous step stpmax = 10.*abs(gstep(i)) if (step .gt. stpmax) step = stpmax c minimum step size allowed by machine precision stpmin = 8. * abs(epsma2*x(i)) if (step .lt. stpmin) step = stpmin c end of iterations if step change less than factor 2 if (abs((step-stepb4)/step) .lt. tlrstp) go to 50 c take step positive gstep(i) = sign(step, gstep(i)) stepb4 = step x(i) = xtf + step call mninex(x) call fcn(nparx,gin,fs1,u,4,futil) nfcn=nfcn+1 c take step negative x(i) = xtf - step call mninex(x) call fcn(nparx,gin,fs2,u,4,futil) nfcn=nfcn+1 grbfor = grd(i) grd(i) = (fs1-fs2)/(2.0*step) g2(i) = (fs1+fs2-2.0*amin)/(step**2) x(i) = xtf if (ldebug) then d1d2 = (fs1+fs2-2.0*amin)/step write (isyswr,41) i,grd(i),step,stpmin,optstp,d1d2,g2(i) 41 format (i4,2g11.3,5g10.2) endif c see if another iteration is necessary if (abs(grbfor-grd(i))/(abs(grd(i))+dfmin/step) .lt. tlrgrd) + go to 50 45 continue c end of icyc loop. too many iterations if (ncyc .eq. 1) go to 50 write (cbf1,'(2e11.3)') grd(i),grbfor call mnwarn('d','mnderi', + 'first derivative not converged. '//cbf1) 50 continue c 60 continue call mninex(x) return c . derivatives calc by fcn 100 do 150 iint= 1, npar iext = nexofi(iint) if (nvarl(iext) .gt. 1) go to 120 grd(iint) = gin(iext) go to 150 120 dd = (blim(iext)-alim(iext))*0.5 *dcos(x(iint)) grd(iint) = gin(iext)*dd 150 continue 200 return end cdeck id>, mndxdi. subroutine mndxdi(pint,ipar,dxdi) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the transformation factor between external and cc internal parameter values. this factor is one for cc parameters which are not limited. called from mnemat. parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead i = nexofi(ipar) dxdi = 1.0 if (nvarl(i) .gt. 1) + dxdi = 0.5 *abs((blim(i)-alim(i)) * dcos(pint)) return end cdeck id>, mneig. subroutine mneig(a,ndima,n,mits,work,precis,ifault) c ************ double precision version ************* implicit double precision (a-h,o-z) c dimension a(ndima,*),work(*) data zero,one,two/0.0,1.0,2.0/ data tol/1.0e-35/ c precis is the machine precision epsmac ifault = 1 c i = n do 70 i1 = 2,n l = i-2 f = a(i,i-1) gl = zero c if(l .lt. 1) go to 25 c do 20 k = 1,l 20 gl = gl+a(i,k)**2 25 h = gl + f**2 c if(gl .gt. tol) go to 30 c work(i) = zero work(n+i) = f go to 65 30 l = l+1 c gl = dsqrt(h) c if(f .ge. zero) gl = -gl c work(n+i) = gl h = h-f*gl a(i,i-1) = f-gl f = zero do 50 j = 1,l a(j,i) = a(i,j)/h gl = zero do 40 k = 1,j 40 gl = gl+a(j,k)*a(i,k) c if(j .ge. l) go to 47 c j1 = j+1 do 45 k = j1,l 45 gl = gl+a(k,j)*a(i,k) 47 work(n+j) = gl/h f = f+gl*a(j,i) 50 continue hh = f/(h+h) do 60 j = 1,l f = a(i,j) gl = work(n+j)-hh*f work(n+j) = gl do 60 k = 1,j a(j,k) = a(j,k)-f*work(n+k)-gl*a(i,k) 60 continue work(i) = h 65 i = i-1 70 continue work(1) = zero work(n+1) = zero do 110 i = 1,n l = i-1 c if(work(i) .eq. zero .or. l .eq. 0) go to 100 c do 90 j = 1,l gl = zero do 80 k = 1,l 80 gl = gl+a(i,k)*a(k,j) do 90 k = 1,l a(k,j) = a(k,j)-gl*a(k,i) 90 continue 100 work(i) = a(i,i) a(i,i) = one c if(l .eq. 0) go to 110 c do 105 j = 1,l a(i,j) = zero a(j,i) = zero 105 continue 110 continue c c n1 = n-1 do 130 i = 2,n i0 = n+i-1 130 work(i0) = work(i0+1) work(n+n) = zero b = zero f = zero do 210 l = 1,n j = 0 h = precis*(abs(work(l))+abs(work(n+l))) c if(b .lt. h) b = h c do 140 m1 = l,n m = m1 c if(abs(work(n+m)) .le. b) go to 150 c 140 continue c 150 if(m .eq. l) go to 205 c 160 if(j .eq. mits) return c j = j+1 pt = (work(l+1)-work(l))/(two*work(n+l)) r = dsqrt(pt*pt+one) pr = pt+r c if(pt .lt. zero) pr=pt-r c h = work(l)-work(n+l)/pr do 170 i=l,n 170 work(i) = work(i)-h f = f+h pt = work(m) c = one s = zero m1 = m-1 i = m do 200 i1 = l,m1 j = i i = i-1 gl = c*work(n+i) h = c*pt c if(abs(pt) .ge. abs(work(n+i))) go to 180 c c = pt/work(n+i) r = dsqrt(c*c+one) work(n+j) = s*work(n+i)*r s = one/r c = c/r go to 190 180 c = work(n+i)/pt r = dsqrt(c*c+one) work(n+j) = s*pt*r s = c/r c = one/r 190 pt = c*work(i)-s*gl work(j) = h+s*(c*gl+s*work(i)) do 200 k = 1,n h = a(k,j) a(k,j) = s*a(k,i)+c*h a(k,i) = c*a(k,i)-s*h 200 continue work(n+l) = s*pt work(l) = c*pt c if(abs(work(n+l)) .gt. b) go to 160 c 205 work(l) = work(l)+f 210 continue do 240 i=1,n1 k = i pt = work(i) i1 = i+1 do 220 j = i1,n c if(work(j) .ge. pt) go to 220 c k = j pt = work(j) 220 continue c if(k .eq. i) go to 240 c work(k) = work(i) work(i) = pt do 230 j=1,n pt = a(j,i) a(j,i) = a(j,k) a(j,k) = pt 230 continue 240 continue ifault = 0 c return end cdeck id>, mnemat. subroutine mnemat(emat,ndim) c ************ double precision version ************* implicit double precision (a-h,o-z) dimension emat(ndim,ndim) cc calculates the external error matrix from the internal cc to be called by user, who must dimension emat at (ndim,ndim) parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead if (isw(2) .lt. 1) return if (isw(5) .ge. 2) write (isyswr,'(/a,i4,a,i3,a,g10.2)') + ' external error matrix. ndim=',ndim,' npar=',npar, + ' err def=',up c size of matrix to be printed npard = npar if (ndim .lt. npar) then npard = ndim if (isw(5) .ge. 0) write (isyswr,'(a,a)') ' user-dimensioned ', + ' array emat not big enough. reduced matrix calculated.' endif c nperln is the number of elements that fit on one line nperln = (npagwd-5)/10 nperln = min(nperln,13) if (isw(5).ge. 1 .and. npard.gt.nperln) write (isyswr,'(a)') + ' elements above diagonal are not printed.' c i counts the rows of the matrix do 110 i= 1, npard call mndxdi(x(i),i,dxdi) kga = i*(i-1)/2 do 100 j= 1, i call mndxdi(x(j),j,dxdj) kgb = kga + j emat(i,j) = dxdi * vhmat(kgb) * dxdj * up emat(j,i) = emat(i,j) 100 continue 110 continue c iz is number of columns to be printed in row i if (isw(5) .ge. 2) then do 160 i= 1, npard iz = npard if (npard .ge. nperln) iz = i do 150 k= 1, iz, nperln k2 = k + nperln - 1 if (k2 .gt. iz) k2=iz write (isyswr,'(1x,13e10.3)') (emat(i,kk),kk=k,k2) 150 continue 160 continue endif return end cdeck id>, mnerrs. subroutine mnerrs(number,eplus,eminus,eparab,gcc) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called by user, utility routine to get minos errors cc if number is positive, then it is external parameter number, cc if negative, it is -internal number. cc values returned by mnerrs: cc eplus, eminus are minos errors of parameter number, cc eparab is 'parabolic' error (from error matrix). cc (errors not calculated are set = 0.) cc gcc is global correlation coefficient from error matrix parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c iex = number if (number .lt. 0) then iin = -number if (iin .gt. npar) go to 900 iex = nexofi(iin) endif if (iex .gt. nu .or. iex .le. 0) go to 900 iin = niofex(iex) if (iin .le. 0) go to 900 c iex is external number, iin is internal number eplus = erp(iin) if (eplus.eq.undefi) eplus=0. eminus= ern(iin) if (eminus.eq.undefi) eminus=0. call mndxdi(x(iin),iin,dxdi) ndiag = iin*(iin+1)/2 eparab = abs(dxdi*dsqrt(abs(up*vhmat(ndiag)))) c global correlation coefficient gcc = 0. if (isw(2) .lt. 2) go to 990 gcc = globcc(iin) go to 990 c error. parameter number not valid 900 eplus = 0. eminus = 0. eparab = 0. gcc = 0. 990 return end cdeck id>, mneval. subroutine mneval(fcn,anext,fnext,ierev,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc evaluates the function being analyzed by mncros, which is cc generally the minimum of fcn with respect to all remaining cc variable parameters. common block /mn7xcr/ contains the cc data necessary to know the values of u(ke1cr) and u(ke2cr) cc to be used, namely u(ke1cr) = xmidcr + anext*xdircr cc and (if ke2cr .ne. 0) u(ke2cr) = ymidcr + anext*ydircr parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead cc external fcn,futil u(ke1cr) = xmidcr + anext*xdircr if ( ke2cr .ne. 0) u(ke2cr) = ymidcr + anext*ydircr call mninex(x) nparx = npar call fcn(nparx,gin,fnext,u,4,futil) nfcn = nfcn + 1 ierev = 0 if (npar .gt. 0) then itaur = 1 amin = fnext isw(1) = 0 call mnmigr(fcn,futil) itaur = 0 fnext = amin if (isw(1) .ge. 1) ierev = 1 if (isw(4) .lt. 1) ierev = 2 endif return end cdeck id>, mnexcm. subroutine mnexcm(fcn,comand,plist,llist,ierflg,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc interprets a command and takes appropriate action, cc either directly by skipping to the corresponding code in cc mnexcm, or by setting up a call to a subroutine cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil character*(*) comand c cannot say dimension plist(llist) since llist can be =0. dimension plist(*) parameter (mxpt=101) dimension xptu(mxpt), yptu(mxpt) c alphabetical order of command names! dimension isort(40) character*10 cname(40), cneway, chwhy*18, c26*30, cvblnk*2 logical ltofix, lfixed, lfreed c recognized minuit commands: data cname( 1) / 'minimize ' / data cname( 2) / 'seek ' / data cname( 3) / 'simplex ' / data cname( 4) / 'migrad ' / data cname( 5) / 'minos ' / data cname( 6) / 'set xxx ' / data cname( 7) / 'show xxx ' / data cname( 8) / 'top of pag' / data cname( 9) / 'fix ' / data cname(10) / 'restore ' / data cname(11) / 'release ' / data cname(12) / 'scan ' / data cname(13) / 'contour ' / data cname(14) / 'hesse ' / data cname(15) / 'save ' / data cname(16) / 'improve ' / data cname(17) / 'call fcn ' / data cname(18) / 'standard ' / data cname(19) / 'end ' / data cname(20) / 'exit ' / data cname(21) / 'return ' / data cname(22) / 'clear ' / data cname(23) / 'help ' / data cname(24) / 'mncontour ' / data cname(25) / 'stop ' / data cname(26) / 'jump ' / data nname/26/ data cname(27) / ' ' / data cname(28) / ' ' / data cname(29) / ' ' / data cname(30) / ' ' / data cname(31) / ' ' / data cname(32) / ' ' / data cname(33) / ' ' / c obsolete commands: data cname(34) / 'covariance' / data cname(35) / 'printout ' / data cname(36) / 'gradient ' / data cname(37) / 'matout ' / data cname(38) / 'error def ' / data cname(39) / 'limits ' / data cname(40) / 'punch ' / data nntot/40/ c 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 data isort/ 17,22,13,19,20, 9,23,14,16,26, 4, 1, 5,24,11, + 10,21,15,12, 2, 6, 3, 7,18,25, 8, 1, 1, 1, 1, + 1,1,1,1,1,1,1,1,1,1/ c lk = len(comand) if (lk .gt. maxcwd) lk=maxcwd cword = comand(1:lk) c copy the first maxp arguments into common (word7), making c sure that word7(1)=0. if llist=0 do 20 iw= 1, maxp word7(iw) = zero if (iw .le. llist) word7(iw) = plist(iw) 20 continue icomnd = icomnd + 1 nfcnlc = nfcn if (cword(1:7).ne.'set pri' .or. word7(1).ge.0.) then if (isw(5) .ge. 0) then lnow = llist if (lnow .gt. 4) lnow=4 write (isyswr,25) icomnd,cword(1:lk),(plist(i),i=1,lnow) 25 format (1h ,10(1h*)/' **',i5,' **',a,4g12.4) if (llist .gt. lnow) then write (cvblnk,'(i2)') lk c26 = '(11h **********,'//cvblnk//'x,4g12.4)' write (isyswr,c26) (plist(i),i=lnow+1,llist) endif write (isyswr, '(1h ,10(1h*))' ) endif endif nfcnmx = word7(1) if (nfcnmx .le. 0) nfcnmx = 200 + 100*npar + 5*npar**2 epsi = word7(2) if (epsi .le. zero) epsi = 0.1 * up lnewmn = .false. lphead = .true. isw(1) = 0 ierflg = 0 c look for command in list cname . . . . . . . . . . do 80 i= 1, nntot if (cword(1:3) .eq. cname(i)(1:3)) go to 90 80 continue write (isyswr,'(11x,''unknown command ignored:'',a)') comand ierflg = 2 go to 5000 c normal case: recognized minuit command . . . . . . . 90 continue if (cword(1:4) .eq. 'mino') i = 5 if (i.ne.6 .and. i.ne.7 .and. i.ne.8 .and. i.ne.23) then cfrom = cname(i) nfcnfr = nfcn endif c 1 2 3 4 5 6 7 8 9 10 go to ( 400, 200, 300, 400, 500, 700, 700, 800, 900,1000, 1 1100,1200,1300,1400,1500,1600,1700,1800,1900,1900, 2 1900,2200,2300,2400,1900,2600,3300,3300,3300,3300, 3 3300,3300,3300,3400,3500,3600,3700,3800,3900,4000) , i c . . . . . . . . . . seek 200 call mnseek(fcn,futil) go to 5000 c . . . . . . . . . . simplex 300 call mnsimp(fcn,futil) go to 5000 c . . . . . . migrad, minimize 400 continue nf = nfcn apsi = epsi call mnmigr(fcn,futil) call mnwerr if (isw(4) .ge. 1) go to 5000 if (isw(1) .eq. 1) go to 5000 if (cword(1:3) .eq. 'mig') go to 5000 nfcnmx = nfcnmx + nf - nfcn nf = nfcn call mnsimp(fcn,futil) if (isw(1) .eq. 1) go to 5000 nfcnmx = nfcnmx + nf - nfcn call mnmigr(fcn,futil) call mnwerr go to 5000 c . . . . . . . . . . minos 500 continue nsuper = nfcn + 2*(npar+1)*nfcnmx c possible loop over new minima epsi = 0.1 * up 510 continue call mncuve(fcn,futil) call mnmnos(fcn,futil) if (.not. lnewmn) go to 5000 call mnrset(0) call mnmigr(fcn,futil) call mnwerr if (nfcn .lt. nsuper) go to 510 write (isyswr,'(/'' too many function calls. minos gives up''/)') ierflg = 1 go to 5000 c . . . . . . . . . .set, show 700 call mnset(fcn,futil) go to 5000 c . . . . . . . . . . top of page 800 continue write (isyswr,'(1h1)') go to 5000 c . . . . . . . . . . fix 900 ltofix = .true. c . . (also release) .... 901 continue lfreed = .false. lfixed = .false. if (llist .eq. 0) then write (isyswr,'(a,a)') cword,': no parameters requested ' go to 5000 endif do 950 ilist= 1, llist iext = plist(ilist) chwhy = ' is undefined.' if (iext .le. 0) go to 930 if (iext .gt. nu) go to 930 if (nvarl(iext) .lt. 0) go to 930 chwhy = ' is constant. ' if (nvarl(iext) .eq. 0) go to 930 iint = niofex(iext) if (ltofix) then chwhy = ' already fixed.' if (iint .eq. 0) go to 930 call mnfixp(iint,ierr) if (ierr .eq. 0) then lfixed = .true. else ierflg = 1 endif else chwhy = ' already variable.' if (iint .gt. 0) go to 930 krl = -iabs(iext) call mnfree(krl) lfreed = .true. endif go to 950 930 write (isyswr,'(a,i4,a,a)') ' parameter',iext,chwhy,' ignored.' 950 continue if (lfreed .or. lfixed) call mnrset(0) if (lfreed) then isw(2) = 0 dcovar = 1. edm = bigedm isw(4) = 0 endif call mnwerr if (isw(5) .gt. 1) call mnprin(5,amin) go to 5000 c . . . . . . . . . . restore 1000 it = word7(1) if (it.gt.1 .or. it.lt.0) go to 1005 lfreed = (npfix .gt. 0) call mnfree(it) if (lfreed) then call mnrset(0) isw(2) = 0 dcovar = 1. edm = bigedm endif go to 5000 1005 write (isyswr,'(a,i4)') ' ignored. unknown argument:',it go to 5000 c . . . . . . . . . . release 1100 ltofix = .false. go to 901 c . . . . . . . . . . scan . . . 1200 continue iext = word7(1) if (iext .le. 0) go to 1210 it2 = 0 if (iext .le. nu) it2 = niofex(iext) if (it2 .le. 0) go to 1250 1210 call mnscan(fcn,futil) go to 5000 1250 write (isyswr,'(a,i4,a)') ' parameter',iext,' not variable.' go to 5000 c . . . . . . . . . . contour 1300 continue ke1 = word7(1) ke2 = word7(2) if (ke1 .eq. 0) then if (npar .eq. 2) then ke1 = nexofi(1) ke2 = nexofi(2) else write (isyswr,'(a,a)') cword,': no parameters requested ' go to 5000 endif endif nfcnmx = 1000 call mncntr(fcn,ke1,ke2,ierrf,futil) ierflg = ierrf go to 5000 c . . . . . . . . . . hesse 1400 continue call mnhess(fcn,futil) call mnwerr if (isw(5) .ge. 0) call mnprin(2, amin) if (isw(5) .ge. 1) call mnmatu(1) go to 5000 c . . . . . . . . . . save 1500 continue call mnsave go to 5000 c . . . . . . . . . . improve 1600 continue call mncuve(fcn,futil) call mnimpr(fcn,futil) if (lnewmn) go to 400 go to 5000 c . . . . . . . . . . call fcn 1700 iflag = word7(1) nparx = npar f = undefi call fcn(nparx,gin,f,u,iflag,futil) nfcn = nfcn + 1 nowprt = 0 if (f .ne. undefi) then if (amin .eq. undefi) then amin = f nowprt = 1 else if (f .lt. amin) then amin = f nowprt = 1 endif if (isw(5).ge.0 .and. iflag.le.5 .and. nowprt.eq.1) + call mnprin(5,amin) if (iflag .eq. 3) fval3=f endif if (iflag .gt. 5) call mnrset(1) go to 5000 c . . . . . . . . . . standard 1800 call stand go to 5000 c . . . . . . . stop, end, exit 1900 it = plist(1) if (fval3 .eq. amin .or. it .gt. 0) go to 5000 iflag = 3 write (isyswr,'(/a/)') ' call to user function with iflag = 3' nparx = npar call fcn(nparx,gin,f,u,iflag,futil) nfcn = nfcn + 1 go to 5000 c . . . . . . . . . . clear 2200 continue call mncler if (isw(5) .ge. 1) write (isyswr,'(a)') + ' minuit memory cleared. no parameters now defined.' go to 5000 c . . . . . . . . . . help 2300 continue if (index(cword,'sho') .gt. 0) go to 700 if (index(cword,'set') .gt. 0) go to 700 write (isyswr,2301) (cname(isort(i)),i=1,nname),'parameters' 2301 format (' the commands recognized by minuit are:'/6(2x,a10)) write (isyswr,'(a)') ' see also: help set and help show' go to 5000 c . . . . . . . . . . mncontour 2400 continue epsi = 0.05 * up ke1 = word7(1) ke2 = word7(2) if (ke1.eq.0 .and. npar.eq.2) then ke1 = nexofi(1) ke2 = nexofi(2) endif nptu = word7(3) if (nptu .le. 0) nptu=20 if (nptu .gt. mxpt) nptu = mxpt nfcnmx = 100*(nptu+5)*(npar+1) call mncont(fcn,ke1,ke2,nptu,xptu,yptu,ierrf,futil) go to 5000 c . . . . . . . . . . jump 2600 continue step = word7(1) if (step .le. zero) step = 2. rno = 0. izero = 0 do 2620 i= 1, npar call mnrn15(rno,izero) rno = 2.0*rno - 1.0 2620 x(i) = x(i) + rno*step*werr(i) call mninex(x) call mnamin(fcn,futil) call mnrset(0) go to 5000 c . . . . . . . . . . blank line 3300 continue write (isyswr,'(10x,a)') ' blank command ignored.' go to 5000 c . . . . . . . . obsolete commands . . . . . . . . . . . . . . c . . . . . . . . . . covariance 3400 continue write (isyswr, '(a)') ' the "covariance" command is osbsolete.', + ' the covariance matrix is now saved in a different format', + ' with the "save" command and read in with:"set covariance"' go to 5000 c . . . . . . . . . . printout 3500 continue cneway = 'set print ' go to 3100 c . . . . . . . . . . gradient 3600 continue cneway = 'set grad ' go to 3100 c . . . . . . . . . . matout 3700 continue cneway = 'show covar' go to 3100 c . . . . . . . . . error def 3800 continue cneway = 'set errdef' go to 3100 c . . . . . . . . . . limits 3900 continue cneway = 'set limits' go to 3100 c . . . . . . . . . . punch 4000 continue cneway = 'save ' c ....... come from obsolete commands 3100 write (isyswr, 3101) cword,cneway 3101 format (' obsolete command:',1x,a10,5x,'please use:',1x,a10) cword = cneway if (cword .eq. 'save ') go to 1500 go to 700 c . . . . . . . . . . . . . . . . . . 5000 return end cdeck id>, mnexin. subroutine mnexin(pint) c ************ double precision version ************* implicit double precision (a-h,o-z) cc transforms the external parameter values u to internal cc values in the dense array pint. subroutine mnpint is used. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension pint(*) limset = .false. do 100 iint= 1, npar iext = nexofi(iint) call mnpint(u(iext),iext,pinti) pint(iint) = pinti 100 continue return end cdeck id>, mnfixp. subroutine mnfixp(iint,ierr) c ************ double precision version ************* implicit double precision (a-h,o-z) cc removes parameter iint from the internal (variable) parameter cc list, and arranges the rest of the list to fill the hole. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension yy(mni) c first see if it can be done ierr = 0 if (iint.gt.npar .or. iint.le.0) then ierr = 1 write (isyswr,'(a,i4)') + ' minuit error. argument to mnfixp=',iint go to 300 endif iext = nexofi(iint) if (npfix .ge. mni) then ierr = 1 write (isyswr,'(a,i4,a,i4)') ' minuit cannot fix parameter', + iext,' maximum number that can be fixed is',mni go to 300 endif c reduce number of variable parameters by one niofex(iext) = 0 nold = npar npar = npar - 1 c save values in case parameter is later restored npfix = npfix + 1 ipfix(npfix) = iext lc = iint xs(npfix) = x(lc) xts(npfix) = xt(lc) dirins(npfix) = werr(lc) grds(npfix) = grd(lc) g2s(npfix) = g2(lc) gsteps(npfix) = gstep(lc) c shift values for other parameters to fill hole do 100 ik= iext+1, nu if (niofex(ik) .gt. 0) then lc = niofex(ik) - 1 niofex(ik) = lc nexofi(lc) = ik x(lc) = x(lc+1) xt(lc) = xt(lc+1) dirin(lc) = dirin(lc+1) werr(lc) = werr(lc+1) grd(lc) = grd(lc+1) g2(lc) = g2(lc+1) gstep(lc) = gstep(lc+1) endif 100 continue if (isw(2) .le. 0) go to 300 c remove one row and one column from variance matrix if (npar .le. 0) go to 300 do 260 i= 1, nold m = max(i,iint) n = min(i,iint) ndex = m*(m-1)/2 + n 260 yy(i)=vhmat(ndex) yyover = 1.0/yy(iint) knew = 0 kold = 0 do 294 i= 1, nold do 292 j= 1, i kold = kold + 1 if (j.eq.iint .or. i.eq.iint) go to 292 knew = knew + 1 vhmat(knew) = vhmat(kold) - yy(j)*yy(i)*yyover 292 continue 294 continue 300 return end cdeck id>, mnfree. subroutine mnfree(k) c ************ double precision version ************* implicit double precision (a-h,o-z) cc restores one or more fixed parameter(s) to variable status cc by inserting it into the internal parameter list at the cc appropriate place. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c-- k = 0 means restore all parameters c-- k = 1 means restore the last parameter fixed c-- k = -i means restore external parameter i (if possible) c-- iq = fix-location where internal parameters were stored c-- ir = external number of parameter being restored c-- is = internal number of parameter being restored if (k .gt. 1) write (isyswr,510) if (npfix .lt. 1) write (isyswr,500) if (k.eq.1 .or. k.eq.0) go to 40 c release parameter with specified external number ka = iabs(k) if (niofex(ka) .eq. 0) go to 15 write (isyswr,540) 540 format (' ignored. parameter specified is already variable.') return 15 if (npfix .lt. 1) go to 21 do 20 ik= 1, npfix if (ipfix(ik) .eq. ka) go to 24 20 continue 21 write (isyswr,530) ka 530 format (' parameter',i4,' not fixed. cannot be released.') return 24 if (ik .eq. npfix) go to 40 c move specified parameter to end of list ipsav = ka xv = xs(ik) xtv = xts(ik) dirinv = dirins(ik) grdv = grds(ik) g2v = g2s(ik) gstepv = gsteps(ik) do 30 i= ik+1,npfix ipfix(i-1) = ipfix(i) xs(i-1) = xs(i) xts(i-1) = xts(i) dirins(i-1) = dirins(i) grds(i-1) = grds(i) g2s(i-1) = g2s(i) gsteps(i-1) = gsteps(i) 30 continue ipfix(npfix) = ipsav xs(npfix) = xv xts(npfix) = xtv dirins(npfix) = dirinv grds(npfix) = grdv g2s(npfix) = g2v gsteps(npfix) = gstepv c restore last parameter in fixed list -- ipfix(npfix) 40 continue if (npfix .lt. 1) go to 300 ir = ipfix(npfix) is = 0 do 100 ik= nu, ir, -1 if (niofex(ik) .gt. 0) then lc = niofex(ik) + 1 is = lc - 1 niofex(ik) = lc nexofi(lc) = ik x(lc) = x(lc-1) xt(lc) = xt(lc-1) dirin(lc) = dirin(lc-1) werr(lc) = werr(lc-1) grd(lc) = grd(lc-1) g2(lc) = g2(lc-1) gstep(lc) = gstep(lc-1) endif 100 continue npar = npar + 1 if (is .eq. 0) is = npar niofex(ir) = is nexofi(is) = ir iq = npfix x(is) = xs(iq) xt(is) = xts(iq) dirin(is) = dirins(iq) werr(is) = dirins(iq) grd(is) = grds(iq) g2(is) = g2s(iq) gstep(is) = gsteps(iq) npfix = npfix - 1 isw(2) = 0 dcovar = 1. if (itaur .lt. 1) write(isyswr,520) ir,cpnam(ir) if (k.eq.0) go to 40 300 continue c if different from internal, external values are taken call mnexin(x) 400 return 500 format (' call to mnfree ignored. there are no fixed pa', + 'rameters'/) 510 format (' call to mnfree ignored. argument greater than one'/) 520 format (20x, 9hparameter,i4,2h, ,a10,' restored to variable.') end cdeck id>, mngrad. subroutine mngrad(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnset cc interprets the set grad command, which informs minuit whether cc the first derivatives of fcn will be calculated by the user cc inside fcn. it can check the user's derivative calculation cc by comparing it with a finite difference approximation. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c external fcn,futil character*4 cgood,cbad,cnone,cwd logical lnone dimension gf(mni) parameter (cgood='good',cbad=' bad',cnone='none') c isw(3) = 1 nparx = npar if (word7(1) .gt. zero) go to 2000 c get user-calculated first derivatives from fcn do 30 i= 1, nu 30 gin(i) = undefi call mninex(x) call fcn(nparx,gin,fzero,u,2,futil) nfcn = nfcn + 1 call mnderi(fcn,futil) do 40 i= 1, npar 40 gf(i) = grd(i) c get minuit-calculated first derivatives isw(3) = 0 istsav = istrat istrat = 2 call mnhes1(fcn,futil) istrat = istsav write (isyswr,51) 51 format(/' check of gradient calculation in fcn'/12x,'parameter', + 6x,9hg(in fcn) ,3x,9hg(minuit) ,2x,'dg(minuit)',3x,9hagreement) isw(3) = 1 lnone = .false. do 100 lc = 1, npar i = nexofi(lc) cwd = cgood err = dgrd(lc) if (abs(gf(lc)-grd(lc)) .gt. err) cwd = cbad if (gin(i) .eq. undefi) then cwd = cnone lnone = .true. gf(lc) = 0. endif if (cwd .ne. cgood) isw(3) = 0 write (isyswr,99) i,cpnam(i),gf(lc),grd(lc),err,cwd 99 format (7x,i5,2x ,a10,3e12.4,4x ,a4) 100 continue if (lnone) write (isyswr,'(a)') + ' agreement=none means fcn did not calculate the derivative' if (isw(3) .eq. 0) write (isyswr,1003) 1003 format(/' minuit does not accept derivative calculations by fcn'/ + ' to force acceptance, enter "set grad 1"'/) c 2000 continue return end cdeck id>, mnhess. subroutine mnhess(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the full second-derivative matrix of fcn cc by taking finite differences. when calculating diagonal cc elements, it may iterate so that step size is nearly that cc which gives function change= up/10. the first derivatives cc of course come as a free side effect, but with a smaller cc step size in order to obtain a known accuracy. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension yy(mni) logical ldebug character cbf1*22 c ldebug = (idbg(3) .ge. 1) if (amin .eq. undefi) call mnamin(fcn,futil) if (istrat .le. 0) then ncyc = 3 tlrstp = 0.5 tlrg2 = 0.1 else if (istrat .eq. 1) then ncyc = 5 tlrstp = 0.3 tlrg2 = 0.05 else ncyc = 7 tlrstp = 0.1 tlrg2 = 0.02 endif if (isw(5).ge.2 .or. ldebug) write (isyswr,'(a)') + ' start covariance matrix calculation.' cfrom = 'hesse ' nfcnfr = nfcn cstatu= 'ok ' npard = npar c make sure starting at the right place call mninex(x) nparx = npar call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 if (fs1 .ne. amin) then df = amin - fs1 write (cbf1(1:12),'(g12.3)') df call mnwarn('d','mnhess', + 'function value differs from amin by '//cbf1(1:12) ) endif amin = fs1 if (ldebug) write (isyswr,'(a,a)') ' par d gstep ', +' d g2 grd sag ' c . . . . . . diagonal elements . c isw(2) = 1 if approx, 2 if not posdef, 3 if ok c aimsag is the sagitta we are aiming for in second deriv calc. aimsag = dsqrt(epsma2)*(abs(amin)+up) c zero the second derivative matrix npar2 = npar*(npar+1)/2 do 10 i= 1,npar2 10 vhmat(i) = 0. c c loop over variable parameters for second derivatives idrv = 2 do 100 id= 1, npard i = id + npar - npard if (g2(i) .eq. zero) then call mnwarn('d','mnhess', + 'a second derivative is zero on entering.') wint = werr(i) iext = nexofi(i) if (nvarl(iext) .gt. 1) then call mndxdi(x(i),i,dxdi) if (abs(dxdi) .lt. .001) then wint = .01 else wint = wint/abs(dxdi) endif endif g2(i) = up/wint**2 endif xtf = x(i) dmin = 8.*epsma2*abs(xtf) c c find step which gives sagitta = aimsag d = abs(gstep(i)) do 40 icyc= 1, ncyc c loop here only if sag=0. do 25 multpy= 1, 5 c take two steps x(i) = xtf + d call mninex(x) nparx = npar call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 x(i) = xtf - d call mninex(x) call fcn(nparx,gin,fs2,u,4,futil) nfcn = nfcn + 1 x(i) = xtf sag = 0.5*(fs1+fs2-2.0*amin) if (sag .ne. zero) go to 30 if (gstep(i) .lt. zero) then if (d .ge. .5) go to 26 d = 10.*d if (d .gt. 0.5) d = 0.51 go to 25 endif d = 10.*d 25 continue 26 write (cbf1(1:4),'(i4)') iext call mnwarn('w','hesse', + 'second derivative zero for parameter'//cbf1(1:4) ) go to 390 c sag is not zero 30 g2bfor = g2(i) g2(i) = 2.*sag/d**2 grd(i) = (fs1-fs2)/(2.*d) if (ldebug) write (isyswr,31) i,idrv,gstep(i),d,g2(i),grd(i),sag 31 format (i4,i2,6g12.5) gstep(i) = sign(d,gstep(i)) dirin(i) = d yy(i) = fs1 dlast = d d = dsqrt(2.0*aimsag/abs(g2(i))) c if parameter has limits, max int step size = 0.5 stpinm = 0.5 if (gstep(i) .lt. zero) d = min(d,stpinm) if (d .lt. dmin) d = dmin c see if converged if (abs((d-dlast)/d) .lt. tlrstp) go to 50 if (abs((g2(i)-g2bfor)/g2(i)) .lt. tlrg2 ) go to 50 d = min(d, 10.*dlast) d = max(d, 0.1*dlast) 40 continue c end of step size loop write (cbf1,'(i2,2e10.2)') iext,sag,aimsag call mnwarn('d','mnhess','second deriv. sag,aim= '//cbf1) c 50 continue ndex = i*(i+1)/2 vhmat(ndex) = g2(i) 100 continue c end of diagonal second derivative loop call mninex(x) c refine the first derivatives if (istrat .gt. 0) call mnhes1(fcn,futil) isw(2) = 3 dcovar = 0. c . . . . off-diagonal elements if (npar .eq. 1) go to 214 do 200 i= 1, npar do 180 j= 1, i-1 xti = x(i) xtj = x(j) x(i) = xti + dirin(i) x(j) = xtj + dirin(j) call mninex(x) call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 x(i) = xti x(j) = xtj elem = (fs1+amin-yy(i)-yy(j)) / (dirin(i)*dirin(j)) ndex = i*(i-1)/2 + j vhmat(ndex) = elem 180 continue 200 continue 214 call mninex(x) c verify matrix positive-definite call mnpsdf do 220 i= 1, npar do 219 j= 1, i ndex = i*(i-1)/2 + j p(i,j) = vhmat(ndex) 219 p(j,i) = p(i,j) 220 continue call mnvert(p,maxint,maxint,npar,ifail) if (ifail .gt. 0) then call mnwarn('w','hesse', 'matrix inversion fails.') go to 390 endif c . . . . . . . calculate e d m edm = 0. do 230 i= 1, npar c off-diagonal elements ndex = i*(i-1)/2 do 225 j= 1, i-1 ndex = ndex + 1 ztemp = 2.0 * p(i,j) edm = edm + grd(i)*ztemp*grd(j) 225 vhmat(ndex) = ztemp c diagonal elements ndex = ndex + 1 vhmat(ndex) = 2.0 * p(i,i) edm = edm + p(i,i) * grd(i)**2 230 continue if (isw(5).ge.1 .and. isw(2).eq.3 .and. itaur.eq.0) + write(isyswr,'(a)')' covariance matrix calculated successfully' go to 900 c failure to invert 2nd deriv matrix 390 isw(2) = 1 dcovar = 1. cstatu = 'failed ' if (isw(5) .ge. 0) write (isyswr,'(a)') + ' mnhess fails and will return diagonal matrix. ' do 395 i= 1, npar ndex = i*(i-1)/2 do 394 j= 1, i-1 ndex = ndex + 1 394 vhmat(ndex) = 0.0 ndex = ndex +1 g2i = g2(i) if (g2i .le. zero) g2i = 1.0 395 vhmat(ndex) = 2.0/g2i 900 return end cdeck id>, mnhes1. subroutine mnhes1(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnhess and mngrad cc calculate first derivatives (grd) and uncertainties (dgrd) cc and appropriate step sizes gstep parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil logical ldebug character cbf1*22 ldebug = (idbg(5) .ge. 1) if (istrat .le. 0) ncyc = 1 if (istrat .eq. 1) ncyc = 2 if (istrat .gt. 1) ncyc = 6 idrv = 1 nparx = npar dfmin = 4.*epsma2*(abs(amin)+up) c main loop over parameters do 100 i= 1, npar xtf = x(i) dmin = 4.*epsma2*abs(xtf) epspri = epsma2 + abs(grd(i)*epsma2) optstp = dsqrt(dfmin/(abs(g2(i))+epspri)) d = 0.2 * abs(gstep(i)) if (d .gt. optstp) d = optstp if (d .lt. dmin) d = dmin chgold = 10000. c iterate reducing step size do 50 icyc= 1, ncyc x(i) = xtf + d call mninex(x) call fcn(nparx,gin,fs1,u,4,futil) nfcn = nfcn + 1 x(i) = xtf - d call mninex(x) call fcn(nparx,gin,fs2,u,4,futil) nfcn = nfcn + 1 x(i) = xtf c check if step sizes appropriate sag = 0.5*(fs1+fs2-2.0*amin) grdold = grd(i) grdnew = (fs1-fs2)/(2.0*d) dgmin = epsmac*(abs(fs1)+abs(fs2))/d if (ldebug) write (isyswr,11) i,idrv,gstep(i),d,g2(i),grdnew,sag 11 format (i4,i2,6g12.5) if (grdnew .eq. zero) go to 60 change = abs((grdold-grdnew)/grdnew) if (change.gt.chgold .and. icyc.gt.1) go to 60 chgold = change grd(i) = grdnew gstep(i) = sign(d,gstep(i)) c decrease step until first derivative changes by <5% if (change .lt. 0.05) go to 60 if (abs(grdold-grdnew) .lt. dgmin) go to 60 if (d .lt. dmin) then call mnwarn('d','mnhes1','step size too small for 1st drv.') go to 60 endif d = 0.2*d 50 continue c loop satisfied = too many iter write (cbf1,'(2g11.3)') grdold,grdnew call mnwarn('d','mnhes1','too many iterations on d1.'//cbf1) 60 continue dgrd(i) = max(dgmin,abs(grdold-grdnew)) 100 continue c end of first deriv. loop call mninex(x) return end cdeck id>, mnimpr. subroutine mnimpr(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc attempts to improve on a good local minimum by finding a cc better one. the quadratic part of fcn is removed by mncalf cc and this transformed function is minimized using the simplex cc method from several random starting points. cc ref. -- goldstein and price, math.comp. 25, 569 (1971) cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension dsav(mni), y(mni+1) parameter (alpha=1.,beta=0.5,gamma=2.0) data rnum/0./ if (npar .le. 0) return if (amin .eq. undefi) call mnamin(fcn,futil) cstatu = 'unchanged ' itaur = 1 epsi = 0.1*up npfn=nfcn nloop = word7(2) if (nloop .le. 0) nloop = npar + 4 nparx = npar nparp1=npar+1 wg = 1.0/float(npar) sigsav = edm apsi = amin do 2 i= 1, npar xt(i) = x(i) dsav(i) = werr(i) do 2 j = 1, i ndex = i*(i-1)/2 + j p(i,j) = vhmat(ndex) 2 p(j,i) = p(i,j) call mnvert(p,maxint,maxint,npar,ifail) if (ifail .ge. 1) go to 280 c save inverted matrix in vt do 12 i= 1, npar ndex = i*(i-1)/2 do 12 j= 1, i ndex = ndex + 1 12 vthmat(ndex) = p(i,j) loop = 0 c 20 continue do 25 i= 1, npar dirin(i) = 2.0*dsav(i) call mnrn15(rnum,iseed) 25 x(i) = xt(i) + 2.0*dirin(i)*(rnum-0.5) loop = loop + 1 reg = 2.0 if (isw(5) .ge. 0) write (isyswr, 1040) loop 30 call mncalf(fcn,x,ycalf,futil) amin = ycalf c . . . . set up random simplex jl = nparp1 jh = nparp1 y(nparp1) = amin amax = amin do 45 i= 1, npar xi = x(i) call mnrn15(rnum,iseed) x(i) = xi - dirin(i) *(rnum-0.5) call mncalf(fcn,x,ycalf,futil) y(i) = ycalf if (y(i) .lt. amin) then amin = y(i) jl = i else if (y(i) .gt. amax) then amax = y(i) jh = i endif do 40 j= 1, npar 40 p(j,i) = x(j) p(i,nparp1) = xi x(i) = xi 45 continue c edm = amin sig2 = edm c . . . . . . . start main loop 50 continue if (amin .lt. zero) go to 95 if (isw(2) .le. 2) go to 280 ep = 0.1*amin if (sig2 .lt. ep .and. edm.lt.ep ) go to 100 sig2 = edm if ((nfcn-npfn) .gt. nfcnmx) go to 300 c calculate new point * by reflection do 60 i= 1, npar pb = 0. do 59 j= 1, nparp1 59 pb = pb + wg * p(i,j) pbar(i) = pb - wg * p(i,jh) 60 pstar(i)=(1.+alpha)*pbar(i)-alpha*p(i,jh) call mncalf(fcn,pstar,ycalf,futil) ystar = ycalf if(ystar.ge.amin) go to 70 c point * better than jl, calculate new point ** do 61 i=1,npar 61 pstst(i)=gamma*pstar(i)+(1.-gamma)*pbar(i) call mncalf(fcn,pstst,ycalf,futil) ystst = ycalf 66 if (ystst .lt. y(jl)) go to 67 call mnrazz(ystar,pstar,y,jh,jl) go to 50 67 call mnrazz(ystst,pstst,y,jh,jl) go to 50 c point * is not as good as jl 70 if (ystar .ge. y(jh)) go to 73 jhold = jh call mnrazz(ystar,pstar,y,jh,jl) if (jhold .ne. jh) go to 50 c calculate new point ** 73 do 74 i=1,npar 74 pstst(i)=beta*p(i,jh)+(1.-beta)*pbar(i) call mncalf(fcn,pstst,ycalf,futil) ystst = ycalf if(ystst.gt.y(jh)) go to 30 c point ** is better than jh if (ystst .lt. amin) go to 67 call mnrazz(ystst,pstst,y,jh,jl) go to 50 c . . . . . . end main loop 95 if (isw(5) .ge. 0) write (isyswr,1000) reg = 0.1 c . . . . . ask if point is new 100 call mninex(x) call fcn(nparx,gin,amin,u,4,futil) nfcn = nfcn + 1 do 120 i= 1, npar dirin(i) = reg*dsav(i) if (abs(x(i)-xt(i)) .gt. dirin(i)) go to 150 120 continue go to 230 150 nfcnmx = nfcnmx + npfn - nfcn npfn = nfcn call mnsimp(fcn,futil) if (amin .ge. apsi) go to 325 do 220 i= 1, npar dirin(i) = 0.1 *dsav(i) if (abs(x(i)-xt(i)) .gt. dirin(i)) go to 250 220 continue 230 if (amin .lt. apsi) go to 350 go to 325 c . . . . . . truly new minimum 250 lnewmn = .true. if (isw(2) .ge. 1) then isw(2) = 1 dcovar = max(dcovar,half) else dcovar = 1. endif itaur = 0 nfcnmx = nfcnmx + npfn - nfcn cstatu = 'new minimu' if (isw(5) .ge. 0) write (isyswr,1030) return c . . . return to previous region 280 if (isw(5) .gt. 0) write (isyswr,1020) go to 325 300 isw(1) = 1 325 do 330 i= 1, npar dirin(i) = 0.01*dsav(i) 330 x(i) = xt(i) amin = apsi edm = sigsav 350 call mninex(x) if (isw(5) .gt. 0) write (isyswr,1010) cstatu= 'unchanged ' call mnrset(0) if (isw(2) .lt. 2) go to 380 if (loop .lt. nloop .and. isw(1) .lt. 1) go to 20 380 call mnprin (5,amin) itaur = 0 return 1000 format (54h an improvement on the previous minimum has been found) 1010 format (51h improve has returned to region of original minimum) 1020 format (/44h covariance matrix was not positive-definite) 1030 format (/38h improve has found a truly new minimum/1h ,37(1h*)/) 1040 format (/18h start attempt no.,i2, 20h to find new minimum) end cdeck id>, mninex. subroutine mninex(pint) c ************ double precision version ************* implicit double precision (a-h,o-z) cc transforms from internal coordinates (pint) to external cc parameters (u). the minimizing routines which work in cc internal coordinates call this routine before calling fcn. parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension pint(*) do 100 j= 1, npar i = nexofi(j) if (nvarl(i) .eq. 1) then u(i) = pint(j) else u(i) = alim(i) + 0.5*(dsin(pint(j)) +1.0) * (blim(i)-alim(i)) endif 100 continue return end cdeck id>, mninit. subroutine mninit (i1,i2,i3) c ************ double precision version ************* implicit double precision (a-h,o-z) cc this is the main initialization subroutine for minuit cc it initializes some constants in common cc (including the logical i/o unit nos.), cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c external intrac logical intrac c i/o unit numbers isysrd = i1 isyswr = i2 istkwr(1) = isyswr nstkwr = 1 isyssa = i3 nstkrd = 0 c version identifier cvrsn = '90.10 ' c some constant constants in common maxint=mni maxext=mne undefi = -54321. bigedm = 123456. cundef = ')undefined' covmes(0) = 'no error matrix ' covmes(1) = 'err matrix approximate' covmes(2) = 'err matrix not pos-def' covmes(3) = 'error matrix accurate ' c some starting values in common nblock = 0 icomnd = 0 ctitl = cundef cfrom = 'input ' nfcnfr = nfcn cstatu= 'initialize' isw(3) = 0 isw(4) = 0 isw(5) = 1 c isw(6)=0 for batch jobs, =1 for interactive jobs isw(6) = 0 if (intrac(dummy)) isw(6) = 1 c debug options set to default values do 10 idb= 0, maxdbg 10 idbg(idb) = 0 lrepor = .false. lwarn = .true. limset = .false. lnewmn = .false. istrat = 1 itaur = 0 c default page dimensions and 'new page' carriage control integer npagwd = 120 npagln = 56 newpag = 1 if (isw(6) .gt. 0) then npagwd = 80 npagln = 30 newpag = 0 endif up = 1.0 updflt = up c determine machine accuracy epsmac epstry = 0.5 do 33 i= 1, 100 epstry = epstry * 0.5 epsp1 = one + epstry call mntiny(epsp1, epsbak) if (epsbak .lt. epstry) go to 35 33 continue epstry = 1.0e-7 epsmac = 4.0*epstry write (isyswr,'(a,a,e10.2)') ' mninit unable to determine', + ' arithmetic precision. will assume:',epsmac 35 epsmac = 8.0 * epstry epsma2 = 2.0 * dsqrt(epsmac) c the vlims are a non-negligible distance from pi/2 c used by mnpint to set variables "near" the physical limits piby2 = 2.0*atan(1.0) distnn = 8.0*dsqrt(epsma2) vlimhi = piby2 - distnn vlimlo = -piby2 + distnn call mncler write (isyswr,'(3a,i3,a,i3,a,e10.2)') ' minuit release ',cvrsn, +' initialized. dimensions ',mne,'/',mni,' epsmac=',epsmac return end cdeck id>, mnintr. subroutine mnintr(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called by user. interfaces to mnread to allow user to change cc easily from fortran-callable to interactive mode. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil iflgin = 3 call mnread(fcn,iflgin,iflgut,futil) write (isyswr,'(2a/)') ' end of minuit command input. ', + ' return to user program.' return end cdeck id>, mnlims. subroutine mnlims(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnset cc interprets the set lim command, to reset the parameter limits cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil c cfrom = 'set lim ' nfcnfr = nfcn cstatu= 'no change ' i2 = word7(1) if (i2 .gt. maxext .or. i2 .lt. 0) go to 900 if (i2 .gt. 0) go to 30 c set limits on all parameters newcod = 4 if (word7(2) .eq. word7(3)) newcod = 1 do 20 inu= 1, nu if (nvarl(inu) .le. 0) go to 20 if (nvarl(inu).eq.1 .and. newcod.eq.1) go to 20 kint = niofex(inu) c see if parameter has been fixed if (kint .le. 0) then if (isw(5) .ge. 0) write (isyswr,'(11x,a,i3)') + ' limits not changed for fixed parameter:',inu go to 20 endif if (newcod .eq. 1) then c remove limits from parameter if (isw(5) .gt. 0) write (isyswr,134) inu cstatu = 'new limits' call mndxdi(x(kint),kint,dxdi) snew = gstep(kint)*dxdi gstep(kint) = abs(snew) nvarl(inu) = 1 else c put limits on parameter alim(inu) = min(word7(2),word7(3)) blim(inu) = max(word7(2),word7(3)) if (isw(5) .gt. 0) write (isyswr,237) inu,alim(inu),blim(inu) nvarl(inu) = 4 cstatu = 'new limits' gstep(kint) = -0.1 endif 20 continue go to 900 c set limits on one parameter 30 if (nvarl(i2) .le. 0) then write (isyswr,'(a,i3,a)') ' parameter ',i2,' is not variable.' go to 900 endif kint = niofex(i2) c see if parameter was fixed if (kint .eq. 0) then write (isyswr,'(a,i3)') + ' request to change limits on fixed parameter:',i2 do 82 ifx= 1, npfix if (i2 .eq. ipfix(ifx)) go to 92 82 continue write (isyswr,'(a)') ' minuit bug in mnlims. see f. james' 92 continue endif if (word7(2) .ne. word7(3)) go to 235 c remove limits if (nvarl(i2) .ne. 1) then if (isw(5) .gt. 0) write (isyswr,134) i2 134 format (30h limits removed from parameter ,i4) cstatu = 'new limits' if (kint .le. 0) then gsteps(ifx) = abs(gsteps(ifx)) else call mndxdi(x(kint),kint,dxdi) if (abs(dxdi) .lt. 0.01) dxdi=0.01 gstep(kint) = abs(gstep(kint)*dxdi) grd(kint) = grd(kint)*dxdi endif nvarl(i2) = 1 else write (isyswr,'(a,i3)') ' no limits specified. parameter ', + i2,' is already unlimited. no change.' endif go to 900 c put on limits 235 alim(i2) = min(word7(2),word7(3)) blim(i2) = max(word7(2),word7(3)) nvarl(i2) = 4 if (isw(5) .gt. 0) write (isyswr,237) i2,alim(i2),blim(i2) 237 format (10h parameter ,i3, 14h limits set to ,2g15.5) cstatu = 'new limits' if (kint .le. 0) then gsteps(ifx) = -0.1 else gstep(kint) = -0.1 endif c 900 continue if (cstatu .ne. 'no change ') then call mnexin(x) call mnrset(1) endif return end cdeck id>, mnline. subroutine mnline(fcn,start,fstart,step,slope,toler,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc perform a line search from position start cc along direction step, where the length of vector step cc gives the expected position of minimum. cc fstart is value of function at start cc slope (if non-zero) is df/dx along step at start cc toler is initial tolerance of minimum in direction step parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension start(*), step(*) parameter (maxpt=12) dimension xpq(maxpt),ypq(maxpt) character*1 chpq(maxpt) dimension xvals(3),fvals(3),coeff(3) character*26 charal character*60 cmess parameter (slambg=5.,alpha=2.) c slambg and alpha control the maximum individual steps allowed. c the first step is always =1. the max length of second step is slambg. c the max size of subsequent steps is the maximum previous successful c step multiplied by alpha + the size of most recent successful step, c but cannot be smaller than slambg. logical ldebug data charal / 'abcdefghijklmnopqrstuvwxyz' / ldebug = (idbg(1).ge.1) c starting values for overall limits on total step slam overal = 1000. undral = -100. c debug check if start is ok if (ldebug) then call mninex(start) call fcn(nparx,gin,f1,u,4,futil) nfcn=nfcn+1 if (f1 .ne. fstart) then write (isyswr,'(a/2e14.5/2x,10f10.5)') + ' mnline start point not consistent, f values, parameters=', + (x(kk),kk=1,npar) endif endif c . set up linear search along step fvmin = fstart xvmin = 0. nxypt = 1 chpq(1) = charal(1:1) xpq(1) = 0. ypq(1) = fstart c slamin = smallest possible value of abs(slam) slamin = 0. do 20 i= 1, npar if (step(i) .eq. zero) go to 20 ratio = abs(start(i)/step(i)) if (slamin .eq. zero) slamin = ratio if (ratio .lt. slamin) slamin = ratio 20 x(i) = start(i) + step(i) if (slamin .eq. zero) slamin = epsmac slamin = slamin*epsma2 nparx = npar c call mninex(x) call fcn(nparx,gin,f1,u,4,futil) nfcn=nfcn+1 nxypt = nxypt + 1 chpq(nxypt) = charal(nxypt:nxypt) xpq(nxypt) = 1. ypq(nxypt) = f1 if (f1 .lt. fstart) then fvmin = f1 xvmin = 1.0 endif c . quadr interp using slope gdel and two points slam = 1. toler8 = toler slamax = slambg flast = f1 c can iterate on two-points (cut) if no imprvmnt 25 continue denom = 2.0*(flast-fstart-slope*slam)/slam**2 c if (denom .eq. zero) denom = -0.1*slope slam = 1. if (denom .ne. zero) slam = -slope/denom if (slam .lt. zero) slam = slamax if (slam .gt. slamax) slam = slamax if (slam .lt. toler8) slam = toler8 if (slam .lt. slamin) go to 80 if (abs(slam-1.0).lt.toler8 .and. f1.lt.fstart) go to 70 if (abs(slam-1.0).lt.toler8) slam = 1.0+toler8 if (nxypt .ge. maxpt) go to 65 do 30 i= 1, npar 30 x(i) = start(i) + slam*step(i) call mninex(x) call fcn(npar,gin,f2,u,4,futil) nfcn = nfcn + 1 nxypt = nxypt + 1 chpq(nxypt) = charal(nxypt:nxypt) xpq(nxypt) = slam ypq(nxypt) = f2 if (f2 .lt. fvmin) then fvmin = f2 xvmin = slam endif if (fstart .eq. fvmin) then flast = f2 toler8 = toler*slam overal = slam-toler8 slamax = overal go to 25 endif c . quadr interp using 3 points xvals(1) = xpq(1) fvals(1) = ypq(1) xvals(2) = xpq(nxypt-1) fvals(2) = ypq(nxypt-1) xvals(3) = xpq(nxypt) fvals(3) = ypq(nxypt) c begin iteration, calculate desired step 50 continue slamax = max(slamax,alpha*abs(xvmin)) call mnpfit(xvals,fvals,3,coeff,sdev) if (coeff(3) .le. zero) then slopem = 2.0*coeff(3)*xvmin + coeff(2) if (slopem .le. zero) then slam = xvmin + slamax else slam = xvmin - slamax endif else slam = -coeff(2)/(2.0*coeff(3)) if (slam .gt. xvmin+slamax) slam = xvmin+slamax if (slam .lt. xvmin-slamax) slam = xvmin-slamax endif if (slam .gt. zero) then if (slam .gt. overal) slam = overal else if (slam .lt. undral) slam = undral endif c come here if step was cut below 52 continue toler9 = max(toler8,abs(toler8*slam)) do 55 ipt= 1, 3 if (abs(slam-xvals(ipt)) .lt. toler9) go to 70 55 continue c take the step do 60 i= 1, npar 60 x(i) = start(i)+slam*step(i) call mninex(x) call fcn(nparx,gin,f3,u,4,futil) nfcn = nfcn + 1 nxypt = nxypt + 1 chpq(nxypt) = charal(nxypt:nxypt) xpq(nxypt) = slam ypq(nxypt) = f3 c find worst previous point out of three fvmax = fvals(1) nvmax = 1 if (fvals(2) .gt. fvmax) then fvmax = fvals(2) nvmax = 2 endif if (fvals(3) .gt. fvmax) then fvmax = fvals(3) nvmax = 3 endif c if latest point worse than all three previous, cut step if (f3 .ge. fvmax) then if (nxypt .ge. maxpt) go to 65 if (slam .gt. xvmin) overal = min(overal,slam-toler8) if (slam .lt. xvmin) undral = max(undral,slam+toler8) slam = 0.5*(slam+xvmin) go to 52 endif c prepare another iteration, replace worst previous point xvals(nvmax) = slam fvals(nvmax) = f3 if (f3 .lt. fvmin) then fvmin = f3 xvmin = slam else if (slam .gt. xvmin) overal = min(overal,slam-toler8) if (slam .lt. xvmin) undral = max(undral,slam+toler8) endif if (nxypt .lt. maxpt) go to 50 c . . end of iteration . . . c stop because too many iterations 65 cmess = ' line search has exhausted the limit of function calls ' if (ldebug) then write (isyswr,'(a/(2x,6g12.4))') ' mnline debug: steps=', + (step(kk),kk=1,npar) endif go to 100 c stop because within tolerance 70 continue cmess = ' line search has attained tolerance ' go to 100 80 continue cmess = ' step size at arithmetically allowed minimum' 100 continue amin = fvmin do 120 i= 1, npar dirin(i) = step(i)*xvmin 120 x(i) = start(i) + dirin(i) call mninex(x) if (xvmin .lt. 0.) call mnwarn('d','mnline', + ' line minimum in backwards direction') if (fvmin .eq. fstart) call mnwarn('d','mnline', + ' line search finds no improvement ') if (ldebug) then write (isyswr,'('' after'',i3,'' points,'',a)') nxypt,cmess call mnplot(xpq,ypq,chpq,nxypt,isyswr,npagwd,npagln) endif return end cdeck id>, mnmatu. subroutine mnmatu(kode) c ************ double precision version ************* implicit double precision (a-h,o-z) cc prints the covariance matrix v when kode=1. cc always prints the global correlations, and cc calculates and prints the individual correlation coefficients cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension vline(mni) isw2 = isw(2) if (isw2 .lt. 1) then write (isyswr,'(1x,a)') covmes(isw2) go to 500 endif if (npar .eq. 0) then write (isyswr,'('' mnmatu: npar=0'')') go to 500 endif c . . . . .external error matrix if (kode .eq. 1) then isw5 = isw(5) isw(5) = 2 call mnemat(p,maxint) if (isw2.lt.3) write (isyswr,'(1x,a)') covmes(isw2) isw(5) = isw5 endif c . . . . . correlation coeffs. . if (npar .le. 1) go to 500 call mnwerr c ncoef is number of coeff. that fit on one line, not to exceed 20 ncoef = (npagwd-19)/6 ncoef = min(ncoef,20) nparm = min(npar,ncoef) write (isyswr, 150) (nexofi(id),id=1,nparm) 150 format (/36h parameter correlation coefficients / + 18h no. global ,20i6) do 200 i= 1, npar ix = nexofi(i) ndi = i*(i+1)/2 do 170 j= 1, npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n ndj = j*(j+1)/2 170 vline(j) = vhmat(ndex)/dsqrt(abs(vhmat(ndi)*vhmat(ndj))) nparm = min(npar,ncoef) write (isyswr,171) ix, globcc(i), (vline(it),it=1,nparm) 171 format (6x,i3,2x,f7.5,1x,20f6.3) if (i.le.nparm) go to 200 do 190 iso= 1, 10 nsofar = nparm nparm = min(npar,nsofar+ncoef) write (isyswr,181) (vline(it),it=nsofar+1,nparm) 181 format (19x,20f6.3) if (i .le. nparm) go to 192 190 continue 192 continue 200 continue if (isw2.lt.3) write (isyswr,'(1x,a)') covmes(isw2) 500 return end cdeck id>, mnmigr. subroutine mnmigr(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a local function minimization using basically the cc method of davidon-fletcher-powell as modified by fletcher cc ref. -- fletcher, comp.j. 13,317 (1970) "switching method" cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension gs(mni), step(mni), xxs(mni), flnu(mni), vg(mni) logical ldebug parameter (toler=0.05) if (npar .le. 0) return if (amin .eq. undefi) call mnamin(fcn,futil) ldebug = (idbg(4) .ge. 1) cfrom = 'migrad ' nfcnfr = nfcn nfcnmg = nfcn cstatu= 'initiate ' iswtr = isw(5) - 2*itaur npfn = nfcn nparx = npar vlen = npar*(npar+1)/2 nrstrt = 0 npsdf = 0 lined2 = 0 isw(4) = -1 rhotol = 1.0e-3*apsi if (iswtr .ge. 1) write (isyswr,470) istrat,rhotol 470 format (' start migrad minimization. strategy',i2, +'. convergence when edm .lt.',e9.2) c initialization strategy if (istrat.lt.2 .or. isw(2).ge.3) go to 2 c come (back) here to restart completely 1 continue if (nrstrt .gt. istrat) then cstatu= 'failed ' isw(4) = -1 go to 230 endif c . get full covariance and gradient call mnhess(fcn,futil) call mnwerr npsdf = 0 if (isw(2) .ge. 1) go to 10 c . get gradient at start point 2 continue call mninex(x) if (isw(3) .eq. 1) then call fcn(nparx,gin,fzero,u,2,futil) nfcn = nfcn + 1 endif call mnderi(fcn,futil) if (isw(2) .ge. 1) go to 10 c sometimes start with diagonal matrix do 3 i= 1, npar xxs(i) = x(i) step(i) = zero 3 continue c do line search if second derivative negative lined2 = lined2 + 1 if (lined2 .lt. 2*npar) then do 5 i= 1, npar if (g2(i) .gt. 0.) go to 5 step(i) = -sign(gstep(i),grd(i)) gdel = step(i)*grd(i) fs = amin call mnline(fcn,xxs,fs,step,gdel,toler,futil) call mnwarn('d','mnmigr','negative g2 line search') iext = nexofi(i) if (ldebug) write (isyswr,'(a,i3,2g13.3)') + ' negative g2 line search, param ',iext,fs,amin go to 2 5 continue endif c make diagonal error matrix do 8 i=1,npar ndex = i*(i-1)/2 do 7 j=1,i-1 ndex = ndex + 1 7 vhmat(ndex) = 0. ndex = ndex + 1 if (g2(i) .le. zero) g2(i) = 1. vhmat(ndex) = 2./g2(i) 8 continue dcovar = 1. if (ldebug) write (isyswr,'(a,a/(1x,10g10.2))') ' debug mnmigr,', + ' starting matrix diagonal, vhmat=', (vhmat(kk),kk=1,int(vlen)) c ready to start first iteration 10 continue impruv = 0 nrstrt = nrstrt + 1 if (nrstrt .gt. istrat+1) then cstatu= 'failed ' go to 230 endif fs = amin c . . . get edm and set up loop edm = 0. do 18 i= 1, npar gs(i) = grd(i) xxs(i) = x(i) ndex = i*(i-1)/2 do 17 j= 1, i-1 ndex = ndex + 1 17 edm = edm + gs(i)*vhmat(ndex)*gs(j) ndex = ndex + 1 18 edm = edm + 0.5 * gs(i)**2 *vhmat(ndex) edm = edm * 0.5 * (1.0+3.0*dcovar) if (edm .lt. zero) then call mnwarn('w','migrad','starting matrix not pos-definite.') isw(2) = 0 dcovar = 1. go to 2 endif if (isw(2) .eq. 0) edm=bigedm iter = 0 call mninex(x) call mnwerr if (iswtr .ge. 1) call mnprin(3,amin) if (iswtr .ge. 2) call mnmatu(0) c . . . . . start main loop 24 continue if (nfcn-npfn .ge. nfcnmx) go to 190 gdel = 0. gssq = 0. do 30 i=1,npar ri = 0. gssq = gssq + gs(i)**2 do 25 j=1,npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n 25 ri = ri + vhmat(ndex) *gs(j) step(i) = -0.5*ri 30 gdel = gdel + step(i)*gs(i) if (gssq .eq. zero) then call mnwarn('d','migrad', + ' first derivatives of fcn are all zero') go to 300 endif c if gdel positive, v not posdef if (gdel .ge. zero) then call mnwarn('d','migrad',' newton step not descent.') if (npsdf .eq. 1) go to 1 call mnpsdf npsdf = 1 go to 24 endif c . . . . do line search call mnline(fcn,xxs,fs,step,gdel,toler,futil) if (amin .eq. fs) go to 200 cfrom = 'migrad ' nfcnfr = nfcnmg cstatu= 'progress ' c . get gradient at new point call mninex(x) if (isw(3) .eq. 1) then call fcn(nparx,gin,fzero,u,2,futil) nfcn = nfcn + 1 endif call mnderi(fcn,futil) c . calculate new edm npsdf = 0 81 edm = 0. gvg = 0. delgam = 0. gdgssq = 0. do 100 i= 1, npar ri = 0. vgi = 0. do 90 j= 1, npar m = max(i,j) n = min(i,j) ndex = m*(m-1)/2 + n vgi = vgi + vhmat(ndex)*(grd(j)-gs(j)) 90 ri = ri + vhmat(ndex)* grd(j) vg(i) = vgi*0.5 gami = grd(i) - gs(i) gdgssq = gdgssq + gami**2 gvg = gvg + gami*vg(i) delgam = delgam + dirin(i)*gami 100 edm = edm + grd(i)*ri*0.5 edm = edm * 0.5 * (1.0 + 3.0*dcovar) c . if edm negative, not positive-definite if (edm .lt. zero .or. gvg .le. zero) then call mnwarn('d','migrad','not pos-def. edm or gvg negative.') cstatu = 'not posdef' if (npsdf .eq. 1) go to 230 call mnpsdf npsdf = 1 go to 81 endif c print information about this iteration iter = iter + 1 if (iswtr.ge.3 .or. (iswtr.eq.2.and.mod(iter,10).eq.1)) then call mnwerr call mnprin(3,amin) endif if (gdgssq .eq. zero) call mnwarn('d','migrad', + 'no change in first derivatives over last step') if (delgam .lt. zero) call mnwarn('d','migrad', + 'first derivatives increasing along search line') c . update covariance matrix cstatu = 'improvemnt' if (ldebug) write (isyswr,'(a,(1x,10g10.3))') ' vhmat 1 =', + (vhmat(kk),kk=1,10) dsum = 0. vsum = 0. do 120 i=1, npar do 120 j=1, i d = dirin(i)*dirin(j)/delgam - vg(i)*vg(j)/gvg dsum = dsum + abs(d) ndex = i*(i-1)/2 + j vhmat(ndex) = vhmat(ndex) + 2.0*d vsum = vsum + abs(vhmat(ndex)) 120 continue c smooth local fluctuations by averaging dcovar dcovar = 0.5*(dcovar + dsum/vsum) if (iswtr.ge.3 .or. ldebug) write (isyswr,'(a,f5.1,a)') + ' relative change in cov. matrix=',dcovar*100.,'%' if (ldebug) write (isyswr,'(a,(1x,10g10.3))') ' vhmat 2 =', + (vhmat(kk),kk=1,10) if (delgam .le. gvg) go to 135 do 125 i= 1, npar 125 flnu(i) = dirin(i)/delgam - vg(i)/gvg do 130 i= 1, npar do 130 j= 1, i ndex = i*(i-1)/2 + j 130 vhmat(ndex) = vhmat(ndex) + 2.0*gvg*flnu(i)*flnu(j) 135 continue c and see if converged if (edm .lt. 0.1*rhotol) go to 300 c if not, prepare next iteration do 140 i= 1, npar xxs(i) = x(i) gs(i) = grd(i) 140 continue fs = amin impruv = impruv + 1 if (isw(2) .eq. 0 .and. dcovar.lt. 0.5 ) isw(2) = 1 if (isw(2) .eq. 3 .and. dcovar.gt. 0.1 ) isw(2) = 1 if (isw(2) .eq. 1 .and. dcovar.lt. 0.05) isw(2) = 3 go to 24 c . . . . . end main loop c . . call limit in mnmigr 190 isw(1) = 1 if (isw(5) .ge. 0) + write (isyswr,'(a)') ' call limit exceeded in migrad.' cstatu = 'call limit' go to 230 c . . fails to improve . . 200 if (iswtr .ge. 1) write (isyswr,'(a)') + ' migrad fails to find improvement' do 210 i= 1, npar 210 x(i) = xxs(i) if (edm .lt. rhotol) go to 300 if (edm .lt. abs(epsma2*amin)) then if (iswtr .ge. 0) write (isyswr, '(a)') + ' machine accuracy limits further improvement.' go to 300 endif if (istrat .lt. 1) then if (isw(5) .ge. 0) write (isyswr, '(a)') + ' migrad fails with strategy=0. will try with strategy=1.' istrat = 1 endif go to 1 c . . fails to converge 230 if (iswtr .ge. 0) write (isyswr,'(a)') + ' migrad terminated without convergence.' if (isw(2) .eq. 3) isw(2) = 1 isw(4) = -1 go to 400 c . . apparent convergence 300 if (iswtr .ge. 0) write(isyswr,'(/a)') + ' migrad minimization has converged.' if (itaur .eq. 0) then if (istrat .ge. 2 .or. (istrat.eq.1.and.isw(2).lt.3)) then if (isw(5) .ge. 0) write (isyswr, '(/a)') + ' migrad will verify convergence and error matrix.' call mnhess(fcn,futil) call mnwerr npsdf = 0 if (edm .gt. rhotol) go to 10 endif endif cstatu='converged ' isw(4) = 1 c come here in any case 400 continue cfrom = 'migrad ' nfcnfr = nfcnmg call mninex(x) call mnwerr if (iswtr .ge. 0) call mnprin (3,amin) if (iswtr .ge. 1) call mnmatu(1) return end cdeck id>, mnmnos. subroutine mnmnos(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a minos error analysis on those parameters for cc which it is requested on the minos command. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil if (npar .le. 0) go to 700 ngood = 0 nbad = 0 nfcnmi = nfcn c . loop over parameters requested do 570 knt= 1, npar if (int(word7(2)) .eq. 0) then ilax = nexofi(knt) else if (knt .ge. 7) go to 580 ilax = int(word7(knt+1)) if (ilax .eq. 0) go to 580 if (ilax .gt. 0 .and. ilax .le. nu) then if (niofex(ilax) .gt. 0) go to 565 endif write (isyswr,564) ilax 564 format (' parameter number ',i5,' not variable. ignored.') go to 570 endif 565 continue c calculate one pair of m e's ilax2 = 0 call mnmnot(fcn,ilax,ilax2,val2pl,val2mi,futil) if (lnewmn) go to 650 c update ngood and nbad iin = niofex(ilax) if (erp(iin) .gt. zero) then ngood=ngood+1 else nbad=nbad+1 endif if (ern(iin) .lt. zero) then ngood=ngood+1 else nbad=nbad+1 endif 570 continue c end of loop . . . . . . . 580 continue c . . . . printout final values . cfrom = 'minos ' nfcnfr = nfcnmi cstatu= 'unchanged ' if (ngood.eq.0.and.nbad.eq.0) go to 700 if (ngood.gt.0.and.nbad.eq.0) cstatu='successful' if (ngood.eq.0.and.nbad.gt.0) cstatu='failure ' if (ngood.gt.0.and.nbad.gt.0) cstatu='problems ' if (isw(5) .ge. 0) call mnprin(4,amin) if (isw(5) .ge. 2) call mnmatu(0) go to 900 c . . . new minimum found . . . . 650 continue cfrom = 'minos ' nfcnfr = nfcnmi cstatu= 'new minimu' if (isw(5) .ge. 0) call mnprin(4,amin) write (isyswr,675) 675 format(/50h new minimum found. go back to minimization step./1h , +60(1h=)/60x,1hv/60x,1hv/60x,1hv/57x,7hvvvvvvv/58x,5hvvvvv/59x, +3hvvv/60x,1hv//) go to 900 700 write (isyswr,'(a)') ' there are no minos errors to calculate.' 900 return end cdeck id>, mnmnot. subroutine mnmnot(fcn,ilax,ilax2,val2pl,val2mi,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a minos error analysis on one parameter. cc the parameter ilax is varied, and the minimum of the cc function with respect to the other parameters is followed cc until it crosses the value fmin+up. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension xdev(mni),w(mni),gcc(mni) character*4 cpos,cneg,csig character*1 cdot,cstar,cblank parameter (cpos='posi',cneg='nega',cdot='.',cstar='*',cblank=' ') logical lovflo, lright, lleft c . . save and prepare start vals isw2 = isw(2) isw4 = isw(4) sigsav = edm istrav = istrat dc = dcovar lovflo = .false. lnewmn = .false. toler = epsi*0.5 apsi = epsi*0.5 abest=amin aim = amin + up mpar=npar nfmxin = nfcnmx do 125 i= 1, mpar 125 xt(i) = x(i) do 130 j= 1, mpar*(mpar+1)/2 130 vthmat(j) = vhmat(j) do 135 i= 1, mpar gcc(i) = globcc(i) 135 w(i) = werr(i) it = niofex(ilax) erp(it) = 0. ern(it) = 0. call mninex(xt) ut = u(ilax) if (nvarl(ilax) .eq. 1) then alim(ilax) = ut -100.*w(it) blim(ilax) = ut +100.*w(it) endif ndex = it*(it+1)/2 xunit = dsqrt(up/vthmat(ndex)) marc = 0 do 162 i= 1, mpar if (i .eq. it) go to 162 marc = marc + 1 imax = max(it,i) indx = imax*(imax-1)/2 + min(it,i) xdev(marc) = xunit*vthmat(indx) 162 continue c fix the parameter in question call mnfixp (it,ierr) if (ierr .gt. 0) then write (isyswr,'(a,i5,a,i5)') + ' minuit error. cannot fix parameter',ilax,' internal',it go to 700 endif c . . . . . nota bene: from here on, npar=mpar-1 c remember: mnfixp squeezes it out of x, xt, werr, and vhmat, c not w, vthmat do 500 isig= 1,2 if (isig .eq. 1) then sig = 1.0 csig = cpos else sig = -1.0 csig = cneg endif c . sig=sign of error being calcd if (isw(5) .gt. 1) write (isyswr,806) csig,ilax,cpnam(ilax) 806 format (/' determination of ',a4,'tive minos error for parameter', + i3, 2x ,a) if (isw(2).le.0) call mnwarn('d','minos','no covariance matrix.') nlimit = nfcn + nfmxin istrat = max(istrav-1,0) du1 = w(it) u(ilax) = ut + sig*du1 fac = sig*du1/w(it) do 185 i= 1, npar 185 x(i) = xt(i) + fac*xdev(i) if (isw(5) .gt. 1) write (isyswr,801) ilax,ut,sig*du1,u(ilax) 801 format (/' parameter',i4,' set to',e11.3,' + ',e10.3,' = ',e12.3) c loop to hit aim ke1cr = ilax ke2cr = 0 xmidcr = ut + sig*du1 xdircr = sig*du1 c amin = abest nfcnmx = nlimit - nfcn call mncros(fcn,aopt,iercr,futil) if (abest-amin .gt. 0.01*up) go to 650 if (iercr .eq. 1) go to 440 if (iercr .eq. 2) go to 450 if (iercr .eq. 3) go to 460 c . error successfully calculated eros = sig*du1 + aopt*xdircr if (isw(5) .gt. 1) write (isyswr,808) csig,ilax,cpnam(ilax),eros 808 format (/9x,4hthe ,a4, 29htive minos error of parameter,i3, 2h +, ,a10, 4h, is ,e12.4) go to 480 c . . . . . . . . failure returns 440 if (isw(5) .ge. 1) write(isyswr,807) csig,ilax,cpnam(ilax) 807 format (5x,'the ',a4,'tive minos error of parameter',i3,', ',a, +', exceeds its limit.'/) eros = undefi go to 480 450 if (isw(5) .ge. 1) write (isyswr, 802) csig,ilax,nfmxin 802 format (9x,'the ',a,'tive minos error',i4,' requires more than', + i5,' function calls.'/) eros = 0. go to 480 460 if (isw(5) .ge. 1) write (isyswr, 805) csig,ilax 805 format (25x,a,'tive minos error not calculated for parameter',i4/) eros = 0. c 480 if (isw(5) .gt. 1) write (isyswr,'(5x, 74(1h*))') if (sig .lt. zero) then ern(it) = eros if (ilax2.gt.0 .and. ilax2.le.nu) val2mi = u(ilax2) else erp(it) = eros if (ilax2.gt.0 .and. ilax2.le.nu) val2pl = u(ilax2) endif 500 continue c . . parameter finished. reset v c normal termination itaur = 1 call mnfree(1) do 550 j= 1, mpar*(mpar+1)/2 550 vhmat(j) = vthmat(j) do 595 i= 1, mpar werr(i) = w(i) globcc(i) = gcc(i) 595 x(i) = xt(i) call mninex (x) edm = sigsav amin = abest isw(2) = isw2 isw(4) = isw4 dcovar = dc go to 700 c new minimum 650 lnewmn = .true. isw(2) = 0 dcovar = 1. isw(4) = 0 sav = u(ilax) itaur = 1 call mnfree(1) u(ilax) = sav call mnexin(x) edm = bigedm c in any case 700 continue itaur = 0 nfcnmx = nfmxin istrat = istrav return end cdeck id>, mnparm. subroutine mnparm(k,cnamj,uk,wk,a,b,ierflg) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnread and user-callable cc implements one parameter definition, that is: cc k (external) parameter number cc cnamk parameter name cc uk starting value cc wk starting step size or uncertainty cc a, b lower and upper physical parameter limits cc and sets up (updates) the parameter lists. cc output: ierflg=0 if no problems cc >0 if mnparm unable to implement definition cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead character*(*) cnamj character cnamk*10, chbufi*4 c cnamk = cnamj kint = npar if (k.lt.1 .or. k.gt.maxext) then c parameter number exceeds allowed maximum value write (isyswr,9) k,maxext 9 format (/' minuit user error. parameter number is',i11/ + ', allowed range is one to',i4/) go to 800 endif c normal parameter request ktofix = 0 if (nvarl(k) .lt. 0) go to 50 c previously defined parameter is being redefined c find if parameter was fixed do 40 ix= 1, npfix if (ipfix(ix) .eq. k) ktofix = k 40 continue if (ktofix .gt. 0) then call mnwarn('w','param def','redefining a fixed parameter.') if (kint .ge. maxint) then write (isyswr,'(a)') ' cannot release. max npar exceeded.' go to 800 endif call mnfree(-k) endif c if redefining previously variable parameter if(niofex(k) .gt. 0) kint = npar-1 50 continue c c . . .print heading if (lphead .and. isw(5).ge.0) then write (isyswr,61) lphead = .false. endif 61 format(/' parameter definitions:'/ + ' no. name value step size limits') if (wk .gt. zero) go to 122 c . . .constant parameter . . . . if (isw(5) .ge. 0) write (isyswr, 82) k,cnamk,uk 82 format (1x,i5,1x,1h',a10,1h',1x,g13.5, ' constant') nvl = 0 go to 200 122 if (a.eq.zero .and. b.eq.zero) then c variable parameter without limits nvl = 1 if (isw(5) .ge. 0) write (isyswr, 127) k,cnamk,uk,wk 127 format (1x,i5,1x,1h',a10,1h',1x,2g13.5, ' no limits') else c variable parameter with limits nvl = 4 lnolim = .false. if (isw(5) .ge. 0) write (isyswr, 132) k,cnamk,uk,wk,a,b 132 format(1x,i5,1x,1h',a10,1h',1x,2g13.5,2x,2g13.5) endif c . . request for another variable parameter kint = kint + 1 if (kint .gt. maxint) then write (isyswr,135) maxint 135 format (/' minuit user error. too many variable parameters.'/ + ' this version of minuit dimensioned for',i4//) go to 800 endif if (nvl .eq. 1) go to 200 if (a .eq. b) then write (isyswr,'(/a,a/a/)') ' user error in minuit parameter', + ' definition',' upper and lower limits equal.' go to 800 endif if (b .lt. a) then sav = b b = a a = sav call mnwarn('w','param def','parameter limits were reversed.') if (lwarn) lphead=.true. endif if ((b-a) .gt. 1.0e7) then write (chbufi,'(i4)') k call mnwarn('w','param def', + 'limits on param'//chbufi//' too far apart.') if (lwarn) lphead=.true. endif danger = (b-uk)*(uk-a) if (danger .lt. 0.) + call mnwarn('w','param def','starting value outside limits.') if (danger .eq. 0.) + call mnwarn('w','param def','starting value is at limit.') 200 continue c . . . input ok, set values, arrange lists, c calculate step sizes gstep, dirin cfrom = 'parametr' nfcnfr = nfcn cstatu= 'new values' nu = max(nu,k) cpnam(k) = cnamk u(k) = uk alim(k) = a blim(k) = b nvarl(k) = nvl call mnrset(1) c k is external number of new parameter c lastin is the number of var. params with ext. param. no.< k lastin = 0 do 240 ix= 1, k-1 if (niofex(ix) .gt. 0) lastin=lastin+1 240 continue c kint is new number of variable params, npar is old if (kint .eq. npar) go to 280 if (kint .gt. npar) then c insert new variable parameter in list do 260 in= npar,lastin+1,-1 ix = nexofi(in) niofex(ix) = in+1 nexofi(in+1)= ix x (in+1) = x (in) xt (in+1) = xt (in) dirin(in+1) = dirin(in) g2 (in+1) = g2 (in) gstep(in+1) = gstep(in) 260 continue else c remove variable parameter from list do 270 in= lastin+1,kint ix = nexofi(in+1) niofex(ix) = in nexofi(in)= ix x (in)= x (in+1) xt (in)= xt (in+1) dirin (in)= dirin(in+1) g2 (in)= g2 (in+1) gstep (in)= gstep(in+1) 270 continue endif 280 continue ix = k niofex(ix) = 0 npar = kint c lists are now arranged . . . . if (nvl .gt. 0) then in = lastin+1 nexofi(in) = ix niofex(ix) = in sav = u(ix) call mnpint(sav,ix,pinti) x(in) = pinti xt(in) = x(in) werr(in) = wk sav2 = sav + wk call mnpint(sav2,ix,pinti) vplu = pinti - x(in) sav2 = sav - wk call mnpint(sav2,ix,pinti) vminu = pinti - x(in) dirin(in) = 0.5 * (abs(vplu) +abs(vminu)) g2(in) = 2.0*up / dirin(in)**2 gsmin = 8.*epsma2*abs(x(in)) gstep(in) = max (gsmin, 0.1*dirin(in)) if (amin .ne. undefi) then small = dsqrt(epsma2*(amin+up)/up) gstep(in) = max(gsmin, small*dirin(in)) endif grd (in) = g2(in)*dirin(in) c if parameter has limits if (nvarl(k) .gt. 1) then if (gstep(in).gt. 0.5) gstep(in)=0.5 gstep(in) = -gstep(in) endif endif if (ktofix .gt. 0) then kinfix = niofex(ktofix) if (kinfix .gt. 0) call mnfixp(kinfix,ierr) if (ierr .gt. 0) go to 800 endif ierflg = 0 return c error on input, unable to implement request . . . . 800 continue ierflg = 1 return end cdeck id>, mnpfit. subroutine mnpfit(parx2p,pary2p,npar2p,coef2p,sdev2p) c ************ double precision version ************* implicit double precision (a-h,o-z) c c to fit a parabola to npar2p points c c npar2p no. of points c parx2p(i) x value of point i c pary2p(i) y value of point i c c coef2p(1...3) coefficients of the fitted parabola c y=coef2p(1) + coef2p(2)*x + coef2p(3)*x**2 c sdev2p= variance c method : chi**2 = min equation solved explicitly dimension parx2p(npar2p),pary2p(npar2p),coef2p(npar2p) dimension cz(3) c do 3 i=1,3 3 cz(i)=0. sdev2p=0. if(npar2p.lt.3) go to 10 f=npar2p c--- center x values for reasons of machine precision xm=0. do 2 i=1,npar2p 2 xm=xm+parx2p(i) xm=xm/f x2=0. x3=0. x4=0. y=0. y2=0. xy=0. x2y=0. do 1 i=1,npar2p s=parx2p(i)-xm t=pary2p(i) s2=s*s x2=x2+s2 x3=x3+s*s2 x4=x4+s2*s2 y=y+t y2=y2+t*t xy=xy+s*t x2y=x2y+s2*t 1 continue a=(f*x4-x2**2)*x2-f*x3**2 if(a.eq.0.) goto 10 cz(3)=(x2*(f*x2y-x2*y)-f*x3*xy)/a cz(2)=(xy-x3*cz(3))/x2 cz(1)=(y-x2*cz(3))/f if(npar2p.eq.3) goto 6 sdev2p=y2-(cz(1)*y+cz(2)*xy+cz(3)*x2y) if(sdev2p.lt.0.) sdev2p=0. sdev2p=sdev2p/(f-3.) 6 cz(1)=cz(1)+xm*(xm*cz(3)-cz(2)) cz(2)=cz(2)-2.*xm*cz(3) 10 continue do 11 i=1,3 11 coef2p(i)=cz(i) return end cdeck id>, mnpint. subroutine mnpint(pexti,i,pinti) c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the internal parameter value pinti corresponding cc to the external value pexti for parameter i. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead logical limloc character chbufi*4, chbuf2*30 limloc = .false. pinti = pexti igo = nvarl(i) if (igo .eq. 4) then c-- there are two limits alimi = alim(i) blimi = blim(i) yy=2.0*(pexti-alimi)/(blimi-alimi) - 1.0 yy2 = yy**2 if (yy2 .ge. (1.0- epsma2)) then if (yy .lt. 0.) then a = vlimlo chbuf2 = ' is at its lower allowed limit.' else a = vlimhi chbuf2 = ' is at its upper allowed limit.' endif pinti = a pexti = alimi + 0.5* (blimi-alimi) *(dsin(a) +1.0) limset = .true. write (chbufi,'(i4)') i if (yy2 .gt. 1.0) chbuf2 = ' brought back inside limits.' call mnwarn('w',cfrom,'variable'//chbufi//chbuf2) else pinti = dasin(yy) endif endif return end cdeck id>, mnplot. subroutine mnplot(xpt,ypt,chpt,nxypt,nunit,npagwd,npagln) c ************ double precision version ************* implicit double precision (a-h,o-z) cc plots points in array xypt onto one page with labelled axes cc nxypt is the number of points to be plotted cc xpt(i) = x-coord. of ith point cc ypt(i) = y-coord. of ith point cc chpt(i) = character to be plotted at this position cc the input point arrays xpt, ypt, chpt are destroyed. cc dimension xpt(*), ypt(*), sav(2) character*1 chpt(*) , chsav, chbest, cdot, cslash, cblank parameter (maxwid=100) character cline*100, chmess*30 dimension xvalus(12) logical overpr data cdot,cslash,cblank/ '.' , '/' , ' '/ maxnx = min(npagwd-20,maxwid) if (maxnx .lt. 10) maxnx = 10 maxny = npagln if (maxny .lt. 10) maxny = 10 if (nxypt .le. 1) return xbest = xpt(1) ybest = ypt(1) chbest = chpt(1) c order the points by decreasing y km1 = nxypt - 1 do 150 i= 1, km1 iquit = 0 ni = nxypt - i do 140 j= 1, ni if (ypt(j) .gt. ypt(j+1)) go to 140 savx = xpt(j) xpt(j) = xpt(j+1) xpt(j+1) = savx savy = ypt(j) ypt(j) = ypt(j+1) ypt(j+1) = savy chsav = chpt(j) chpt(j) = chpt(j+1) chpt(j+1) = chsav iquit = 1 140 continue if (iquit .eq. 0) go to 160 150 continue 160 continue c find extreme values xmax = xpt(1) xmin = xmax do 200 i= 1, nxypt if (xpt(i) .gt. xmax) xmax = xpt(i) if (xpt(i) .lt. xmin) xmin = xpt(i) 200 continue dxx = 0.001*(xmax-xmin) xmax = xmax + dxx xmin = xmin - dxx call mnbins(xmin,xmax,maxnx,xmin,xmax,nx,bwidx) ymax = ypt(1) ymin = ypt(nxypt) if (ymax .eq. ymin) ymax=ymin+1.0 dyy = 0.001*(ymax-ymin) ymax = ymax + dyy ymin = ymin - dyy call mnbins(ymin,ymax,maxny,ymin,ymax,ny,bwidy) any = ny c if first point is blank, it is an 'origin' if (chbest .eq. cblank) go to 50 xbest = 0.5 * (xmax+xmin) ybest = 0.5 * (ymax+ymin) 50 continue c find scale constants ax = 1.0/bwidx ay = 1.0/bwidy bx = -ax*xmin + 2.0 by = -ay*ymin - 2.0 c convert points to grid positions do 300 i= 1, nxypt xpt(i) = ax*xpt(i) + bx 300 ypt(i) = any-ay*ypt(i) - by nxbest = ax*xbest + bx nybest = any - ay*ybest - by c print the points ny = ny + 2 nx = nx + 2 isp1 = 1 linodd = 1 overpr=.false. do 400 i= 1, ny do 310 ibk= 1, nx 310 cline (ibk:ibk) = cblank cline(1:1) = cdot cline(nx:nx) = cdot cline(nxbest:nxbest) = cdot if (i.ne.1 .and. i.ne.nybest .and. i.ne.ny) go to 320 do 315 j= 1, nx 315 cline(j:j) = cdot 320 continue yprt = ymax - float(i-1)*bwidy if (isp1 .gt. nxypt) go to 350 c find the points to be plotted on this line do 341 k= isp1,nxypt ks = ypt(k) if (ks .gt. i) go to 345 ix = xpt(k) if (cline(ix:ix) .eq. cdot) go to 340 if (cline(ix:ix) .eq. cblank) go to 340 if (cline(ix:ix) .eq.chpt(k)) go to 341 overpr = .true. c overpr is true if one or more positions contains more than c one point cline(ix:ix) = '&' go to 341 340 cline(ix:ix) = chpt(k) 341 continue isp1 = nxypt + 1 go to 350 345 isp1 = k 350 continue if (linodd .eq. 1 .or. i .eq. ny) go to 380 linodd = 1 write (nunit, '(18x,a)') cline(:nx) go to 400 380 write (nunit,'(1x,g14.7,a,a)') yprt, ' ..', cline(:nx) linodd = 0 400 continue c print labels on x-axis every ten columns do 410 ibk= 1, nx cline(ibk:ibk) = cblank if (mod(ibk,10) .eq. 1) cline(ibk:ibk) = cslash 410 continue write (nunit, '(18x,a)') cline(:nx) c do 430 ibk= 1, 12 430 xvalus(ibk) = xmin + float(ibk-1)*10.*bwidx iten = (nx+9) / 10 write (nunit,'(12x,12g10.4)') (xvalus(ibk), ibk=1,iten) chmess = ' ' if (overpr) chmess=' overprint character is &' write (nunit,'(25x,a,g13.7,a)') 'one column=',bwidx, chmess 500 return end cdeck id>, mnpout. subroutine mnpout(iuext,chnam,val,err,xlolim,xuplim,iuint) c ************ double precision version ************* implicit double precision (a-h,o-z) cc user-called cc provides the user with information concerning the current status cc of parameter number iuext. namely, it returns: cc chnam: the name of the parameter cc val: the current (external) value of the parameter cc err: the current estimate of the parameter uncertainty cc xlolim: the lower bound (or zero if no limits) cc xuplim: the upper bound (or zero if no limits) cc iuint: the internal parameter number (or zero if not variable, cc or negative if undefined). cc note also: if iuext is negative, then it is -internal parameter cc number, and iuint is returned as the external number. cc except for iuint, this is exactly the inverse of mnparm cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead character*(*) chnam xlolim = 0. xuplim = 0. err = 0. if (iuext .eq. 0) go to 100 if (iuext .lt. 0) then c internal parameter number specified iint = -iuext if (iint .gt. npar) go to 100 iext = nexofi(iint) iuint = iext else c external parameter number specified iext = iuext if (iext .eq. 0) go to 100 if (iext .gt. nu) go to 100 iint = niofex(iext) iuint = iint endif c in both cases nvl = nvarl(iext) if (nvl .lt. 0) go to 100 chnam = cpnam(iext) val = u(iext) if (iint .gt. 0) err = werr(iint) if (nvl .eq. 4) then xlolim = alim(iext) xuplim = blim(iext) endif return c parameter is undefined 100 iuint = -1 chnam = 'undefined' val = 0. return end cdeck id>, mnprin. subroutine mnprin (inkode,fval) c ************ double precision version ************* implicit double precision (a-h,o-z) cc prints the values of the parameters at the time of the call. cc also prints other relevant information such as function value, cc estimated distance to minimum, parameter errors, step sizes. cc c according to the value of ikode, the printout is: c ikode=inkode= 0 only info about function value c 1 parameter values, errors, limits c 2 values, errors, step sizes, internal values c 3 values, errors, step sizes, first derivs. c 4 values, parabolic errors, minos errors c when inkode=5, mnprin chooses ikode=1,2, or 3, according to isw(2) c parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c character*14 colhdu(6),colhdl(6), cx2,cx3,cgetx character*11 cnambf, cblank character chedm*10, cheval*15 parameter (cgetx='please get x..') data cblank/' '/ c if (nu .eq. 0) then write (isyswr,'(a)') ' there are currently no parameters defined' go to 700 endif c get value of ikode based in inkode, isw(2) ikode = inkode if (inkode .eq. 5) then ikode = isw(2)+1 if (ikode .gt. 3) ikode=3 endif c set 'default' column headings do 5 k= 1, 6 colhdu(k) = 'undefined' 5 colhdl(k) = 'column head' c print title if minos errors, and title exists. if (ikode.eq.4 .and. ctitl.ne.cundef) + write (isyswr,'(/a,a)') ' minuit task: ',ctitl c report function value and status if (fval .eq. undefi) then cheval = ' unknown ' else write (cheval,'(g15.7)') fval endif if (edm .eq. bigedm) then chedm = ' unknown ' else write (chedm, '(e10.2)') edm endif nc = nfcn-nfcnfr write (isyswr,905) cheval,cfrom,cstatu,nc,nfcn 905 format (/' fcn=',a,' from ',a8,' status=',a10,i6,' calls', + i9,' total') m = isw(2) if (m.eq.0 .or. m.eq.2 .or. dcovar.eq.zero) then write (isyswr,907) chedm,istrat,covmes(m) 907 format (21x,'edm=',a,' strategy=',i2,6x,a) else dcmax = 1. dc = min(dcovar,dcmax) * 100. write (isyswr,908) chedm,istrat,dc 908 format (21x,'edm=',a,' strategy=',i1,' error matrix', + ' uncertainty=',f5.1,'%') endif c if (ikode .eq. 0) go to 700 c find longest name (for rene!) ntrail = 10 do 20 i= 1, nu if (nvarl(i) .lt. 0) go to 20 do 15 ic= 10,1,-1 if (cpnam(i)(ic:ic) .ne. ' ') go to 16 15 continue ic = 1 16 lbl = 10-ic if (lbl .lt. ntrail) ntrail=lbl 20 continue nadd = ntrail/2 + 1 if (ikode .eq. 1) then colhdu(1) = ' ' colhdl(1) = ' error ' colhdu(2) = ' physical' colhdu(3) = ' limits ' colhdl(2) = ' negative ' colhdl(3) = ' positive ' endif if (ikode .eq. 2) then colhdu(1) = ' ' colhdl(1) = ' error ' colhdu(2) = ' internal ' colhdl(2) = ' step size ' colhdu(3) = ' internal ' colhdl(3) = ' value ' endif if (ikode .eq. 3) then colhdu(1) = ' ' colhdl(1) = ' error ' colhdu(2) = ' step ' colhdl(2) = ' size ' colhdu(3) = ' first ' colhdl(3) = ' derivative ' endif if (ikode .eq. 4) then colhdu(1) = ' parabolic ' colhdl(1) = ' error ' colhdu(2) = ' minos ' colhdu(3) = 'errors ' colhdl(2) = ' negative ' colhdl(3) = ' positive ' endif c if (ikode .ne. 4) then if (isw(2) .lt. 3) colhdu(1)=' approximate ' if (isw(2) .lt. 1) colhdu(1)=' current guess' endif ncol = 3 write (isyswr, 910) (colhdu(kk),kk=1,ncol) write (isyswr, 911) (colhdl(kk),kk=1,ncol) 910 format (/' ext parameter ', 13x ,6a14) 911 format ( ' no. name ',' value ',6a14) c c . . . loop over parameters . . do 200 i= 1, nu if (nvarl(i) .lt. 0) go to 200 l = niofex(i) cnambf = cblank(1:nadd)//cpnam(i) if (l .eq. 0) go to 55 c variable parameter. x1 = werr(l) cx2 = cgetx cx3 = cgetx if (ikode .eq. 1) then if (nvarl(i) .le. 1) then write (isyswr, 952) i,cnambf,u(i),x1 go to 200 else x2 = alim(i) x3 = blim(i) endif endif if (ikode .eq. 2) then x2 = dirin(l) x3 = x(l) endif if (ikode .eq. 3) then x2 = dirin(l) x3 = grd(l) if (nvarl(i).gt.1 .and. abs(dcos(x(l))) .lt. 0.001) + cx3 = '** at limit **' endif if (ikode .eq. 4) then x2 = ern(l) if (x2.eq.zero) cx2=' ' if (x2.eq.undefi) cx2=' at limit ' x3 = erp(l) if (x3.eq.zero) cx3=' ' if (x3.eq.undefi) cx3=' at limit ' endif if (cx2.eq.cgetx) write (cx2,'(g14.5)') x2 if (cx3.eq.cgetx) write (cx3,'(g14.5)') x3 write (isyswr,952) i,cnambf,u(i),x1,cx2,cx3 952 format (i4,1x,a11,2g14.5,2a) c check if parameter is at limit if (nvarl(i) .le. 1 .or. ikode .eq. 3) go to 200 if (abs(dcos(x(l))) .lt. 0.001) write (isyswr,1004) 1004 format (1h ,32x,42hwarning - - above parameter is at limit.) go to 200 c c print constant or fixed parameter. 55 continue colhdu(1) = ' constant ' if (nvarl(i).gt.0) colhdu(1) = ' fixed ' if (nvarl(i).eq.4 .and. ikode.eq.1) then write (isyswr,'(i4,1x,a11,g14.5,a,2g14.5)') + i,cnambf,u(i),colhdu(1),alim(i),blim(i) else write (isyswr,'(i4,1x,a11,g14.5,a)') i,cnambf,u(i),colhdu(1) endif 200 continue c if (up.ne.updflt) write (isyswr,'(31x,a,g10.2)') 'err def=',up 700 continue return end cdeck id>, mnpsdf. subroutine mnpsdf c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the eigenvalues of v to see if positive-def. cc if not, adds constant along diagonal to make positive. parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead character chbuff*12 dimension s(mni) epsmin = 1.0e-6 epspdf = max(epsmin, epsma2) dgmin = vhmat(1) c check if negative or zero on diagonal do 200 i= 1, npar ndex = i*(i+1)/2 if (vhmat(ndex) .le. zero) then write (chbuff(1:3),'(i3)') i call mnwarn('w',cfrom, +'negative diagonal element'//chbuff(1:3)//' in error matrix') endif if (vhmat(ndex) .lt. dgmin) dgmin = vhmat(ndex) 200 continue if (dgmin .le. 0.) then dg = 1.0 - dgmin write (chbuff,'(e12.2)') dg call mnwarn('w',cfrom, + chbuff//' added to diagonal of error matrix') else dg = 0. endif c store vhmat in p, make sure diagonal pos. do 213 i= 1, npar ndex = i*(i-1)/2 ndexd = ndex + i vhmat(ndexd) = vhmat(ndexd) + dg s(i) = 1.0/dsqrt(vhmat(ndexd)) do 213 j= 1, i ndex = ndex + 1 213 p(i,j) = vhmat(ndex) * s(i)*s(j) c call eigen (p,p,maxint,npar,pstar,-npar) call mneig(p,maxint,npar,maxint,pstar,epspdf,ifault) pmin = pstar(1) pmax = pstar(1) do 215 ip= 2, npar if (pstar(ip) .lt. pmin) pmin = pstar(ip) if (pstar(ip) .gt. pmax) pmax = pstar(ip) 215 continue pmax = max(abs(pmax), one) if ((pmin .le. zero .and. lwarn) .or. isw(5) .ge. 2) then write (isyswr,550) write (isyswr,551) (pstar(ip),ip=1,npar) endif if (pmin .gt. epspdf*pmax) go to 217 if (isw(2) .eq. 3) isw(2)=2 padd = 1.0e-3*pmax - pmin do 216 ip= 1, npar ndex = ip*(ip+1)/2 216 vhmat(ndex) = vhmat(ndex) *(1.0 + padd) cstatu= 'not posdef' write (chbuff,'(g12.5)') padd call mnwarn('w',cfrom, + 'matrix forced pos-def by adding '//chbuff//' to diagonal.') 217 continue c 550 format (' eigenvalues of second-derivative matrix:' ) 551 format (7x,6e12.4) return end cdeck id>, mnrazz. subroutine mnrazz(ynew,pnew,y,jh,jl) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called only by mnsimp (and mnimpr) to add a new point cc and remove an old one from the current simplex, and get the cc estimated distance to minimum. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension pnew(*), y(*) do 10 i=1,npar 10 p(i,jh) = pnew(i) y(jh)=ynew if(ynew .lt. amin) then do 15 i=1,npar 15 x(i) = pnew(i) call mninex(x) amin = ynew cstatu = 'progress ' jl=jh endif jh = 1 nparp1 = npar+1 20 do 25 j=2,nparp1 if (y(j) .gt. y(jh)) jh = j 25 continue edm = y(jh) - y(jl) if (edm .le. zero) go to 45 us = 1.0/edm do 35 i= 1, npar pbig = p(i,1) plit = pbig do 30 j= 2, nparp1 if (p(i,j) .gt. pbig) pbig = p(i,j) if (p(i,j) .lt. plit) plit = p(i,j) 30 continue dirin(i) = pbig - plit 35 continue 40 return 45 write (isyswr, 1000) npar go to 40 1000 format (' function value does not seem to depend on any of the', + i3,' variable parameters.' /10x,'verify that step sizes are', + ' big enough and check fcn logic.'/1x,79(1h*)/1x,79(1h*)/) end cdeck id>, mnread. subroutine mnread(fcn,iflgin,iflgut,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from minuit. reads all user input to minuit. cc this routine is highly unstructured and defies normal logic. cc cc iflgin indicates the function originally requested: cc = 1: read one-line title cc 2: read parameter definitions cc 3: read minuit commands cc cc iflgut= 1: reading terminated normally cc 2: end-of-data on input cc 3: unrecoverable read error cc 4: unable to process parameter requests cc internally, cc iflgdo indicates the subfunction to be performed on the next cc input record: 1: read a one-line title cc 2: read a parameter definition cc 3: read a command cc 4: read in covariance matrix cc for example, when iflgin=3, but iflgdo=1, then it should read cc a title, but this was requested by a command, not by minuit. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension plist(maxp) character cnamk*10, crdbuf*80, celmnt*20 character comand*(maxcwd) character cpromt(3)*40, clower*26, cupper*26 logical leof data cpromt/' enter minuit title, or "set input n" : ', + ' enter minuit parameter definition: ', + ' enter minuit command: '/ c data clower/'abcdefghijklmnopqrstuvwxyz'/ data cupper/'abcdefghijklmnopqrstuvwxyz'/ c iflgut = 1 iflgdo = iflgin ifatal = 0 leof = .false. c . . . . read next record 10 continue if (isw(6) .eq. 1) write (isyswr,'(a)') cpromt(iflgdo) crdbuf = ' ' read (isysrd,'(a)',err=500,end=45) crdbuf c . . preemptive commands leof = .false. if (index(crdbuf,'*eof') .eq. 1 .or. + index(crdbuf,'*eof') .eq. 1) then write (isyswr,'(a,i3)') ' *eof encountered on unit no.',isysrd lphead = .true. go to 50 endif if (index(crdbuf,'set inp') .eq. 1 .or. + index(crdbuf,'set inp') .eq. 1) then icomnd = icomnd + 1 write (isyswr, 21) icomnd,crdbuf(1:50) 21 format (' **********'/' **',i5,' **',a/' **********') lphead = .true. go to 50 endif go to 80 c . . hardware eof on current isysrd 45 crdbuf = '*eof ' write (isyswr,'(a,i3)') ' end of data on unit no.',isysrd c or set input command 50 continue call mnstin(crdbuf,ierr) if (ierr .eq. 0) go to 10 if (ierr .eq. 2) then if (.not. leof) then write (isyswr,'(a,a/)') ' two consecutive eofs on ', + 'primary input file will terminate execution.' leof = .true. go to 10 endif endif iflgut = ierr go to 900 80 if (iflgdo .gt. 1) go to 100 c read title . . . . . iflgdo = 1 c if title is 'set title', skip and read again if (index(crdbuf,'set tit') .eq. 1) go to 10 if (index(crdbuf,'set tit') .eq. 1) go to 10 ctitl = crdbuf(1:50) write (isyswr,'(1x,a50)') ctitl write (isyswr,'(1x,78(1h*))') lphead = .true. if (iflgin .eq. iflgdo) go to 900 iflgdo = iflgin go to 10 c data record is not a title. get upper case 100 continue do 110 i= 1, maxcwd if (crdbuf(i:i) .eq. '''') go to 111 do 108 ic= 1, 26 if (crdbuf(i:i) .eq. clower(ic:ic)) crdbuf(i:i)=cupper(ic:ic) 108 continue 110 continue 111 continue c read parameter definitions. iflgdo = 2 if (iflgdo .gt. 2) go to 300 c if parameter def is 'parameter', skip and read again if (index(crdbuf,'par') .eq. 1) go to 10 c if line starts with set title, read a title first if (index(crdbuf,'set tit') .eq. 1) then iflgdo = 1 go to 10 endif c find out whether fixed or free-field format kapo1 = index(crdbuf,'''') if (kapo1 .eq. 0) go to 150 kapo2 = index(crdbuf(kapo1+1:),'''') if (kapo2 .eq. 0) go to 150 c new (free-field) format kapo2 = kapo2 + kapo1 c skip leading blanks if any do 115 istart=1, kapo1-1 if (crdbuf(istart:istart) .ne. ' ') go to 120 115 continue istart = kapo1-1 120 continue c parameter number integer if (istart .lt. 1) go to 210 celmnt = crdbuf(istart:kapo1-1) read (celmnt,'(bn,f20.0)',err=180) fk k = fk if (k .eq. 0) go to 210 cnamk = 'param '//celmnt if (kapo2-kapo1 .gt. 1) cnamk = crdbuf(kapo1+1:kapo2-1) call mncrck(crdbuf(kapo2+1:),maxcwd,comand,lnc, + maxp,plist,llist, ierr,isyswr) if (ierr .gt. 0) go to 180 uk = plist(1) wk = 0. if (llist .ge. 2) wk = plist(2) a = 0. if (llist .ge. 3) a = plist(3) b = 0. if (llist .ge. 4) b = plist(4) go to 170 c old (fixed-field) format 150 continue read (crdbuf, 158,err=180) xk,cnamk,uk,wk,a,b 158 format (bn,f10.0, a10, 4f10.0) k = xk if (k .eq. 0) go to 210 c parameter format cracked, implement parameter definition 170 call mnparm(k,cnamk,uk,wk,a,b,ierr) if (ierr .eq. 0) go to 10 c format error 180 continue if (isw(6) .eq. 1) then write (isyswr,'(a)') ' format error. ignored. enter again.' else write (isyswr,'(a)') ' error in parameter definition' ifatal = ifatal + 1 endif go to 10 c . . . end parameter requests 210 write (isyswr,'(4x,75(1h*))') if (ifatal.gt.0 .and. isw(6).ne.1) then iflgut = 4 go to 900 endif if (iflgin .eq. iflgdo) go to 900 iflgdo = iflgin go to 10 c . . . . . iflgdo = 3 c read commands 300 continue c crack the next command . . . . . . . . . . . . . . . . do 350 ipos= 1, 80 if (crdbuf(ipos:ipos) .ne. ' ') go to 355 350 continue write (isyswr,'(a)') ' blank command ignored.' go to 10 355 ibegin = ipos call mncrck(crdbuf(ibegin:),maxcwd,comand,lnc, + maxp, plist, llist, ierr,isyswr) if (ierr .gt. 0) then if (isw(6) .eq. 1) then write (isyswr,'(a)') ' command ignored ' go to 10 else write (isyswr,'(a)') ' command cannot be interpreted' go to 500 endif endif c certain commands are trapped here already lphead = .true. if (index(comand,'par' ) .eq. 1) go to 440 if (index(comand,'set') .ne. 1) go to 370 if (index(comand,'cov') .eq. 5) go to 400 if (index(comand,'tit') .eq. 5) go to 460 370 continue call mnexcm(fcn,comand(1:lnc),plist,llist,ierr,futil) if (comand(1:3).eq.'end') go to 900 if (comand(1:3).eq.'exi') go to 900 if (comand(1:3).eq.'ret') go to 900 if (comand(1:3).eq.'sto') go to 900 go to 10 c . . . . . . . . . . set covar 400 nrape = plist(1) icomnd = icomnd + 1 write (isyswr,405) icomnd,comand(1:lnc),(plist(i),i=1,llist) 405 format (1h ,10(1h*)/' **',i5,' **',a,4g12.4/20x,5g12.4) write (isyswr, '(1h ,10(1h*))' ) if (nrape .ne. npar) go to 425 npar2 = npar*(npar+1)/2 read (isysrd,420,err=500,end=45) (vhmat(i),i=1,npar2) 420 format (bn,7e11.4,3x) isw(2) = 3 dcovar = 0.0 if (isw(5) .ge. 0) call mnmatu(1) if (isw(5) .ge. 1) call mnprin(2,amin) go to 10 425 continue write (isyswr,428) 428 format(' size of covariance matrix to be read does not', + ' correspond to'/' number of currently variable parameters.', + ' command ignored.'/) read (isysrd,420,err=500,end=45) ((dummy,i=1,j),j=1,nrape) go to 10 c . . . . . parameter command 440 continue iflgdo = 2 ifatal = 0 c go and read parameter definitions go to 10 c . . . . set title 460 continue iflgdo = 1 go to 10 c . . . . error conditions 500 iflgut = 3 900 return end cdeck id>, mnrn15. subroutine mnrn15(val,inseed) c ************ double precision version ************* implicit double precision (a-h,o-z) c this is a super-portable random number generator. c it should not overflow on any 32-bit machine. c the cycle is only ~10**9, so use with care! c note especially that val must not be undefined on input. c set default starting seed parameter (three=3.0) data iseed/12345/ if (val .eq. three) go to 100 c inseed = iseed k = iseed/53668 iseed = 40014*(iseed-k*53668) - k*12211 if (iseed .lt. 0) iseed = iseed + 2147483563 val = real(iseed) * 4.656613e-10 return c "entry" to set seed, flag is val=3. 100 iseed = inseed return end cdeck id>, mnrset. subroutine mnrset(iopt) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mncler and whenever problem changes, for example cc after set limits, set param, call fcn 6 cc if iopt=1, cc resets function value and errors to undefined cc if iopt=0, sets only minos errors to undefined parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead cstatu = 'reset ' if (iopt .ge. 1) then amin = undefi fval3 = 2.0*abs(amin) + 1. edm = bigedm isw(4) = 0 isw(2) = 0 dcovar = 1. isw(1) = 0 endif lnolim = .true. do 10 i= 1, npar iext = nexofi(i) if (nvarl(iext) .ge. 4) lnolim=.false. erp(i) = zero ern(i) = zero globcc(i) = zero 10 continue if (isw(2) .ge. 1) then isw(2) = 1 dcovar = max(dcovar,half) endif return end cdeck id>, mnsave. subroutine mnsave c ************ double precision version ************* implicit double precision (a-h,o-z) cc writes current parameter values and step sizes onto file isyssa cc in format which can be reread by minuit for restarting. cc the covariance matrix is also output if it exists. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension vc(7) logical lopen,lname character cgname*64, cfname*64, canswr*1 c inquire(unit=isyssa,opened=lopen,named=lname,name=cgname) if (lopen) then if (.not.lname) cgname='unnamed file' write (isyswr,32) isyssa,cgname 32 format (' current values will be saved on unit',i3,': ',a/) else c new file, open it write (isyswr,35) isyssa 35 format (' unit',i3,' is not opened.') if (isw(6) .eq. 1) then write (isyswr,'(a)') ' please give file name:' read (isysrd,'(a)') cfname open (unit=isyssa,file=cfname,status='new',err=600) cgname = cfname else go to 650 endif endif c file is now correctly opened if (isw(6) .eq. 1) then write (isyswr,37) isyssa 37 format (' should unit',i3,' be rewound before writing to it?' ) read (isysrd,'(a)') canswr if (canswr.eq.'y' .or. canswr.eq.'y') rewind isyssa endif c and rewound if requested write (isyssa,'(10hset title )',err=700) write (isyssa,'(a)') ctitl write (isyssa,'(10hparameters)') nlines = 3 c write out parameter values do 200 i= 1, nu if (nvarl(i) .lt. 0) go to 200 nlines = nlines + 1 iint = niofex(i) if (nvarl(i) .gt. 1) go to 100 c parameter without limits write (isyssa,1001) i,cpnam(i),u(i),werr(iint) go to 200 c parameter with limits 100 continue write (isyssa,1001) i,cpnam(i),u(i),werr(iint),alim(i),blim(i) 1001 format (1x,i5,1h',a10,1h',4e13.5) 200 continue write (isyssa,'(a)') ' ' nlines = nlines + 1 c write out covariance matrix, if any if (isw(2) .lt. 1) go to 750 write (isyssa,1003,err=700) npar 1003 format ('set covariance',i6) npar2 = npar*(npar+1)/2 write (isyssa,1004) (vhmat(i),i=1,npar2) 1004 format (bn,7e11.4,3x) ncovar = npar2/7 + 1 if (mod(npar2,7) .gt. 0) ncovar = ncovar + 1 nlines = nlines + ncovar write (isyswr, 501) nlines,isyssa,cgname(1:45) 501 format (1x,i5,' records written to unit',i4,':',a) if (ncovar .gt. 0) write (isyswr, 502) ncovar 502 format (' including',i5,' records for the covariance matrix.'/) go to 900 c some error conditions 600 write (isyswr,'(a,i4)') ' i/o error: unable to open unit',isyssa go to 900 650 write (isyswr,'(a,i4,a)') ' unit',isyssa,' is not opened.' go to 900 700 write (isyswr,'(a,i4)') ' error: unable to write to unit',isyssa go to 900 750 write (isyswr,'(a)') ' there is no covariance matrix to save.' c 900 return end cdeck id>, mnscan. subroutine mnscan(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc scans the values of fcn as a function of one parameter cc and plots the resulting values as a curve using mnplot. cc it may be called to scan one parameter or all parameters. cc retains the best function and parameter values found. parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil xlreq = min(word7(3),word7(4)) xhreq = max(word7(3),word7(4)) ncall = word7(2) + 0.01 if (ncall .le. 1) ncall = 41 if (ncall .gt. maxcpt) ncall = maxcpt nccall = ncall if (amin .eq. undefi) call mnamin(fcn,futil) iparwd = word7(1) + 0.1 ipar = max(iparwd, 0) iint = niofex(ipar) cstatu = 'no change' if (iparwd .gt. 0) go to 200 c c equivalent to a loop over parameters requested 100 ipar = ipar + 1 if (ipar .gt. nu) go to 900 iint = niofex(ipar) if (iint .le. 0) go to 100 c set up range for parameter ipar 200 continue ubest = u(ipar) xpt(1) = ubest ypt(1) = amin chpt(1)= ' ' xpt(2) = ubest ypt(2) = amin chpt(2)= 'x' nxypt = 2 if (nvarl(ipar) .gt. 1) go to 300 c no limits on parameter if (xlreq .eq. xhreq) go to 250 unext = xlreq step = (xhreq-xlreq)/float(ncall-1) go to 500 250 continue xl = ubest - werr(iint) xh = ubest+ werr(iint) call mnbins(xl,xh,ncall, unext,uhigh,nbins,step) nccall = nbins + 1 go to 500 c limits on parameter 300 continue if (xlreq .eq. xhreq) go to 350 xl = max(xlreq,alim(ipar)) xh = min(xhreq,blim(ipar)) if (xl .ge. xh) go to 700 unext = xl step = (xh-xl)/float(ncall-1) go to 500 350 continue unext = alim(ipar) step = (blim(ipar)-alim(ipar))/float(ncall-1) c main scanning loop over parameter ipar 500 continue do 600 icall = 1, nccall u(ipar) = unext nparx = npar call fcn(nparx,gin,fnext,u,4,futil) nfcn = nfcn + 1 nxypt = nxypt + 1 xpt(nxypt) = unext ypt(nxypt) = fnext chpt(nxypt) = '*' if (fnext .lt. amin) then amin = fnext ubest = unext cstatu= 'improved ' endif 530 continue unext = unext + step 600 continue c finished with scan of parameter ipar u(ipar) = ubest call mnexin(x) write (isyswr,1001) newpag,ipar,cpnam(ipar) nunit = isyswr call mnplot(xpt,ypt,chpt,nxypt,nunit,npagwd,npagln) go to 800 700 continue write (isyswr,1000) ipar 800 continue if (iparwd .le. 0) go to 100 c finished with all parameters 900 continue call mnprin(5,amin) return 1000 format (46h requested range outside limits for parameter ,i3/) 1001 format (i1,'scan of parameter no.',i3,3h, ,a10) end cdeck id>, mnseek. subroutine mnseek(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a rough (but global) minimization by monte carlo search. cc each time a new minimum is found, the search area is shifted cc to be centered at the best value. random points are chosen cc uniformly over a hypercube determined by current step sizes. cc the metropolis algorithm accepts a worse point with probability cc exp(-d/up), where d is the degradation. improved points cc are of course always accepted. actual steps are random cc multiples of the nominal steps (dirin). cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil parameter (twopi=2.0*3.141593) dimension step(mni), xbest(mni), xmid(mni) mxfail = word7(1) if (mxfail .le. 0) mxfail=100+20*npar mxstep = 10*mxfail if (amin .eq. undefi) call mnamin(fcn,futil) alpha = word7(2) if (alpha .le. zero) alpha=3. if (isw(5) .ge. 1) write (isyswr, 3) mxfail,mxstep,alpha 3 format (' mnseek: monte carlo minimization using metropolis', + ' algorithm'/' to stop after',i6,' successive failures, or', + i7,' steps'/' maximum step size is',f9.3,' error bars.') cstatu= 'initial ' if (isw(5) .ge. 2) call mnprin(2,amin) cstatu = 'unchanged ' ifail = 0 rnum = zero rnum1 = zero rnum2 = zero nparx = npar flast = amin c set up step sizes, starting values do 10 ipar = 1, npar iext = nexofi(ipar) dirin(ipar) = 2.0*alpha*werr(ipar) if (nvarl(iext) .gt. 1) then c parameter with limits call mndxdi(x(ipar),ipar,dxdi) if (dxdi .eq. zero) dxdi=1. dirin(ipar) = 2.0*alpha*werr(ipar)/dxdi if (abs(dirin(ipar)).gt.twopi) dirin(ipar)=twopi endif xmid(ipar) = x(ipar) 10 xbest(ipar) = x(ipar) c search loop do 500 istep= 1, mxstep if (ifail .ge. mxfail) go to 600 do 100 ipar= 1, npar call mnrn15(rnum1,iseed) call mnrn15(rnum2,iseed) 100 x(ipar) = xmid(ipar) + 0.5*(rnum1+rnum2-1.)*dirin(ipar) call mninex(x) call fcn(nparx,gin,ftry,u,4,futil) nfcn = nfcn + 1 if (ftry .lt. flast) then if (ftry .lt. amin) then cstatu = 'improvemnt' amin = ftry do 200 ib= 1, npar 200 xbest(ib) = x(ib) ifail = 0 if (isw(5) .ge. 2) call mnprin(2,amin) endif go to 300 else ifail = ifail + 1 c metropolis algorithm bar = exp((amin-ftry)/up) call mnrn15(rnum,iseed) if (bar .lt. rnum) go to 500 endif c accept new point, move there 300 continue do 350 j= 1, npar xmid(j) = x(j) 350 continue flast = ftry 500 continue c end search loop 600 continue if (isw(5) .gt. 1) write (isyswr,601) ifail 601 format(' mnseek:',i5,' successive unsuccessful trials.') do 700 ib= 1, npar 700 x(ib) = xbest(ib) call mninex(x) if (isw(5) .ge. 1) call mnprin(2,amin) if (isw(5) .eq. 0) call mnprin(0,amin) return end cdeck id>, mnset. subroutine mnset(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnexcm cc interprets the commands that start with set and show cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c external fcn,futil c file characteristics for set input logical lopen,lname character*1 canswr character cfname*64, cmode*16 c 'set ' or 'show', 'on ' or 'off', 'suppressed' or 'reported ' character ckind*4, copt*3, cwarn*10 c explanation of print level numbers -1:3 and strategies 0:2 character cprlev(-1:3)*34 ,cstrat(0:2)*44 c identification of debug options parameter (numdbg = 6) character*40 cdbopt(0:numdbg) c things that can be set or shown character*10 cname(30) data cname( 1)/'fcn value '/ data cname( 2)/'parameters'/ data cname( 3)/'limits '/ data cname( 4)/'covariance'/ data cname( 5)/'correlatio'/ data cname( 6)/'print levl'/ data cname( 7)/'nogradient'/ data cname( 8)/'gradient '/ data cname( 9)/'error def '/ data cname(10)/'input file'/ data cname(11)/'width page'/ data cname(12)/'lines page'/ data cname(13)/'nowarnings'/ data cname(14)/'warnings '/ data cname(15)/'random gen'/ data cname(16)/'title '/ data cname(17)/'strategy '/ data cname(18)/'eigenvalue'/ data cname(19)/'page throw'/ data cname(20)/'minos errs'/ data cname(21)/'epsmachine'/ data cname(22)/'outputfile'/ data cname(23)/'batch '/ data cname(24)/'interactiv'/ data nname/24/ c options not intended for normal users data cname(25)/'reserve '/ data cname(26)/'reserve '/ data cname(27)/'nodebug '/ data cname(28)/'debug '/ data cname(29)/'show '/ data cname(30)/'set '/ data nntot/30/ c data cprlev(-1)/'-1: no output except from "show" '/ data cprlev( 0)/' 0: reduced output '/ data cprlev( 1)/' 1: normal output '/ data cprlev( 2)/' 2: extra output for problem cases'/ data cprlev( 3)/' 3: maximum output '/ c data cstrat( 0)/' 0: minimize the number of calls to function'/ data cstrat( 1)/' 1: try to balance speed against reliability'/ data cstrat( 2)/' 2: make sure minimum true, errors correct '/ c data cdbopt(0)/'report all exceptional conditions '/ data cdbopt(1)/'mnline: line search minimization '/ data cdbopt(2)/'mnderi: first derivative calculations '/ data cdbopt(3)/'mnhess: second derivative calculations '/ data cdbopt(4)/'mnmigr: covariance matrix updates '/ data cdbopt(5)/'mnhes1: first derivative uncertainties '/ data cdbopt(6)/'mncont: mncontour plot (mncros search) '/ c c do 2 i= 1, nntot if (index(cword(4:10),cname(i)(1:3)) .gt. 0) go to 5 2 continue i = 0 5 kname = i c c command could be set xxx, show xxx, help set or help show if (index(cword(1:4),'hel') .gt. 0) go to 2000 if (index(cword(1:4),'sho') .gt. 0) go to 1000 if (index(cword(1:4),'set') .eq. 0) go to 1900 c --- ckind = 'set ' c . . . . . . . . . . set unknown if (kname .le. 0) go to 1900 c . . . . . . . . . . set known go to(3000, 20, 30, 40,3000, 60, 70, 80, 90, 100, + 110, 120, 130, 140, 150, 160, 170,3000, 190,3000, + 210, 220, 230, 240,1900,1900, 270, 280, 290, 300) , kname c c . . . . . . . . . . set param 20 continue iprm = word7(1) if (iprm .gt. nu) go to 25 if (iprm .le. 0) go to 25 if (nvarl(iprm) .lt. 0) go to 25 u(iprm) = word7(2) call mnexin(x) isw2 = isw(2) call mnrset(1) c keep approximate covariance matrix, even if new param value isw(2) = min(isw2,1) cfrom = 'set parm' nfcnfr = nfcn cstatu = 'new values' go to 4000 25 write (isyswr,'(a/)') ' undefined parameter number. ignored.' go to 4000 c . . . . . . . . . . set limits 30 call mnlims(fcn,futil) go to 4000 c . . . . . . . . . . set covar 40 continue c this command must be handled by mnread, and is not fortran-callable go to 3000 c . . . . . . . . . . set print 60 isw(5) = word7(1) go to 4000 c . . . . . . . . . . set nograd 70 isw(3) = 0 go to 4000 c . . . . . . . . . . set grad 80 call mngrad(fcn,futil) go to 4000 c . . . . . . . . . . set errdef 90 if (word7(1) .eq. up) go to 4000 if (word7(1) .le. zero) then if (up .eq. updflt) go to 4000 up = updflt else up = word7(1) endif do 95 i= 1, npar ern(i) = 0. 95 erp(i) = 0. call mnwerr go to 4000 c . . . . . . . . . . set input c this command must be handled by mnread. if it gets this far, c it is illegal. 100 continue go to 3000 c . . . . . . . . . . set width 110 npagwd = word7(1) npagwd = max(npagwd,50) go to 4000 c . . . . . . . . . . set lines 120 npagln = word7(1) go to 4000 c . . . . . . . . . . set nowarn 130 lwarn = .false. go to 4000 c . . . . . . . . . . set warn 140 lwarn = .true. call mnwarn('w','sho','sho') go to 4000 c . . . . . . . . . . set random 150 jseed = int(word7(1)) val = 3. call mnrn15(val, jseed) if (isw(5) .gt. 0) write (isyswr, 151) jseed 151 format (' minuit random number seed set to ',i10) go to 4000 c . . . . . . . . . . set title 160 continue c this command must be handled by mnread, and is not fortran-callable go to 3000 c . . . . . . . . . set strategy 170 istrat = word7(1) istrat = max(istrat,0) istrat = min(istrat,2) if (isw(5) .gt. 0) go to 1172 go to 4000 c . . . . . . . . . set page throw 190 newpag = word7(1) go to 1190 c . . . . . . . . . . set epsmac 210 if (word7(1).gt.zero .and. word7(1).lt.0.1) epsmac = word7(1) epsma2 = dsqrt(epsmac) go to 1210 c . . . . . . . . . . set outputfile 220 continue iunit = word7(1) isyswr = iunit istkwr(1) = iunit if (isw(5) .ge. 0) go to 1220 go to 4000 c . . . . . . . . . . set batch 230 isw(6) = 0 if (isw(5) .ge. 0) go to 1100 go to 4000 c . . . . . . . . . . set interactive 240 isw(6) = 1 if (isw(5) .ge. 0) go to 1100 go to 4000 c . . . . . . . . . . set nodebug 270 iset = 0 go to 281 c . . . . . . . . . . set debug 280 iset = 1 281 continue idbopt = word7(1) if (idbopt .gt. numdbg) go to 288 if (idbopt .ge. 0) then idbg(idbopt) = iset if (iset .eq. 1) idbg(0) = 1 else c set debug -1 sets all debug options do 285 id= 0, numdbg 285 idbg(id) = iset endif lrepor = (idbg(0) .ge. 1) call mnwarn('d','sho','sho') go to 4000 288 write (isyswr,289) idbopt 289 format (' unknown debug option',i6,' requested. ignored') go to 4000 c . . . . . . . . . . set show 290 continue c . . . . . . . . . . set set 300 continue go to 3000 c ----------------------------------------------------- 1000 continue c at this point, cword must be 'show' ckind = 'show' if (kname .le. 0) go to 1900 go to (1010,1020,1030,1040,1050,1060,1070,1070,1090,1100, + 1110,1120,1130,1130,1150,1160,1170,1180,1190,1200, + 1210,1220,1100,1100,1900,1900,1270,1270,1290,1300),kname c c . . . . . . . . . . show fcn 1010 continue if (amin .eq. undefi) call mnamin(fcn,futil) call mnprin (0,amin) go to 4000 c . . . . . . . . . . show param 1020 continue if (amin .eq. undefi) call mnamin(fcn,futil) call mnprin (5,amin) go to 4000 c . . . . . . . . . . show limits 1030 continue if (amin .eq. undefi) call mnamin(fcn,futil) call mnprin (1,amin) go to 4000 c . . . . . . . . . . show covar 1040 call mnmatu(1) go to 4000 c . . . . . . . . . . show corre 1050 call mnmatu(0) go to 4000 c . . . . . . . . . . show print 1060 continue if (isw(5) .lt.-1) isw(5) = -1 if (isw(5) .gt. 3) isw(5) = 3 write (isyswr,'(a)') ' allowed print levels are:' write (isyswr,'(27x,a)') cprlev write (isyswr,1061) cprlev(isw(5)) 1061 format (/' current printout level is ',a) go to 4000 c . . . . . . . show nograd, grad 1070 continue if (isw(3) .le. 0) then write (isyswr, 1081) 1081 format(' nograd is set. derivatives not computed in fcn.') else write (isyswr, 1082) 1082 format(' grad is set. user computes derivatives in fcn.') endif go to 4000 c . . . . . . . . . . show errdef 1090 write (isyswr, 1091) up 1091 format (' errors correspond to function change of',g13.5) go to 4000 c . . . . . . . . . . show input, c batch, or interactive 1100 continue inquire(unit=isysrd,opened=lopen,named=lname,name=cfname) cmode = 'batch mode ' if (isw(6) .eq. 1) cmode = 'interactive mode' if (.not. lname) cfname='unknown' write (isyswr,1002) cmode,isysrd,cfname 1002 format (' input now being read in ',a,' from unit no.',i3/ + ' filename: ',a) go to 4000 c . . . . . . . . . . show width 1110 write (isyswr,1111) npagwd 1111 format (10x,'page width is set to',i4,' columns') go to 4000 c . . . . . . . . . . show lines 1120 write (isyswr,1121) npagln 1121 format (10x,'page length is set to',i4,' lines') go to 4000 c . . . . . . .show nowarn, warn 1130 continue cwarn = 'suppressed' if (lwarn) cwarn = 'reported ' write (isyswr,1141) cwarn 1141 format (' minuit warning messages are ',a) if (.not. lwarn) call mnwarn('w','sho','sho') go to 4000 c . . . . . . . . . . show random 1150 val = 0. call mnrn15(val,igrain) ikseed = igrain write (isyswr, 1151) ikseed 1151 format (' minuit rndm seed is currently=',i10/) val = 3.0 iseed = ikseed call mnrn15(val,iseed) go to 4000 c . . . . . . . . . show title 1160 write (isyswr,'(a,a)') ' title of current task is:',ctitl go to 4000 c . . . . . . . show strategy 1170 write (isyswr, '(a)') ' allowed strategies are:' write (isyswr, '(20x,a)') cstrat 1172 write (isyswr, 1175) cstrat(istrat) 1175 format (/' now using strategy ',a/) go to 4000 c . . . . . show eigenvalues 1180 continue iswsav = isw(5) isw(5) = 3 if (isw(2) .lt. 1) then write (isyswr,'(1x,a)') covmes(0) else call mnpsdf endif isw(5) = iswsav go to 4000 c . . . . . show page throw 1190 write (isyswr,'(a,i3)') ' page throw carriage control =',newpag if (newpag .eq. 0) + write (isyswr,'(a)') ' no page throws in minuit output' go to 4000 c . . . . . . show minos errors 1200 continue do 1202 ii= 1, npar if (erp(ii).gt.zero .or. ern(ii).lt.zero) go to 1204 1202 continue write (isyswr,'(a)') + ' there are no minos errors currently valid.' go to 4000 1204 continue call mnprin(4,amin) go to 4000 c . . . . . . . . . show epsmac 1210 write (isyswr,'(a,e12.3)') + ' floating-point numbers assumed accurate to',epsmac go to 4000 c . . . . . . show outputfiles 1220 continue write (isyswr,'(a,i4)') ' minuit primary output to unit',isyswr go to 4000 c . . . . . . show nodebug, debug 1270 continue do 1285 id= 0, numdbg copt = 'off' if (idbg(id) .ge. 1) copt = 'on ' 1285 write (isyswr,1286) id, copt, cdbopt(id) 1286 format (10x,'debug option',i3,' is ',a3,' :',a) if (.not. lrepor) call mnwarn('d','sho','sho') go to 4000 c . . . . . . . . . . show show 1290 ckind = 'show' go to 2100 c . . . . . . . . . . show set 1300 ckind = 'set ' go to 2100 c ----------------------------------------------------- c unknown command 1900 write (isyswr, 1901) cword 1901 format (' the command:',a10,' is unknown.'/) go to 2100 c ----------------------------------------------------- c help show, help set, show set, or show show 2000 ckind = 'set ' if (index(cword(4:10),'sho') .gt. 0) ckind = 'show' 2100 write (isyswr, 2101) ckind,ckind, (cname(kk),kk=1,nname) 2101 format (' the format of the ',a4,' command is:'// + 1x,a4,' xxx [numerical arguments if any]'// + ' where xxx may be one of the following:'/ + (7x,6a12)) go to 4000 c ----------------------------------------------------- c illegal command 3000 write (isyswr,'('' above command is illegal. ignored'')') 4000 return end cdeck id>, mnseti. subroutine mnseti(tit) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called by user to set or change title of current task. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead character*(*) tit ctitl = tit return end cdeck id>, mnsimp. subroutine mnsimp(fcn,futil) c ************ double precision version ************* implicit double precision (a-h,o-z) cc performs a minimization using the simplex method of nelder cc and mead (ref. -- comp. j. 7,308 (1965)). cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead external fcn,futil dimension y(mni+1) data alpha,beta,gamma,rhomin,rhomax / 1.0, 0.5, 2.0, 4.0, 8.0/ if (npar .le. 0) return if (amin .eq. undefi) call mnamin(fcn,futil) cfrom = 'simplex ' nfcnfr = nfcn cstatu= 'unchanged ' npfn=nfcn nparp1=npar+1 nparx = npar rho1 = 1.0 + alpha rho2 = rho1 + alpha*gamma wg = 1.0/float(npar) if (isw(5) .ge. 0) write(isyswr,100) epsi 100 format(' start simplex minimization. convergence when edm .lt.' +,e10.2 ) do 2 i= 1, npar dirin(i) = werr(i) call mndxdi(x(i),i,dxdi) if (dxdi .ne. zero) dirin(i)=werr(i)/dxdi dmin = epsma2*abs(x(i)) if (dirin(i) .lt. dmin) dirin(i)=dmin 2 continue c** choose the initial simplex using single-parameter searches 1 continue ynpp1 = amin jl = nparp1 y(nparp1) = amin absmin = amin do 10 i= 1, npar aming = amin pbar(i) = x(i) bestx = x(i) kg = 0 ns = 0 nf = 0 4 x(i) = bestx + dirin(i) call mninex(x) call fcn(nparx,gin, f, u, 4, futil) nfcn = nfcn + 1 if (f .le. aming) go to 6 c failure if (kg .eq. 1) go to 8 kg = -1 nf = nf + 1 dirin(i) = dirin(i) * (-0.4) if (nf .lt. 3) go to 4 ns = 6 c success 6 bestx = x(i) dirin(i) = dirin(i) * 3.0 aming = f cstatu= 'progress ' kg = 1 ns = ns + 1 if (ns .lt. 6) go to 4 c local minimum found in ith direction 8 y(i) = aming if (aming .lt. absmin) jl = i if (aming .lt. absmin) absmin = aming x(i) = bestx do 9 k= 1, npar 9 p(k,i) = x(k) 10 continue jh = nparp1 amin=y(jl) call mnrazz(ynpp1,pbar,y,jh,jl) do 20 i= 1, npar 20 x(i) = p(i,jl) call mninex(x) cstatu = 'progress ' if (isw(5) .ge. 1) call mnprin(5,amin) edm = bigedm sig2 = edm ncycl=0 c . . . . . start main loop 50 continue if (sig2 .lt. epsi .and. edm.lt.epsi) go to 76 sig2 = edm if ((nfcn-npfn) .gt. nfcnmx) go to 78 c calculate new point * by reflection do 60 i= 1, npar pb = 0. do 59 j= 1, nparp1 59 pb = pb + wg * p(i,j) pbar(i) = pb - wg * p(i,jh) 60 pstar(i)=(1.+alpha)*pbar(i)-alpha*p(i,jh) call mninex(pstar) call fcn(nparx,gin,ystar,u,4,futil) nfcn=nfcn+1 if(ystar.ge.amin) go to 70 c point * better than jl, calculate new point ** do 61 i=1,npar 61 pstst(i)=gamma*pstar(i)+(1.-gamma)*pbar(i) call mninex(pstst) call fcn(nparx,gin,ystst,u,4,futil) nfcn=nfcn+1 c try a parabola through ph, pstar, pstst. min = prho y1 = (ystar-y(jh)) * rho2 y2 = (ystst-y(jh)) * rho1 rho = 0.5 * (rho2*y1 -rho1*y2) / (y1 -y2) if (rho .lt. rhomin) go to 66 if (rho .gt. rhomax) rho = rhomax do 64 i= 1, npar 64 prho(i) = rho*pbar(i) + (1.0-rho)*p(i,jh) call mninex(prho) call fcn(nparx,gin,yrho, u,4,futil) nfcn = nfcn + 1 if (yrho .lt. y(jl) .and. yrho .lt. ystst) go to 65 if (ystst .lt. y(jl)) go to 67 if (yrho .gt. y(jl)) go to 66 c accept minimum point of parabola, prho 65 call mnrazz (yrho,prho,y,jh,jl) go to 68 66 if (ystst .lt. y(jl)) go to 67 call mnrazz(ystar,pstar,y,jh,jl) go to 68 67 call mnrazz(ystst,pstst,y,jh,jl) 68 ncycl=ncycl+1 if (isw(5) .lt. 2) go to 50 if (isw(5) .ge. 3 .or. mod(ncycl, 10) .eq. 0) call mnprin(5,amin) go to 50 c point * is not as good as jl 70 if (ystar .ge. y(jh)) go to 73 jhold = jh call mnrazz(ystar,pstar,y,jh,jl) if (jhold .ne. jh) go to 50 c calculate new point ** 73 do 74 i=1,npar 74 pstst(i)=beta*p(i,jh)+(1.-beta)*pbar(i) call mninex (pstst) call fcn(nparx,gin,ystst,u,4,futil) nfcn=nfcn+1 if(ystst.gt.y(jh)) go to 1 c point ** is better than jh if (ystst .lt. amin) go to 67 call mnrazz(ystst,pstst,y,jh,jl) go to 50 c . . . . . . end main loop 76 if (isw(5) .ge. 0) write(isyswr,'(a)') + ' simplex minimization has converged.' isw(4) = 1 go to 80 78 if (isw(5) .ge. 0) write(isyswr,'(a)') + ' simplex terminates without convergence.' cstatu= 'call limit' isw(4) = -1 isw(1) = 1 80 do 82 i=1,npar pb = 0. do 81 j=1,nparp1 81 pb = pb + wg * p(i,j) 82 pbar(i) = pb - wg * p(i,jh) call mninex(pbar) call fcn(nparx,gin,ypbar,u,4,futil) nfcn=nfcn+1 if (ypbar .lt. amin) call mnrazz(ypbar,pbar,y,jh,jl) call mninex(x) if (nfcnmx+npfn-nfcn .lt. 3*npar) go to 90 if (edm .gt. 2.0*epsi) go to 1 90 if (isw(5) .ge. 0) call mnprin(5, amin) return end cdeck id>, mnstat. subroutine mnstat(fmin,fedm,errdef,npari,nparx,istat) c ************ double precision version ************* implicit double precision (a-h,o-z) cc user-called cc provides the user with information concerning the current status cc of the current minimization. namely, it returns: cc fmin: the best function value found so far cc fedm: the estimated vertical distance remaining to minimum cc errdef: the value of up defining parameter uncertainties cc npari: the number of currently variable parameters cc nparx: the highest (external) parameter number defined by user cc istat: a status integer indicating how good is the covariance cc matrix: 0= not calculated at all cc 1= approximation only, not accurate cc 2= full matrix, but forced positive-definite cc 3= full accurate covariance matrix cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead fmin = amin fedm = edm errdef = up npari = npar nparx = nu istat = isw(2) if (edm .eq. bigedm) then fedm = up endif if (amin .eq. undefi) then fmin = 0.0 fedm = up istat= 0 endif return end cdeck id>, mnstin. subroutine mnstin(crdbuf,ierr) c ************ double precision version ************* implicit double precision (a-h,o-z) cc called from mnread. cc implements the set input command to change input units. cc if command is: 'set input' 'set input 0' or '*eof', cc or 'set input , , ', cc reverts to previous input unit number,if any. cc cc if it is: 'set input n' or 'set input n filename', cc changes to new input file, added to stack cc cc ierr = 0: reading terminated normally cc 2: end-of-data on primary input file cc 3: unrecoverable read error cc 4: unable to process request cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead character crdbuf*(*),cunit*10,cfname*64,cgname*64,canswr*1 character cmode*16 logical lopen,lrewin,noname,lname,mnunpt noname = .true. ierr = 0 if (index(crdbuf,'*eof') .eq. 1) go to 190 if (index(crdbuf,'*eof') .eq. 1) go to 190 lend = len(crdbuf) c look for end of set input command do 20 ic= 8,lend if (crdbuf(ic:ic) .eq. ' ') go to 25 if (crdbuf(ic:ic) .eq. ',') go to 53 20 continue go to 200 25 continue c look for end of separator between command and first argument icol = ic+1 do 50 ic= icol,lend if (crdbuf(ic:ic) .eq. ' ') go to 50 if (crdbuf(ic:ic) .eq. ',') go to 53 go to 55 50 continue go to 200 53 ic = ic + 1 55 ic1 = ic c see if "rewind" was requested in command lrewin = .false. if (index(crdbuf(1:ic1),'rew') .gt. 5) lrewin=.true. if (index(crdbuf(1:ic1),'rew') .gt. 5) lrewin=.true. c first argument begins in or after col ic1 do 75 ic= ic1,lend if (crdbuf(ic:ic) .eq. ' ') go to 75 if (crdbuf(ic:ic) .eq. ',') go to 200 go to 80 75 continue go to 200 80 ic1 = ic c first argument really begins in col ic1 do 100 ic= ic1+1,lend if (crdbuf(ic:ic) .eq. ' ') go to 108 if (crdbuf(ic:ic) .eq. ',') go to 108 100 continue ic = lend + 1 108 ic2 = ic-1 c end of first argument is in col ic2 110 continue cunit = crdbuf(ic1:ic2) write (isyswr,'(a,a)') ' unit no. :',cunit read (cunit,'(bn,f10.0)',err=500) funit iunit = funit if (iunit .eq. 0) go to 200 c skip blanks and commas, find file name do 120 ic= ic2+1,lend if (crdbuf(ic:ic) .eq. ' ') go to 120 if (crdbuf(ic:ic) .eq. ',') go to 120 go to 130 120 continue go to 131 130 continue cfname = crdbuf(ic:lend) noname = .false. write (isyswr, '(a,a)') ' file name is:',cfname c ask if file exists, if not ask for name and open it 131 continue inquire(unit=iunit,opened=lopen,named=lname,name=cgname) if (lopen) then if (noname) then go to 136 else if (.not.lname) cgname='unknown' write (isyswr,132) iunit,cgname,cfname 132 format (' unit',i3,' already opened with name:',a/ + ' new name ignored:',a) endif else c new file, open it write (isyswr,135) iunit 135 format (' unit',i3,' is not opened.') if (noname) then write (isyswr,'(a)') ' no file name given in command.' if (isw(6) .ne. 1) go to 800 write (isyswr,'(a)') ' please give file name:' read (isysrd,'(a)') cfname endif open (unit=iunit,file=cfname,status='old',err=600) write (isyswr,'(a)') ' file opened successfully.' endif c . . file is correctly opened 136 if (lrewin) go to 150 if (isw(6) .ne. 1) go to 300 write (isyswr,137) iunit 137 format (' should unit',i3,' be rewound?' ) read (isysrd,'(a)') canswr if (canswr.ne.'y' .and. canswr.ne.'y') go to 300 150 rewind iunit go to 300 c *eof 190 continue if (nstkrd .eq. 0) then ierr = 2 go to 900 endif c revert to previous input file 200 continue if (nstkrd .eq. 0) then write (isyswr, '(a,a)') ' command ignored:',crdbuf write (isyswr, '(a)') ' already reading from primary input' else isysrd = istkrd(nstkrd) nstkrd = nstkrd - 1 if (nstkrd .eq. 0) isw(6) = iabs(isw(6)) if (isw(5) .ge. 0) then inquire(unit=isysrd,named=lname,name=cfname) cmode = 'batch mode ' if (isw(6) .eq. 1) cmode = 'interactive mode' if (.not.lname) cfname='unknown' if (mnunpt(cfname)) cfname='unprintable' write (isyswr,290) cmode,isysrd,cfname 290 format (' input will now be read in ',a,' from unit no.',i3/ + ' filename: ',a) endif endif go to 900 c switch to new input file, add to stack 300 continue if (nstkrd .ge. maxstk) then write (isyswr, '(a)') ' input file stack size exceeded.' go to 800 endif nstkrd = nstkrd + 1 istkrd(nstkrd) = isysrd isysrd = iunit c isw(6) = 0 for batch, =1 for interactive, and c =-1 for originally interactive temporarily batch if (isw(6) .eq. 1) isw(6) = -1 go to 900 c format error 500 continue write (isyswr,'(a,a)') ' cannot read following as integer:',cunit go to 800 600 continue write (isyswr, 601) cfname 601 format (' system is unable to open file:',a) c serious error 800 continue ierr = 3 900 continue return end cdeck id>, mntiny. subroutine mntiny(epsp1,epsbak) c ************ double precision version ************* implicit double precision (a-h,o-z) cc compares its argument with the value 1.0, and returns cc the value .true. if they are equal. to find epsmac cc safely by foiling the fortran optimizer cc parameter (one=1.0) epsbak = epsp1 - one return end cdeck id>, mnunpt. logical function mnunpt(cfname) c is .true. if cfname contains unprintable characters. character cfname*(*) character cpt*80, cp1*40,cp2*40 parameter (cp1=' abcdefghijklmnopqrstuvwxyzabcdefghijklm') parameter (cp2='nopqrstuvwxyz1234567890./;:[]$%*_!@#&+()') cpt=cp1//cp2 mnunpt = .false. l = len(cfname) do 100 i= 1, l do 50 ic= 1, 80 if (cfname(i:i) .eq. cpt(ic:ic)) go to 100 50 continue mnunpt = .true. go to 150 100 continue 150 continue return end cdeck id>, mnvert. subroutine mnvert(a,l,m,n,ifail) c ************ double precision version ************* implicit double precision (a-h,o-z) cc inverts a symmetric matrix. matrix is first scaled to cc have all ones on the diagonal (equivalent to change of units) cc but no pivoting is done since matrix is positive-definite. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead dimension a(l,m) ,pp(mni), q(mni), s(mni) ifail=0 if (n .lt. 1) go to 100 if (n .gt. maxint) go to 100 c scale matrix by dsqrt of diag elements do 8 i=1,n si = a(i,i) if (si) 100,100,8 8 s(i) = 1.0/dsqrt(si) do 20 i= 1, n do 20 j= 1, n 20 a(i,j) = a(i,j) *s(i)*s(j) c . . . start main loop . . . . do 65 i=1,n k = i c preparation for elimination step1 q(k)=1./a(k,k) pp(k) = 1.0 a(k,k)=0.0 kp1=k+1 km1=k-1 if(km1)100,50,40 40 do 49 j=1,km1 pp(j)=a(j,k) q(j)=a(j,k)*q(k) 49 a(j,k)=0. 50 if(k-n)51,60,100 51 do 59 j=kp1,n pp(j)=a(k,j) q(j)=-a(k,j)*q(k) 59 a(k,j)=0.0 c elimination proper 60 do 65 j=1,n do 65 k=j,n 65 a(j,k)=a(j,k)+pp(j)*q(k) c elements of left diagonal and unscaling do 70 j= 1, n do 70 k= 1, j a(k,j) = a(k,j) *s(k)*s(j) 70 a(j,k) = a(k,j) return c failure return 100 ifail=1 return end cdeck id>, mnwarn. subroutine mnwarn(copt,corg,cmes) c if copt='w', cmes is a warning message from corg. c if copt='d', cmes is a debug message from corg. c if set warnings is in effect (the default), this routine c prints the warning message cmes coming from corg. c if set nowarnings is in effect, the warning message is c stored in a circular buffer of length maxmes. c if called with corg=cmes='sho', it prints the messages in c the circular buffer, fifo, and empties the buffer. c ************ double precision version ************* implicit double precision (a-h,o-z) parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead character copt*1, corg*(*), cmes*(*), ctyp*7 parameter (maxmes=10) character origin(maxmes,2)*10, warmes(maxmes,2)*60 common/mn7wrc/origin, warmes common/mn7wri/nfcwar(maxmes,2),icirc(2) character englsh*20 c if (corg(1:3).eq.'sho' .and. cmes(1:3).eq.'sho') go to 200 c either print warning or put in buffer if (copt .eq. 'w') then ityp = 1 if (lwarn) then write (isyswr,'(a,a/a,a)') ' minuit warning in ',corg, + ' ============== ',cmes return endif else ityp = 2 if (lrepor) then write (isyswr,'(a,a/a,a)') ' minuit debug for ',corg, + ' ============== ',cmes return endif endif c if appropriate flag is off, fill circular buffer if (nwrmes(ityp) .eq. 0) icirc(ityp) = 0 nwrmes(ityp) = nwrmes(ityp) + 1 icirc(ityp) = icirc(ityp) + 1 if (icirc(ityp) .gt. maxmes) icirc(ityp) = 1 ic = icirc(ityp) origin(ic,ityp) = corg warmes(ic,ityp) = cmes nfcwar(ic,ityp) = nfcn return c c 'sho warnings', ask if any suppressed mess in buffer 200 continue if (copt .eq. 'w') then ityp = 1 ctyp = 'warning' else ityp = 2 ctyp = '*debug*' endif if (nwrmes(ityp) .gt. 0) then englsh = ' was suppressed. ' if (nwrmes(ityp) .gt. 1) englsh = 's were suppressed.' write (isyswr,'(/1x,i5,a,a,a,a/)') nwrmes(ityp), + ' minuit ',ctyp,' message', englsh nm = nwrmes(ityp) ic = 0 if (nm .gt. maxmes) then write (isyswr,'(a,i2,a)') ' only the most recent ', + maxmes,' will be listed below.' nm = maxmes ic = icirc(ityp) endif write (isyswr,'(a)') ' calls origin message' do 300 i= 1, nm ic = ic + 1 if (ic .gt. maxmes) ic = 1 write (isyswr,'(1x,i6,1x,a,1x,a)') + nfcwar(ic,ityp),origin(ic,ityp),warmes(ic,ityp) 300 continue nwrmes(ityp) = 0 write (isyswr,'(1h )') endif return end cdeck id>, mnwerr. subroutine mnwerr c ************ double precision version ************* implicit double precision (a-h,o-z) cc calculates the werr, external parameter errors, cc and the global correlation coefficients, to be called cc whenever a new covariance matrix is available. cc parameter (mne=100 , mni=50) parameter (mnihl=mni*(mni+1)/2) character*10 cpnam common 1/mn7nam/ cpnam(mne) 2/mn7ext/ u(mne) ,alim(mne) ,blim(mne) 3/mn7err/ erp(mni) ,ern(mni) ,werr(mni) ,globcc(mni) 4/mn7inx/ nvarl(mne) ,niofex(mne),nexofi(mni) 5/mn7int/ x(mni) ,xt(mni) ,dirin(mni) 6/mn7fx2/ xs(mni) ,xts(mni) ,dirins(mni) 7/mn7der/ grd(mni) ,g2(mni) ,gstep(mni) ,gin(mne) ,dgrd(mni) 8/mn7fx3/ grds(mni) ,g2s(mni) ,gsteps(mni) 9/mn7fx1/ ipfix(mni) ,npfix a/mn7var/ vhmat(mnihl) b/mn7vat/ vthmat(mnihl) c/mn7sim/ p(mni,mni+1),pstar(mni),pstst(mni) ,pbar(mni),prho(mni) c parameter (maxdbg=10, maxstk=10, maxcwd=20, maxp=30, maxcpt=101) parameter (zero=0.0, one=1.0, half=0.5) common d/mn7npr/ maxint ,npar ,maxext ,nu e/mn7iou/ isysrd ,isyswr ,isyssa ,npagwd ,npagln ,newpag e/mn7io2/ istkrd(maxstk) ,nstkrd ,istkwr(maxstk) ,nstkwr f/mn7tit/ cfrom ,cstatu ,ctitl ,cword ,cundef ,cvrsn ,covmes g/mn7flg/ isw(7) ,idbg(0:maxdbg) ,nblock ,icomnd h/mn7min/ amin ,up ,edm ,fval3 ,epsi ,apsi ,dcovar i/mn7cnv/ nfcn ,nfcnmx ,nfcnlc ,nfcnfr ,itaur,istrat,nwrmes(2) j/mn7arg/ word7(maxp) k/mn7log/ lwarn ,lrepor ,limset ,lnolim ,lnewmn ,lphead l/mn7cns/ epsmac ,epsma2 ,vlimlo ,vlimhi ,undefi ,bigedm,updflt m/mn7rpt/ xpt(maxcpt) ,ypt(maxcpt) n/mn7cpt/ chpt(maxcpt) o/mn7xcr/ xmidcr ,ymidcr ,xdircr ,ydircr ,ke1cr ,ke2cr character ctitl*50, cword*(maxcwd), cundef*10, cfrom*8, + cvrsn*6, covmes(0:3)*22, cstatu*10, chpt*1 logical lwarn, lrepor, limset, lnolim, lnewmn, lphead c calculate external error if v exists if (isw(2) .ge. 1) then do 100 l= 1, npar ndex = l*(l+1)/2 dx = dsqrt(abs(vhmat(ndex)*up)) i = nexofi(l) if (nvarl(i) .gt. 1) then al = alim(i) ba = blim(i) - al du1 = al + 0.5 *(dsin(x(l)+dx) +1.0) * ba - u(i) du2 = al + 0.5 *(dsin(x(l)-dx) +1.0) * ba - u(i) if (dx .gt. 1.0) du1 = ba dx = 0.5 * (abs(du1) + abs(du2)) endif werr(l) = dx 100 continue endif c global correlation coefficients if (isw(2) .ge. 1) then do 130 i= 1, npar globcc(i) = 0. k1 = i*(i-1)/2 do 130 j= 1, i k = k1 + j p(i,j) = vhmat(k) 130 p(j,i) = p(i,j) call mnvert(p,maxint,maxint,npar,ierr) if (ierr .eq. 0) then do 150 iin= 1, npar ndiag = iin*(iin+1)/2 denom = p(iin,iin)*vhmat(ndiag) if (denom.le.one .and. denom.ge.zero) then globcc(iin) = 0. else globcc(iin) = dsqrt(1.0-1.0/denom) endif 150 continue endif endif return end cdeck id>, stand. subroutine stand c ************ double precision version ************* implicit double precision (a-h,o-z) cc optional user-supplied subroutine is called whenever the cc command "standard" appears. cc return end PDL-2.018/Lib/Simplex/0000755060175006010010000000000013110402045012511 5ustar chmNonePDL-2.018/Lib/Simplex/Makefile.PL0000644060175006010010000000035012562522364014502 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile(NAME => "PDL::Opt::Simplex", PM => { map {($_ => '$(INST_LIBDIR)/'.$_)} <*.pm> }, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Lib/Simplex/Simplex.pm0000644060175006010010000001554712562522364014525 0ustar chmNone =head1 NAME PDL::Opt::Simplex -- Simplex optimization routines =head1 SYNOPSIS use PDL::Opt::Simplex; ($optimum,$ssize,$optval) = simplex($init,$initsize,$minsize, $maxiter, sub {evaluate_func_at($_[0])}, sub {display_simplex($_[0])} ); =head1 DESCRIPTION This package implements the commonly used simplex optimization algorithm. The basic idea of the algorithm is to move a "simplex" of N+1 points in the N-dimensional search space according to certain rules. The main benefit of the algorithm is that you do not need to calculate the derivatives of your function. $init is a 1D vector holding the initial values of the N fitted parameters, $optimum is a vector holding the final solution. $optval is the evaluation of the final solution. $initsize is the size of $init (more...) $minsize is some sort of convergence criterion (more...) - e.g. $minsize = 1e-6 The sub is assumed to understand more than 1 dimensions and threading. Its signature is 'inp(nparams); [ret]out()'. An example would be sub evaluate_func_at { my($xv) = @_; my $x1 = $xv->slice("(0)"); my $x2 = $xv->slice("(1)"); return $x1**4 + ($x2-5)**4 + $x1*$x2; } Here $xv is a vector holding the current values of the parameters being fitted which are then sliced out explicitly as $x1 and $x2. $ssize gives a very very approximate estimate of how close we might be - it might be miles wrong. It is the euclidean distance between the best and the worst vertices. If it is not very small, the algorithm has not converged. =head1 FUNCTIONS =head2 simplex =for ref Simplex optimization routine =for usage ($optimum,$ssize,$optval) = simplex($init,$initsize,$minsize, $maxiter, sub {evaluate_func_at($_[0])}, sub {display_simplex($_[0])} ); See module C for more information. =head1 CAVEATS Do not use the simplex method if your function has local minima. It will not work. Use genetic algorithms or simulated annealing or conjugate gradient or momentum gradient descent. They will not really work either but they are not guaranteed not to work ;) (if you have infinite time, simulated annealing is guaranteed to work but only after it has visited every point in your space). =head1 SEE ALSO Ron Shaffer's chemometrics web page and references therein: C. Numerical Recipes (bla bla bla XXX ref). The demonstration (Examples/Simplex/tsimp.pl and tsimp2.pl). =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Opt::Simplex; use PDL; use PDL::Primitive; use strict; use PDL::Exporter; # use AutoLoader; @PDL::Opt::Simplex::ISA = qw/PDL::Exporter/; @PDL::Opt::Simplex::EXPORT_OK = qw/simplex/; %PDL::Opt::Simplex::EXPORT_TAGS = ( Func => [@PDL::Opt::Simplex::EXPORT_OK] ); *simplex = \&PDL::simplex; sub PDL::simplex { my ( $init, $initsize, $minsize, $maxiter, $sub, $logsub, $t ) = @_; if ( !defined $t ) { $t = 0 } my ( $i, $j ); my ( $nd, $nd2 ) = ( dims($init), 1 ); my $simp; if ( $nd2 == 1 ) { $simp = PDL->zeroes( $nd, $nd + 1 ); $simp .= $init; # Constructing a tetrahedron: # At step n (starting from zero) # take vertices 0..n and move them 1/(n+1) to negative dir on axis n. # Take vertex n+1 and move it n/(n+1) to positive dir on axis n if ( !ref $initsize ) { $initsize = PDL->pdl($initsize)->dummy( 0, $nd ); } for ( $i = 0 ; $i < $nd ; $i++ ) { my $pj = $i / ( $i + 1 ); ( my $stoopid = $simp->slice("$i,0:$i") ) -= $initsize->at($i) * $pj; ( my $stoopid1 = $simp->slice( "$i," . ( $i + 1 ) ) ) += $initsize->at($i) * ( 1 - $pj ); } } elsif ( $nd2 == $nd + 1 ) { $simp = $init; } else { return; } my $maxind = PDL->zeroes(2); my $minind = PDL->null; my $ssum = PDL->null; my $worst; my $new; my $vals = &{$sub}($simp); my $ss1 = ( $simp - $simp->slice(":,0") )**2; sumover( $ss1, ( my $ss2 = PDL->null ) ); my $ssize = PDL::max( sqrt($ss2) ); &{$logsub}( $simp, $vals, $ssize ) if $logsub; while ( $maxiter-- and max( PDL->topdl($ssize) ) > $minsize ) { my $valsn = $vals; if ($t) { my $noise = $vals->random(); $noise->random; $valsn = $vals + $t * ( -log( $noise + 0.00001 ) ); } maximum_n_ind( $valsn, $maxind ); minimum_ind( $valsn, $minind ); my @worstvals = map { $valsn->at( $maxind->at($_) ) } 0 .. 1; my $bestval = $valsn->at($minind); sumover( $simp->xchg( 0, 1 ), $ssum ); $ssum -= ( $worst = $simp->slice( ":,(" . $maxind->at(0) . ")" ) ); $ssum /= $nd; $new = 2 * $ssum - $worst; my $val = ( &{$sub}($new) )->at(0); if ($t) { $val = $val - $t * ( -log( rand() + 0.00001 ) ); } my $removetop = 0; if ( $val < $bestval ) { my $newnew = $new + $ssum - $worst; my $val2 = &{$sub}($newnew); if ( $val2->at(0) < $val ) { # print "CASE1 Reflection and Expansion\n"; $worst .= $newnew; $val = $val2; } else { # print "CASE2 Reflection, $newnew, $val, $val2\n"; $worst .= $new; } $removetop = 1; } elsif ( $val < $worstvals[1] ) { # print "CASE3 Reflection\n"; $worst .= $new; $removetop = 1; } else { my $newnew = 0.5 * $ssum + 0.5 * $worst; my $val2 = &{$sub}($newnew); if ( $val2->at(0) < $worstvals[0] ) { # print "CASE4 Contraction, $newnew, $val, $val2\n"; $worst .= $newnew; $val = $val2; $removetop = 1; } } if ($removetop) { ( my $stoopid = $vals->slice( "(" . $maxind->at(0) . ")" ) ) .= $val; } else { # print "CASE5 Multiple Contraction\n"; $simp = 0.5 * $simp->slice(":,$minind") + 0.5 * $simp; my $idx = which( sequence($nd+1) != $minind ); ( my $stoopid = $vals->index($idx) ) .= &{$sub}($simp->dice_axis(1,$idx)); } my $ss1 = ( $simp - $simp->slice(":,0") )**2; sumover( $ss1, ( $ss2 = PDL->null ) ); $ssize = PDL::max( sqrt($ss2) ); &{$logsub}( $simp, $vals, $ssize ) if $logsub; } minimum_ind( $vals, ( my $mmind = PDL->null ) ); return ( $simp->slice(":,$mmind"), $ssize, $vals->index($mmind) ); } 1; PDL-2.018/Lib/Slatec/0000755060175006010010000000000013110402046012304 5ustar chmNonePDL-2.018/Lib/Slatec/Makefile.PL0000644060175006010010000001056613036512175014302 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; use Config; use version; # This mess sorts out the Fortran availability - KGB. # Depends on ExtUtils::F77 my $donot = 0; my $msg = ""; my $forcebuild=0; my ($f77); our ($f2cbased, $g2cbased); if (defined $PDL::Config{WITH_SLATEC} && $PDL::Config{WITH_SLATEC}==0) { $msg = "Will skip build of PDL::Slatec on this system"; goto skip; } if (defined $PDL::Config{WITH_SLATEC} && $PDL::Config{WITH_SLATEC}==1) { print "Will forcibly try and build PDL::Slatec on this system\n"; $forcebuild=1; } if (exists $PDL::Config{F77CONF} && -f $PDL::Config{F77CONF}) { print "Loading F77 configuration from $PDL::Config{F77CONF}...\n"; eval { require $PDL::Config{F77CONF} }; if ($@ ne "") { $msg = "F77CONF file not loaded: $@\nOught not build PDL::Slatec\n"; goto skip unless $forcebuild; } $f77 = 'F77Conf'; } else { eval { require ExtUtils::F77; ExtUtils::F77->import; }; # Might want "ExtUtils::F77->import(qw(generic f2c))" if ($@ ne "") { $msg = "ExtUtils::F77 module not found. Ought not build PDL::Slatec" ; goto skip unless $forcebuild; } else { $f77 = 'ExtUtils::F77'; print "(ExtUtils Version $ExtUtils::F77::VERSION)\n"; if ($ExtUtils::F77::VERSION < 1.03 ) { $msg = "Need a version of ExtUtils::F77 >= 1.03. Ought not build PDL::Slatec" ; goto skip unless $forcebuild; } } # end if ($@ ne "") } # if (exists $PDL::Config{F77CONF}... my $compiler_available = $f77->testcompiler; if (!$compiler_available) { $msg = "No f77 compiler found. Ought to skip PDL::Slatec on this system"; $PDL::Config{WITH_SLATEC} = 0; } else { $PDL::Config{WITH_SLATEC} = 1; } skip: if ($msg ne "" && $forcebuild==0) { write_dummy_make( $msg ); $PDL::Config{WITH_SLATEC} = 0; $donot = 1; } else { print "\n Building PDL::Slatec. Turn off WITH_SLATEC if there are any problems\n\n"; $PDL::Config{WITH_SLATEC} = 1; } return if $donot; my @pack = (["slatec.pd", qw(Slatec PDL::Slatec)]); my @slatecfiles = map {s/^slatec\///; s/\.f$//; $_} glob("slatec/*.f"); my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} .= join '', map {" slatec/${_}$Config{obj_ext} "} @slatecfiles; if($Config{cc} eq 'cl') { # Link to MinGW's libg2c.a and libgcc.a, if appropriate # First check that ExtUtils::F77 is available eval{require ExtUtils::F77}; unless($@) { my @f = (); my $drive = (split /:/, `gcc -v 2>&1`)[0]; $drive = substr($drive, -1, 1); for(split ' ', ExtUtils::F77->runtime) { if($_ =~ /^\-L/) { $_ =~ s#^\-L##; unless($_ =~ /:/) {$_ = $drive . ':' . $_} if(-e $_ . '/libg2c.a') {push @f, $_ . '/libg2c.a'} if(-e $_ . '/libgcc.a') {push @f, $_ . '/libgcc.a'} } } $hash{LDFROM} = $hash{OBJECT}; for(@f) {$hash{LDFROM} .= ' ' . $_} } } $hash{LIBS}[0] .= $f77->runtime ; $hash{clean}{FILES} .= " SlatecProtos.h f77_underscore" . join '', map {" slatec/$_.o "} @slatecfiles; # Handle multiple compilers $f2cbased = ($f77->runtime =~ /-lf2c/); $g2cbased = ($f77->runtime =~ /-lg2c/) unless $f2cbased; my $trail = $f77->trail_; # no longer create the prototypes here - this is now handled # by slatec.pd. In fact, with the current method, we no # longer need the .P files # # Create flag file according to whether or not to use # underscores (pretty hacky) unlink("f77_underscore") if -e "f77_underscore"; if ($trail) { open OUT, ">f77_underscore" or die "unable to write scratch file"; close OUT; } undef &MY::postamble; # suppress warning *MY::postamble = sub { my $mycompiler = $f77->compiler(); my $mycflags = $f77->cflags(); my $orig = pdlpp_postamble_int(@pack); my $hack_64bit = ($Config{archname}=~m/x86_64/ ?" -fPIC " : ""); $orig =~ s/:\s*slatec\.pd/: slatec.pd/; $orig .join "\n",map { (" slatec/$_\$(OBJ_EXT): slatec/$_.f $mycompiler -c $hack_64bit -o slatec/$_\$(OBJ_EXT) $mycflags slatec/$_.f " )} @slatecfiles; }; # Remove i386 option for OS X recent versions for better build, dual arch does not work anyway my %items; if ($Config{osname} =~ /darwin/ && version->parse($Config{osvers}) >= version->parse("14")) { # OS X Mavericks+ print "Forcing single arch build for SLATEC\n"; $items{LDDLFLAGS} = $Config{lddlflags}; $items{LDDLFLAGS} =~ s/-arch i386/ /g; } WriteMakefile( %hash, VERSION => "0.12", # This is overridden by VERSION_FROM in %hash %items ); PDL-2.018/Lib/Slatec/slatec/0000755060175006010010000000000013110402046013557 5ustar chmNonePDL-2.018/Lib/Slatec/slatec/chfcm.f0000644060175006010010000001170712562522364015034 0ustar chmNone*DECK CHFCM INTEGER FUNCTION CHFCM (D1, D2, DELTA) C***BEGIN PROLOGUE CHFCM C***SUBSIDIARY C***PURPOSE Check a single cubic for monotonicity. C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (CHFCM-S, DCHFCM-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C *Usage: C C REAL D1, D2, DELTA C INTEGER ISMON, CHFCM C C ISMON = CHFCM (D1, D2, DELTA) C C *Arguments: C C D1,D2:IN are the derivative values at the ends of an interval. C C DELTA:IN is the data slope over that interval. C C *Function Return Values: C ISMON : indicates the monotonicity of the cubic segment: C ISMON = -3 if function is probably decreasing; C ISMON = -1 if function is strictly decreasing; C ISMON = 0 if function is constant; C ISMON = 1 if function is strictly increasing; C ISMON = 2 if function is non-monotonic; C ISMON = 3 if function is probably increasing. C If ABS(ISMON)=3, the derivative values are too close to the C boundary of the monotonicity region to declare monotonicity C in the presence of roundoff error. C C *Description: C C CHFCM: Cubic Hermite Function -- Check Monotonicity. C C Called by PCHCM to determine the monotonicity properties of the C cubic with boundary derivative values D1,D2 and chord slope DELTA. C C *Cautions: C This is essentially the same as old CHFMC, except that a C new output value, -3, was added February 1989. (Formerly, -3 C and +3 were lumped together in the single value 3.) Codes that C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. C Codes that check via "IF (ISMON.GE.3)" should change the test to C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". C C REFER TO PCHCM C C***ROUTINES CALLED R1MACH C***REVISION HISTORY (YYMMDD) C 820518 DATE WRITTEN C 820805 Converted to SLATEC library version. C 831201 Changed from ISIGN to SIGN to correct bug that C produced wrong sign when -1 .LT. DELTA .LT. 0 . C 890206 Added SAVE statements. C 890207 Added sign to returned value ISMON=3 and corrected C argument description accordingly. C 890306 Added caution about changed output. C 890407 Changed name from CHFMC to CHFCM, as requested at the C March 1989 SLATEC CML meeting, and made a few other C minor modifications necessitated by this change. C 890407 Converted to new SLATEC format. C 890407 Modified DESCRIPTION to LDOC format. C 891214 Moved SAVE statements. (WRB) C***END PROLOGUE CHFCM C C Fortran intrinsics used: SIGN. C Other routines used: R1MACH. C C ---------------------------------------------------------------------- C C Programming notes: C C TEN is actually a tuning parameter, which determines the width of C the fuzz around the elliptical boundary. C C To produce a double precision version, simply: C a. Change CHFCM to DCHFCM wherever it occurs, C b. Change the real declarations to double precision, and C c. Change the constants ZERO, ONE, ... to double precision. C C DECLARE ARGUMENTS. C REAL D1, D2, DELTA C C DECLARE LOCAL VARIABLES. C INTEGER ISMON, ITRUE REAL A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO, ZERO SAVE ZERO, ONE, TWO, THREE, FOUR SAVE TEN C C INITIALIZE. C DATA ZERO /0./, ONE /1.0/, TWO /2./, THREE /3./, FOUR /4./, 1 TEN /10./ C C MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND. C***FIRST EXECUTABLE STATEMENT CHFCM EPS = TEN*R1MACH(4) C C MAKE THE CHECK. C IF (DELTA .EQ. ZERO) THEN C CASE OF CONSTANT DATA. IF ((D1.EQ.ZERO) .AND. (D2.EQ.ZERO)) THEN ISMON = 0 ELSE ISMON = 2 ENDIF ELSE C DATA IS NOT CONSTANT -- PICK UP SIGN. ITRUE = SIGN (ONE, DELTA) A = D1/DELTA B = D2/DELTA IF ((A.LT.ZERO) .OR. (B.LT.ZERO)) THEN ISMON = 2 ELSE IF ((A.LE.THREE-EPS) .AND. (B.LE.THREE-EPS)) THEN C INSIDE SQUARE (0,3)X(0,3) IMPLIES OK. ISMON = ITRUE ELSE IF ((A.GT.FOUR+EPS) .AND. (B.GT.FOUR+EPS)) THEN C OUTSIDE SQUARE (0,4)X(0,4) IMPLIES NONMONOTONIC. ISMON = 2 ELSE C MUST CHECK AGAINST BOUNDARY OF ELLIPSE. A = A - TWO B = B - TWO PHI = ((A*A + B*B) + A*B) - THREE IF (PHI .LT. -EPS) THEN ISMON = ITRUE ELSE IF (PHI .GT. EPS) THEN ISMON = 2 ELSE C TO CLOSE TO BOUNDARY TO TELL, C IN THE PRESENCE OF ROUND-OFF ERRORS. ISMON = 3*ITRUE ENDIF ENDIF ENDIF C C RETURN VALUE. C CHFCM = ISMON RETURN C------------- LAST LINE OF CHFCM FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/chfdv.f0000644060175006010010000001253512562522364015046 0ustar chmNone*DECK CHFDV SUBROUTINE CHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT, + IERR) C***BEGIN PROLOGUE CHFDV C***PURPOSE Evaluate a cubic polynomial given in Hermite form and its C first derivative at an array of points. While designed for C use by PCHFD, it may be useful directly as an evaluator C for a piecewise cubic Hermite function in applications, C such as graphing, where the interval is known in advance. C If only function values are required, use CHFEV instead. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H1 C***TYPE SINGLE PRECISION (CHFDV-S, DCHFDV-D) C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, C CUBIC POLYNOMIAL EVALUATION, PCHIP C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C CHFDV: Cubic Hermite Function and Derivative Evaluator C C Evaluates the cubic polynomial determined by function values C F1,F2 and derivatives D1,D2 on interval (X1,X2), together with C its first derivative, at the points XE(J), J=1(1)NE. C C If only function values are required, use CHFEV, instead. C C ---------------------------------------------------------------------- C C Calling sequence: C C INTEGER NE, NEXT(2), IERR C REAL X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), DE(NE) C C CALL CHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR) C C Parameters: C C X1,X2 -- (input) endpoints of interval of definition of cubic. C (Error return if X1.EQ.X2 .) C C F1,F2 -- (input) values of function at X1 and X2, respectively. C C D1,D2 -- (input) values of derivative at X1 and X2, respectively. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real array of points at which the functions are to C be evaluated. If any of the XE are outside the interval C [X1,X2], a warning error is returned in NEXT. C C FE -- (output) real array of values of the cubic function defined C by X1,X2, F1,F2, D1,D2 at the points XE. C C DE -- (output) real array of values of the first derivative of C the same function at the points XE. C C NEXT -- (output) integer array indicating number of extrapolation C points: C NEXT(1) = number of evaluation points to left of interval. C NEXT(2) = number of evaluation points to right of interval. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if NE.LT.1 . C IERR = -2 if X1.EQ.X2 . C (Output arrays have not been changed in either case.) C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 811019 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE CHFDV C Programming notes: C C To produce a double precision version, simply: C a. Change CHFDV to DCHFDV wherever it occurs, C b. Change the real declaration to double precision, and C c. Change the constant ZERO to double precision. C C DECLARE ARGUMENTS. C INTEGER NE, NEXT(2), IERR REAL X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*) C C DECLARE LOCAL VARIABLES. C INTEGER I REAL C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO SAVE ZERO DATA ZERO /0./ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT CHFDV IF (NE .LT. 1) GO TO 5001 H = X2 - X1 IF (H .EQ. ZERO) GO TO 5002 C C INITIALIZE. C IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) C C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). C DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H C (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C2T2 = C2 + C2 C3 = (DEL1 + DEL2)/H C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) C3T3 = C3+C3+C3 C C EVALUATION LOOP. C DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) DE(I) = D1 + X*(C2T2 + X*C3T3) C COUNT EXTRAPOLATION POINTS. IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE C C NORMAL RETURN. C RETURN C C ERROR RETURNS. C 5001 CONTINUE C NE.LT.1 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'CHFDV', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5002 CONTINUE C X1.EQ.X2 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'CHFDV', 'INTERVAL ENDPOINTS EQUAL', IERR, + 1) RETURN C------------- LAST LINE OF CHFDV FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/chfev.f0000644060175006010010000001155112562522364015044 0ustar chmNone*DECK CHFEV SUBROUTINE CHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR) C***BEGIN PROLOGUE CHFEV C***PURPOSE Evaluate a cubic polynomial given in Hermite form at an C array of points. While designed for use by PCHFE, it may C be useful directly as an evaluator for a piecewise cubic C Hermite function in applications, such as graphing, where C the interval is known in advance. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE SINGLE PRECISION (CHFEV-S, DCHFEV-D) C***KEYWORDS CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION, C PCHIP C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C CHFEV: Cubic Hermite Function EValuator C C Evaluates the cubic polynomial determined by function values C F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points C XE(J), J=1(1)NE. C C ---------------------------------------------------------------------- C C Calling sequence: C C INTEGER NE, NEXT(2), IERR C REAL X1, X2, F1, F2, D1, D2, XE(NE), FE(NE) C C CALL CHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR) C C Parameters: C C X1,X2 -- (input) endpoints of interval of definition of cubic. C (Error return if X1.EQ.X2 .) C C F1,F2 -- (input) values of function at X1 and X2, respectively. C C D1,D2 -- (input) values of derivative at X1 and X2, respectively. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real array of points at which the function is to be C evaluated. If any of the XE are outside the interval C [X1,X2], a warning error is returned in NEXT. C C FE -- (output) real array of values of the cubic function defined C by X1,X2, F1,F2, D1,D2 at the points XE. C C NEXT -- (output) integer array indicating number of extrapolation C points: C NEXT(1) = number of evaluation points to left of interval. C NEXT(2) = number of evaluation points to right of interval. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if NE.LT.1 . C IERR = -2 if X1.EQ.X2 . C (The FE-array has not been changed in either case.) C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 811019 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890703 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE CHFEV C Programming notes: C C To produce a double precision version, simply: C a. Change CHFEV to DCHFEV wherever it occurs, C b. Change the real declaration to double precision, and C c. Change the constant ZERO to double precision. C C DECLARE ARGUMENTS. C INTEGER NE, NEXT(2), IERR REAL X1, X2, F1, F2, D1, D2, XE(*), FE(*) C C DECLARE LOCAL VARIABLES. C INTEGER I REAL C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, ZERO SAVE ZERO DATA ZERO /0./ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT CHFEV IF (NE .LT. 1) GO TO 5001 H = X2 - X1 IF (H .EQ. ZERO) GO TO 5002 C C INITIALIZE. C IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) C C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). C DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H C (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C3 = (DEL1 + DEL2)/H C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) C C EVALUATION LOOP. C DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) C COUNT EXTRAPOLATION POINTS. IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE C C NORMAL RETURN. C RETURN C C ERROR RETURNS. C 5001 CONTINUE C NE.LT.1 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'CHFEV', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5002 CONTINUE C X1.EQ.X2 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'CHFEV', 'INTERVAL ENDPOINTS EQUAL', IERR, + 1) RETURN C------------- LAST LINE OF CHFEV FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/chfie.f0000644060175006010010000000632712562522364015034 0ustar chmNone*DECK CHFIE REAL FUNCTION CHFIE (X1, X2, F1, F2, D1, D2, A, B) C***BEGIN PROLOGUE CHFIE C***SUBSIDIARY C***PURPOSE Evaluates integral of a single cubic for PCHIA C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (CHFIE-S, DCHFIE-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C CHFIE: Cubic Hermite Function Integral Evaluator. C C Called by PCHIA to evaluate the integral of a single cubic (in C Hermite form) over an arbitrary interval (A,B). C C ---------------------------------------------------------------------- C C Calling sequence: C C REAL X1, X2, F1, F2, D1, D2, A, B C REAL VALUE, CHFIE C C VALUE = CHFIE (X1, X2, F1, F2, D1, D2, A, B) C C Parameters: C C VALUE -- (output) value of the requested integral. C C X1,X2 -- (input) endpoints if interval of definition of cubic. C C F1,F2 -- (input) function values at the ends of the interval. C C D1,D2 -- (input) derivative values at the ends of the interval. C C A,B -- (input) endpoints of interval of integration. C C***SEE ALSO PCHIA C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 820730 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870813 Minor cosmetic changes. C 890411 1. Added SAVE statements (Vers. 3.2). C 2. Added SIX to REAL declaration. C 890411 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Corrected to set VALUE=0 when IERR.ne.0. (FNF) C 930504 Eliminated IERR and changed name from CHFIV to CHFIE. (FNF) C***END PROLOGUE CHFIE C C Programming notes: C 1. There is no error return from this routine because zero is C indeed the mathematically correct answer when X1.EQ.X2 . C**End C C DECLARE ARGUMENTS. C REAL X1, X2, F1, F2, D1, D2, A, B C C DECLARE LOCAL VARIABLES. C REAL DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, PHIB1, PHIB2, * PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, TB1, TB2, THREE, * TWO, UA1, UA2, UB1, UB2 SAVE HALF, TWO, THREE, FOUR, SIX C C INITIALIZE. C DATA HALF /0.5/, TWO /2./, THREE /3./, FOUR /4./, SIX /6./ C C VALIDITY CHECK INPUT. C C***FIRST EXECUTABLE STATEMENT CHFIE IF (X1 .EQ. X2) THEN CHFIE = 0 ELSE H = X2 - X1 TA1 = (A - X1) / H TA2 = (X2 - A) / H TB1 = (B - X1) / H TB2 = (X2 - B) / H C UA1 = TA1**3 PHIA1 = UA1 * (TWO - TA1) PSIA1 = UA1 * (THREE*TA1 - FOUR) UA2 = TA2**3 PHIA2 = UA2 * (TWO - TA2) PSIA2 = -UA2 * (THREE*TA2 - FOUR) C UB1 = TB1**3 PHIB1 = UB1 * (TWO - TB1) PSIB1 = UB1 * (THREE*TB1 - FOUR) UB2 = TB2**3 PHIB2 = UB2 * (TWO - TB2) PSIB2 = -UB2 * (THREE*TB2 - FOUR) C FTERM = F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1) DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX) C CHFIE = (HALF*H) * (FTERM + DTERM) ENDIF C RETURN C------------- LAST LINE OF CHFIE FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/d1mach.f0000644060175006010010000004676112562522364015121 0ustar chmNone*DECK D1MACH DOUBLE PRECISION FUNCTION D1MACH (I) C***BEGIN PROLOGUE D1MACH C***PURPOSE Return floating point machine dependent constants. C***LIBRARY SLATEC C***CATEGORY R1 C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Fox, P. A., (Bell Labs) C Hall, A. D., (Bell Labs) C Schryer, N. L., (Bell Labs) C***DESCRIPTION C C D1MACH can be used to obtain machine-dependent parameters for the C local machine environment. It is a function subprogram with one C (input) argument, and can be referenced as follows: C C D = D1MACH(I) C C where I=1,...,5. The (output) value of D above is determined by C the (input) value of I. The results for various values of I are C discussed below. C C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. C D1MACH( 3) = B**(-T), the smallest relative spacing. C D1MACH( 4) = B**(1-T), the largest relative spacing. C D1MACH( 5) = LOG10(B) C C Assume double precision numbers are represented in the T-digit, C base-B form C C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and C EMIN .LE. E .LE. EMAX. C C The values of B, T, EMIN and EMAX are provided in I1MACH as C follows: C I1MACH(10) = B, the base. C I1MACH(14) = T, the number of base-B digits. C I1MACH(15) = EMIN, the smallest exponent E. C I1MACH(16) = EMAX, the largest exponent E. C C To alter this function for a particular environment, the desired C set of DATA statements should be activated by removing the C from C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be C checked for consistency with the local operating system. C C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for C a portable library, ACM Transactions on Mathematical C Software 4, 2 (June 1978), pp. 177-188. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 890213 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900618 Added DEC RISC constants. (WRB) C 900723 Added IBM RS 6000 constants. (WRB) C 900911 Added SUN 386i constants. (WRB) C 910710 Added HP 730 constants. (SMR) C 911114 Added Convex IEEE constants. (WRB) C 920121 Added SUN -r8 compiler option constants. (WRB) C 920229 Added Touchstone Delta i860 constants. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C 920625 Added CONVEX -p8 and -pd8 compiler option constants. C (BKS, WRB) C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) C***END PROLOGUE D1MACH C INTEGER SMALL(4) INTEGER LARGE(4) INTEGER RIGHT(4) INTEGER DIVER(4) INTEGER LOG10(4) C DOUBLE PRECISION DMACH(5) SAVE DMACH C EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE APOLLO C C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM C C DATA SMALL(1) / ZC00800000 / C DATA SMALL(2) / Z000000000 / C DATA LARGE(1) / ZDFFFFFFFF / C DATA LARGE(2) / ZFFFFFFFFF / C DATA RIGHT(1) / ZCC5800000 / C DATA RIGHT(2) / Z000000000 / C DATA DIVER(1) / ZCC6800000 / C DATA DIVER(2) / Z000000000 / C DATA LOG10(1) / ZD00E730E7 / C DATA LOG10(2) / ZC77800DC0 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O0000000000000000 / C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O0007777777777777 / C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O7770000000000000 / C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O7777777777777777 / C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE C C DATA SMALL(1) / Z"3001800000000000" / C DATA SMALL(2) / Z"3001000000000000" / C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / C DATA LARGE(2) / Z"4FFE000000000000" / C DATA RIGHT(1) / Z"3FD2800000000000" / C DATA RIGHT(2) / Z"3FD2000000000000" / C DATA DIVER(1) / Z"3FD3800000000000" / C DATA DIVER(2) / Z"3FD3000000000000" / C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / C DATA LOG10(2) / Z"3FFFF7988F8959AC" / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C C DATA SMALL(1) / 00564000000000000000B / C DATA SMALL(2) / 00000000000000000000B / C DATA LARGE(1) / 37757777777777777777B / C DATA LARGE(2) / 37157777777777777777B / C DATA RIGHT(1) / 15624000000000000000B / C DATA RIGHT(2) / 00000000000000000000B / C DATA DIVER(1) / 15634000000000000000B / C DATA DIVER(2) / 00000000000000000000B / C DATA LOG10(1) / 17164642023241175717B / C DATA LOG10(2) / 16367571421742254654B / C C MACHINE CONSTANTS FOR THE CELERITY C1260 C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fn OR -pd8 COMPILER OPTION C C DATA DMACH(1) / Z'0010000000000000' / C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3CC0000000000000' / C DATA DMACH(4) / Z'3CD0000000000000' / C DATA DMACH(5) / Z'3FF34413509F79FF' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fi COMPILER OPTION C C DATA DMACH(1) / Z'0010000000000000' / C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3CA0000000000000' / C DATA DMACH(4) / Z'3CB0000000000000' / C DATA DMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -p8 COMPILER OPTION C C DATA DMACH(1) / Z'00010000000000000000000000000000' / C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3F900000000000000000000000000000' / C DATA DMACH(4) / Z'3F910000000000000000000000000000' / C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / C C MACHINE CONSTANTS FOR THE CRAY C C DATA SMALL(1) / 201354000000000000000B / C DATA SMALL(2) / 000000000000000000000B / C DATA LARGE(1) / 577767777777777777777B / C DATA LARGE(2) / 000007777777777777774B / C DATA RIGHT(1) / 376434000000000000000B / C DATA RIGHT(2) / 000000000000000000000B / C DATA DIVER(1) / 376444000000000000000B / C DATA DIVER(2) / 000000000000000000000B / C DATA LOG10(1) / 377774642023241175717B / C DATA LOG10(2) / 000007571421742254654B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC DMACH(5) C C DATA SMALL / 20K, 3*0 / C DATA LARGE / 77777K, 3*177777K / C DATA RIGHT / 31420K, 3*0 / C DATA DIVER / 32020K, 3*0 / C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING G_FLOAT C C DATA DMACH(1) / '0000000000000010'X / C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / C DATA DMACH(3) / '0000000000003CC0'X / C DATA DMACH(4) / '0000000000003CD0'X / C DATA DMACH(5) / '79FF509F44133FF3'X / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING IEEE_FORMAT C C DATA DMACH(1) / '0010000000000000'X / C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / C DATA DMACH(3) / '3CA0000000000000'X / C DATA DMACH(4) / '3CB0000000000000'X / C DATA DMACH(5) / '3FD34413509F79FF'X / C C MACHINE CONSTANTS FOR THE DEC RISC C C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ C C MACHINE CONSTANTS FOR THE DEC VAX C USING D_FLOATING C (EXPRESSED IN INTEGER AND HEXADECIMAL) C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS C C DATA SMALL(1), SMALL(2) / 128, 0 / C DATA LARGE(1), LARGE(2) / -32769, -1 / C DATA RIGHT(1), RIGHT(2) / 9344, 0 / C DATA DIVER(1), DIVER(2) / 9472, 0 / C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / C C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / C C MACHINE CONSTANTS FOR THE DEC VAX C USING G_FLOATING C (EXPRESSED IN INTEGER AND HEXADECIMAL) C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS C C DATA SMALL(1), SMALL(2) / 16, 0 / C DATA LARGE(1), LARGE(2) / -32769, -1 / C DATA RIGHT(1), RIGHT(2) / 15552, 0 / C DATA DIVER(1), DIVER(2) / 15568, 0 / C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / C C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / C C MACHINE CONSTANTS FOR THE ELXSI 6400 C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) C C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES C C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / C C MACHINE CONSTANTS FOR THE HP 730 C C DATA DMACH(1) / Z'0010000000000000' / C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3CA0000000000000' / C DATA DMACH(4) / Z'3CB0000000000000' / C DATA DMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE HP 2100 C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / C C MACHINE CONSTANTS FOR THE HP 2100 C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 0 / C DATA SMALL(3), SMALL(4) / 0, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177777B / C DATA LARGE(3), LARGE(4) / 177777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / C DATA RIGHT(3), RIGHT(4) / 0, 225B / C DATA DIVER(1), DIVER(2) / 40000B, 0 / C DATA DIVER(3), DIVER(4) / 0, 227B / C DATA LOG10(1), LOG10(2) / 46420B, 46502B / C DATA LOG10(3), LOG10(4) / 76747B, 176377B / C C MACHINE CONSTANTS FOR THE HP 9000 C C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND C THE PERKIN ELMER (INTERDATA) 7/32. C C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / C C MACHINE CONSTANTS FOR THE IBM PC C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. C C DATA SMALL(1) / 2.23D-308 / C DATA LARGE(1) / 1.79D+308 / C DATA RIGHT(1) / 1.11D-16 / C DATA DIVER(1) / 2.22D-16 / C DATA LOG10(1) / 0.301029995663981195D0 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 C C DATA DMACH(1) / Z'0010000000000000' / C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3CA0000000000000' / C DATA DMACH(4) / Z'3CB0000000000000' / C DATA DMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE INTEL i860 C C DATA DMACH(1) / Z'0010000000000000' / C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3CA0000000000000' / C DATA DMACH(4) / Z'3CB0000000000000' / C DATA DMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) C C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) C C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1), SMALL(2) / 8388608, 0 / C DATA LARGE(1), LARGE(2) / 2147483647, -1 / C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / C DATA DIVER(1), DIVER(2) / 620756992, 0 / C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / C C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1), SMALL(2) / 128, 0 / C DATA SMALL(3), SMALL(4) / 0, 0 / C DATA LARGE(1), LARGE(2) / 32767, -1 / C DATA LARGE(3), LARGE(4) / -1, -1 / C DATA RIGHT(1), RIGHT(2) / 9344, 0 / C DATA RIGHT(3), RIGHT(4) / 0, 0 / C DATA DIVER(1), DIVER(2) / 9472, 0 / C DATA DIVER(3), DIVER(4) / 0, 0 / C DATA LOG10(1), LOG10(2) / 16282, 8346 / C DATA LOG10(3), LOG10(4) / -31493, -12296 / C C DATA SMALL(1), SMALL(2) / O000200, O000000 / C DATA SMALL(3), SMALL(4) / O000000, O000000 / C DATA LARGE(1), LARGE(2) / O077777, O177777 / C DATA LARGE(3), LARGE(4) / O177777, O177777 / C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / C DATA DIVER(1), DIVER(2) / O022400, O000000 / C DATA DIVER(3), DIVER(4) / O000000, O000000 / C DATA LOG10(1), LOG10(2) / O037632, O020232 / C DATA LOG10(3), LOG10(4) / O102373, O147770 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS C C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / C C MACHINE CONSTANTS FOR THE SUN C C DATA DMACH(1) / Z'0010000000000000' / C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3CA0000000000000' / C DATA DMACH(4) / Z'3CB0000000000000' / C DATA DMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE SUN C USING THE -r8 COMPILER OPTION C C DATA DMACH(1) / Z'00010000000000000000000000000000' / C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / C C MACHINE CONSTANTS FOR THE SUN 386i C C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER C C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / C C***FIRST EXECUTABLE STATEMENT D1MACH IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', + 'I OUT OF BOUNDS', 1, 2) C D1MACH = DMACH(I) RETURN C END PDL-2.018/Lib/Slatec/slatec/dasum.f0000644060175006010010000000503512562522364015062 0ustar chmNone*DECK DASUM DOUBLE PRECISION FUNCTION DASUM (N, DX, INCX) C***BEGIN PROLOGUE DASUM C***PURPOSE Compute the sum of the magnitudes of the elements of a C vector. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A3A C***TYPE DOUBLE PRECISION (SASUM-S, DASUM-D, SCASUM-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C DX double precision vector with N elements C INCX storage spacing between elements of DX C C --Output-- C DASUM double precision result (zero if N .LE. 0) C C Returns sum of magnitudes of double precision DX. C DASUM = sum from 0 to N-1 of ABS(DX(IX+I*INCX)), C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900821 Modified to correct problem with a negative increment. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DASUM DOUBLE PRECISION DX(*) INTEGER I, INCX, IX, M, MP1, N C***FIRST EXECUTABLE STATEMENT DASUM DASUM = 0.0D0 IF (N .LE. 0) RETURN C IF (INCX .EQ. 1) GOTO 20 C C Code for increment not equal to 1. C IX = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N DASUM = DASUM + ABS(DX(IX)) IX = IX + INCX 10 CONTINUE RETURN C C Code for increment equal to 1. C C Clean-up loop so remaining vector length is a multiple of 6. C 20 M = MOD(N,6) IF (M .EQ. 0) GOTO 40 DO 30 I = 1,M DASUM = DASUM + ABS(DX(I)) 30 CONTINUE IF (N .LT. 6) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 DASUM = DASUM + ABS(DX(I)) + ABS(DX(I+1)) + ABS(DX(I+2)) + 1 ABS(DX(I+3)) + ABS(DX(I+4)) + ABS(DX(I+5)) 50 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/daxpy.f0000644060175006010010000000564412562522364015104 0ustar chmNone*DECK DAXPY SUBROUTINE DAXPY (N, DA, DX, INCX, DY, INCY) C***BEGIN PROLOGUE DAXPY C***PURPOSE Compute a constant times a vector plus a vector. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A7 C***TYPE DOUBLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C DA double precision scalar multiplier C DX double precision vector with N elements C INCX storage spacing between elements of DX C DY double precision vector with N elements C INCY storage spacing between elements of DY C C --Output-- C DY double precision result (unchanged if N .LE. 0) C C Overwrite double precision DY with double precision DA*DX + DY. C For I = 0 to N-1, replace DY(LY+I*INCY) with DA*DX(LX+I*INCX) + C DY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is C defined in a similar way using INCY. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Corrected definition of LX in DESCRIPTION. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DAXPY DOUBLE PRECISION DX(*), DY(*), DA C***FIRST EXECUTABLE STATEMENT DAXPY IF (N.LE.0 .OR. DA.EQ.0.0D0) RETURN IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 C C Code for unequal or nonpositive increments. C 5 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C Code for both increments equal to 1. C C Clean-up loop so remaining vector length is a multiple of 4. C 20 M = MOD(N,4) IF (M .EQ. 0) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF (N .LT. 4) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I+1) = DY(I+1) + DA*DX(I+1) DY(I+2) = DY(I+2) + DA*DX(I+2) DY(I+3) = DY(I+3) + DA*DX(I+3) 50 CONTINUE RETURN C C Code for equal, positive, non-unit increments. C 60 NS = N*INCX DO 70 I = 1,NS,INCX DY(I) = DA*DX(I) + DY(I) 70 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dchfcm.f0000644060175006010010000001201312562522364015167 0ustar chmNone*DECK DCHFCM INTEGER FUNCTION DCHFCM (D1, D2, DELTA) C***BEGIN PROLOGUE DCHFCM C***SUBSIDIARY C***PURPOSE Check a single cubic for monotonicity. C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (CHFCM-S, DCHFCM-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C *Usage: C C DOUBLE PRECISION D1, D2, DELTA C INTEGER ISMON, DCHFCM C C ISMON = DCHFCM (D1, D2, DELTA) C C *Arguments: C C D1,D2:IN are the derivative values at the ends of an interval. C C DELTA:IN is the data slope over that interval. C C *Function Return Values: C ISMON : indicates the monotonicity of the cubic segment: C ISMON = -3 if function is probably decreasing; C ISMON = -1 if function is strictly decreasing; C ISMON = 0 if function is constant; C ISMON = 1 if function is strictly increasing; C ISMON = 2 if function is non-monotonic; C ISMON = 3 if function is probably increasing. C If ABS(ISMON)=3, the derivative values are too close to the C boundary of the monotonicity region to declare monotonicity C in the presence of roundoff error. C C *Description: C C DCHFCM: Cubic Hermite Function -- Check Monotonicity. C C Called by DPCHCM to determine the monotonicity properties of the C cubic with boundary derivative values D1,D2 and chord slope DELTA. C C *Cautions: C This is essentially the same as old DCHFMC, except that a C new output value, -3, was added February 1989. (Formerly, -3 C and +3 were lumped together in the single value 3.) Codes that C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. C Codes that check via "IF (ISMON.GE.3)" should change the test to C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". C C REFER TO DPCHCM C C***ROUTINES CALLED D1MACH C***REVISION HISTORY (YYMMDD) C 820518 DATE WRITTEN C 820805 Converted to SLATEC library version. C 831201 Changed from ISIGN to SIGN to correct bug that C produced wrong sign when -1 .LT. DELTA .LT. 0 . C 890206 Added SAVE statements. C 890209 Added sign to returned value ISMON=3 and corrected C argument description accordingly. C 890306 Added caution about changed output. C 890407 Changed name from DCHFMC to DCHFCM, as requested at the C March 1989 SLATEC CML meeting, and made a few other C minor modifications necessitated by this change. C 890407 Converted to new SLATEC format. C 890407 Modified DESCRIPTION to LDOC format. C 891214 Moved SAVE statements. (WRB) C***END PROLOGUE DCHFCM C C Fortran intrinsics used: DSIGN. C Other routines used: D1MACH. C C ---------------------------------------------------------------------- C C Programming notes: C C TEN is actually a tuning parameter, which determines the width of C the fuzz around the elliptical boundary. C C To produce a single precision version, simply: C a. Change DCHFCM to CHFCM wherever it occurs, C b. Change the double precision declarations to real, and C c. Change the constants ZERO, ONE, ... to single precision. C C DECLARE ARGUMENTS. C DOUBLE PRECISION D1, D2, DELTA, D1MACH C C DECLARE LOCAL VARIABLES. C INTEGER ISMON, ITRUE DOUBLE PRECISION A, B, EPS, FOUR, ONE, PHI, TEN, THREE, TWO, * ZERO SAVE ZERO, ONE, TWO, THREE, FOUR SAVE TEN C C INITIALIZE. C DATA ZERO /0.D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/, 1 TEN /10.D0/ C C MACHINE-DEPENDENT PARAMETER -- SHOULD BE ABOUT 10*UROUND. C***FIRST EXECUTABLE STATEMENT DCHFCM EPS = TEN*D1MACH(4) C C MAKE THE CHECK. C IF (DELTA .EQ. ZERO) THEN C CASE OF CONSTANT DATA. IF ((D1.EQ.ZERO) .AND. (D2.EQ.ZERO)) THEN ISMON = 0 ELSE ISMON = 2 ENDIF ELSE C DATA IS NOT CONSTANT -- PICK UP SIGN. ITRUE = DSIGN (ONE, DELTA) A = D1/DELTA B = D2/DELTA IF ((A.LT.ZERO) .OR. (B.LT.ZERO)) THEN ISMON = 2 ELSE IF ((A.LE.THREE-EPS) .AND. (B.LE.THREE-EPS)) THEN C INSIDE SQUARE (0,3)X(0,3) IMPLIES OK. ISMON = ITRUE ELSE IF ((A.GT.FOUR+EPS) .AND. (B.GT.FOUR+EPS)) THEN C OUTSIDE SQUARE (0,4)X(0,4) IMPLIES NONMONOTONIC. ISMON = 2 ELSE C MUST CHECK AGAINST BOUNDARY OF ELLIPSE. A = A - TWO B = B - TWO PHI = ((A*A + B*B) + A*B) - THREE IF (PHI .LT. -EPS) THEN ISMON = ITRUE ELSE IF (PHI .GT. EPS) THEN ISMON = 2 ELSE C TO CLOSE TO BOUNDARY TO TELL, C IN THE PRESENCE OF ROUND-OFF ERRORS. ISMON = 3*ITRUE ENDIF ENDIF ENDIF C C RETURN VALUE. C DCHFCM = ISMON RETURN C------------- LAST LINE OF DCHFCM FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dchfdv.f0000644060175006010010000001310312562522364015202 0ustar chmNone*DECK DCHFDV SUBROUTINE DCHFDV (X1, X2, F1, F2, D1, D2, NE, XE, FE, DE, NEXT, + IERR) C***BEGIN PROLOGUE DCHFDV C***PURPOSE Evaluate a cubic polynomial given in Hermite form and its C first derivative at an array of points. While designed for C use by DPCHFD, it may be useful directly as an evaluator C for a piecewise cubic Hermite function in applications, C such as graphing, where the interval is known in advance. C If only function values are required, use DCHFEV instead. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H1 C***TYPE DOUBLE PRECISION (CHFDV-S, DCHFDV-D) C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, C CUBIC POLYNOMIAL EVALUATION, PCHIP C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DCHFDV: Cubic Hermite Function and Derivative Evaluator C C Evaluates the cubic polynomial determined by function values C F1,F2 and derivatives D1,D2 on interval (X1,X2), together with C its first derivative, at the points XE(J), J=1(1)NE. C C If only function values are required, use DCHFEV, instead. C C ---------------------------------------------------------------------- C C Calling sequence: C C INTEGER NE, NEXT(2), IERR C DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), C DE(NE) C C CALL DCHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR) C C Parameters: C C X1,X2 -- (input) endpoints of interval of definition of cubic. C (Error return if X1.EQ.X2 .) C C F1,F2 -- (input) values of function at X1 and X2, respectively. C C D1,D2 -- (input) values of derivative at X1 and X2, respectively. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real*8 array of points at which the functions are to C be evaluated. If any of the XE are outside the interval C [X1,X2], a warning error is returned in NEXT. C C FE -- (output) real*8 array of values of the cubic function C defined by X1,X2, F1,F2, D1,D2 at the points XE. C C DE -- (output) real*8 array of values of the first derivative of C the same function at the points XE. C C NEXT -- (output) integer array indicating number of extrapolation C points: C NEXT(1) = number of evaluation points to left of interval. C NEXT(2) = number of evaluation points to right of interval. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if NE.LT.1 . C IERR = -2 if X1.EQ.X2 . C (Output arrays have not been changed in either case.) C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 811019 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 870707 Corrected XERROR calls for d.p. names(s). C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE DCHFDV C Programming notes: C C To produce a single precision version, simply: C a. Change DCHFDV to CHFDV wherever it occurs, C b. Change the double precision declaration to real, and C c. Change the constant ZERO to single precision. C C DECLARE ARGUMENTS. C INTEGER NE, NEXT(2), IERR DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(*), FE(*), DE(*) C C DECLARE LOCAL VARIABLES. C INTEGER I DOUBLE PRECISION C2, C2T2, C3, C3T3, DEL1, DEL2, DELTA, H, X, * XMI, XMA, ZERO SAVE ZERO DATA ZERO /0.D0/ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DCHFDV IF (NE .LT. 1) GO TO 5001 H = X2 - X1 IF (H .EQ. ZERO) GO TO 5002 C C INITIALIZE. C IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) C C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). C DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H C (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C2T2 = C2 + C2 C3 = (DEL1 + DEL2)/H C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) C3T3 = C3+C3+C3 C C EVALUATION LOOP. C DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) DE(I) = D1 + X*(C2T2 + X*C3T3) C COUNT EXTRAPOLATION POINTS. IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE C C NORMAL RETURN. C RETURN C C ERROR RETURNS. C 5001 CONTINUE C NE.LT.1 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DCHFDV', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5002 CONTINUE C X1.EQ.X2 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DCHFDV', 'INTERVAL ENDPOINTS EQUAL', + IERR, 1) RETURN C------------- LAST LINE OF DCHFDV FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dchfev.f0000644060175006010010000001213712562522364015211 0ustar chmNone*DECK DCHFEV SUBROUTINE DCHFEV (X1, X2, F1, F2, D1, D2, NE, XE, FE, NEXT, IERR) C***BEGIN PROLOGUE DCHFEV C***PURPOSE Evaluate a cubic polynomial given in Hermite form at an C array of points. While designed for use by DPCHFE, it may C be useful directly as an evaluator for a piecewise cubic C Hermite function in applications, such as graphing, where C the interval is known in advance. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE DOUBLE PRECISION (CHFEV-S, DCHFEV-D) C***KEYWORDS CUBIC HERMITE EVALUATION, CUBIC POLYNOMIAL EVALUATION, C PCHIP C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DCHFEV: Cubic Hermite Function EValuator C C Evaluates the cubic polynomial determined by function values C F1,F2 and derivatives D1,D2 on interval (X1,X2) at the points C XE(J), J=1(1)NE. C C ---------------------------------------------------------------------- C C Calling sequence: C C INTEGER NE, NEXT(2), IERR C DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(NE), FE(NE) C C CALL DCHFEV (X1,X2, F1,F2, D1,D2, NE, XE, FE, NEXT, IERR) C C Parameters: C C X1,X2 -- (input) endpoints of interval of definition of cubic. C (Error return if X1.EQ.X2 .) C C F1,F2 -- (input) values of function at X1 and X2, respectively. C C D1,D2 -- (input) values of derivative at X1 and X2, respectively. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real*8 array of points at which the function is to C be evaluated. If any of the XE are outside the interval C [X1,X2], a warning error is returned in NEXT. C C FE -- (output) real*8 array of values of the cubic function C defined by X1,X2, F1,F2, D1,D2 at the points XE. C C NEXT -- (output) integer array indicating number of extrapolation C points: C NEXT(1) = number of evaluation points to left of interval. C NEXT(2) = number of evaluation points to right of interval. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if NE.LT.1 . C IERR = -2 if X1.EQ.X2 . C (The FE-array has not been changed in either case.) C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 811019 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 870813 Corrected XERROR calls for d.p. names(s). C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE DCHFEV C Programming notes: C C To produce a single precision version, simply: C a. Change DCHFEV to CHFEV wherever it occurs, C b. Change the double precision declaration to real, and C c. Change the constant ZERO to single precision. C C DECLARE ARGUMENTS. C INTEGER NE, NEXT(2), IERR DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(*), FE(*) C C DECLARE LOCAL VARIABLES. C INTEGER I DOUBLE PRECISION C2, C3, DEL1, DEL2, DELTA, H, X, XMI, XMA, * ZERO SAVE ZERO DATA ZERO /0.D0/ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DCHFEV IF (NE .LT. 1) GO TO 5001 H = X2 - X1 IF (H .EQ. ZERO) GO TO 5002 C C INITIALIZE. C IERR = 0 NEXT(1) = 0 NEXT(2) = 0 XMI = MIN(ZERO, H) XMA = MAX(ZERO, H) C C COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). C DELTA = (F2 - F1)/H DEL1 = (D1 - DELTA)/H DEL2 = (D2 - DELTA)/H C (DELTA IS NO LONGER NEEDED.) C2 = -(DEL1+DEL1 + DEL2) C3 = (DEL1 + DEL2)/H C (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) C C EVALUATION LOOP. C DO 500 I = 1, NE X = XE(I) - X1 FE(I) = F1 + X*(D1 + X*(C2 + X*C3)) C COUNT EXTRAPOLATION POINTS. IF ( X.LT.XMI ) NEXT(1) = NEXT(1) + 1 IF ( X.GT.XMA ) NEXT(2) = NEXT(2) + 1 C (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) 500 CONTINUE C C NORMAL RETURN. C RETURN C C ERROR RETURNS. C 5001 CONTINUE C NE.LT.1 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DCHFEV', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5002 CONTINUE C X1.EQ.X2 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DCHFEV', 'INTERVAL ENDPOINTS EQUAL', + IERR, 1) RETURN C------------- LAST LINE OF DCHFEV FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dchfie.f0000644060175006010010000000654512562522364015202 0ustar chmNone*DECK DCHFIE DOUBLE PRECISION FUNCTION DCHFIE (X1, X2, F1, F2, D1, D2, A, B) C***BEGIN PROLOGUE DCHFIE C***SUBSIDIARY C***PURPOSE Evaluates integral of a single cubic for DPCHIA C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (CHFIE-S, DCHFIE-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DCHFIE: Cubic Hermite Function Integral Evaluator. C C Called by DPCHIA to evaluate the integral of a single cubic (in C Hermite form) over an arbitrary interval (A,B). C C ---------------------------------------------------------------------- C C Calling sequence: C C DOUBLE PRECISION X1, X2, F1, F2, D1, D2, A, B C DOUBLE PRECISION VALUE, DCHFIE C C VALUE = DCHFIE (X1, X2, F1, F2, D1, D2, A, B) C C Parameters: C C VALUE -- (output) value of the requested integral. C C X1,X2 -- (input) endpoints if interval of definition of cubic. C C F1,F2 -- (input) function values at the ends of the interval. C C D1,D2 -- (input) derivative values at the ends of the interval. C C A,B -- (input) endpoints of interval of integration. C C***SEE ALSO DPCHIA C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 820730 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870707 Corrected subroutine name from DCHIV to DCHFIV. C 870813 Minor cosmetic changes. C 890411 1. Added SAVE statements (Vers. 3.2). C 2. Added SIX to DOUBLE PRECISION declaration. C 890411 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Corrected to set VALUE=0 when IERR.ne.0. (FNF) C 930504 Eliminated IERR and changed name DCHFIV to DCHFIE. (FNF) C***END PROLOGUE DCHFIE C C Programming notes: C 1. There is no error return from this routine because zero is C indeed the mathematically correct answer when X1.EQ.X2 . C**End C C DECLARE ARGUMENTS. C DOUBLE PRECISION X1, X2, F1, F2, D1, D2, A, B C C DECLARE LOCAL VARIABLES. C DOUBLE PRECISION DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, * PHIB1, PHIB2, PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, * TB1, TB2, THREE, TWO, UA1, UA2, UB1, UB2 SAVE HALF, TWO, THREE, FOUR, SIX C C INITIALIZE. C DATA HALF/.5D0/, TWO/2.D0/, THREE/3.D0/, FOUR/4.D0/, SIX/6.D0/ C C VALIDITY CHECK INPUT. C C***FIRST EXECUTABLE STATEMENT DCHFIE IF (X1 .EQ. X2) THEN DCHFIE = 0 ELSE H = X2 - X1 TA1 = (A - X1) / H TA2 = (X2 - A) / H TB1 = (B - X1) / H TB2 = (X2 - B) / H C UA1 = TA1**3 PHIA1 = UA1 * (TWO - TA1) PSIA1 = UA1 * (THREE*TA1 - FOUR) UA2 = TA2**3 PHIA2 = UA2 * (TWO - TA2) PSIA2 = -UA2 * (THREE*TA2 - FOUR) C UB1 = TB1**3 PHIB1 = UB1 * (TWO - TB1) PSIB1 = UB1 * (THREE*TB1 - FOUR) UB2 = TB2**3 PHIB2 = UB2 * (TWO - TB2) PSIB2 = -UB2 * (THREE*TB2 - FOUR) C FTERM = F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1) DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX) C DCHFIE = (HALF*H) * (FTERM + DTERM) ENDIF C RETURN C------------- LAST LINE OF DCHFIE FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/ddot.f0000644060175006010010000000550112562522364014701 0ustar chmNone*DECK DDOT DOUBLE PRECISION FUNCTION DDOT (N, DX, INCX, DY, INCY) C***BEGIN PROLOGUE DDOT C***PURPOSE Compute the inner product of two vectors. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A4 C***TYPE DOUBLE PRECISION (SDOT-S, DDOT-D, CDOTU-C) C***KEYWORDS BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C DX double precision vector with N elements C INCX storage spacing between elements of DX C DY double precision vector with N elements C INCY storage spacing between elements of DY C C --Output-- C DDOT double precision dot product (zero if N .LE. 0) C C Returns the dot product of double precision DX and DY. C DDOT = sum for I = 0 to N-1 of DX(LX+I*INCX) * DY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is C defined in a similar way using INCY. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Corrected definition of LX in DESCRIPTION. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DDOT DOUBLE PRECISION DX(*), DY(*) C***FIRST EXECUTABLE STATEMENT DDOT DDOT = 0.0D0 IF (N .LE. 0) RETURN IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 C C Code for unequal or nonpositive increments. C 5 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N DDOT = DDOT + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C Code for both increments equal to 1. C C Clean-up loop so remaining vector length is a multiple of 5. C 20 M = MOD(N,5) IF (M .EQ. 0) GO TO 40 DO 30 I = 1,M DDOT = DDOT + DX(I)*DY(I) 30 CONTINUE IF (N .LT. 5) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + DX(I+2)*DY(I+2) + 1 DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4) 50 CONTINUE RETURN C C Code for equal, positive, non-unit increments. C 60 NS = N*INCX DO 70 I = 1,NS,INCX DDOT = DDOT + DX(I)*DY(I) 70 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dgeco.f0000644060175006010010000001464612562522364015042 0ustar chmNone*DECK DGECO SUBROUTINE DGECO (A, LDA, N, IPVT, RCOND, Z) C***BEGIN PROLOGUE DGECO C***PURPOSE Factor a matrix using Gaussian elimination and estimate C the condition number of the matrix. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2A1 C***TYPE DOUBLE PRECISION (SGECO-S, DGECO-D, CGECO-C) C***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, C MATRIX FACTORIZATION C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C DGECO factors a double precision matrix by Gaussian elimination C and estimates the condition of the matrix. C C If RCOND is not needed, DGEFA is slightly faster. C To solve A*X = B , follow DGECO by DGESL. C To compute INVERSE(A)*C , follow DGECO by DGESL. C To compute DETERMINANT(A) , follow DGECO by DGEDI. C To compute INVERSE(A) , follow DGECO by DGEDI. C C On Entry C C A DOUBLE PRECISION(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an INTEGER vector of pivot indices. C C RCOND DOUBLE PRECISION C an estimate of the reciprocal condition of A . C For the system A*X = B , relative perturbations C in A and B of size EPSILON may cause C relative perturbations in X of size EPSILON/RCOND . C If RCOND is so small that the logical expression C 1.0 + RCOND .EQ. 1.0 C is true, then A may be singular to working C precision. In particular, RCOND is zero if C exact singularity is detected or the estimate C underflows. C C Z DOUBLE PRECISION(N) C a work vector whose contents are usually unimportant. C If A is close to a singular matrix, then Z is C an approximate null vector in the sense that C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED DASUM, DAXPY, DDOT, DGEFA, DSCAL C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DGECO INTEGER LDA,N,IPVT(*) DOUBLE PRECISION A(LDA,*),Z(*) DOUBLE PRECISION RCOND C DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L C C COMPUTE 1-NORM OF A C C***FIRST EXECUTABLE STATEMENT DGECO ANORM = 0.0D0 DO 10 J = 1, N ANORM = MAX(ANORM,DASUM(N,A(1,J),1)) 10 CONTINUE C C FACTOR C CALL DGEFA(A,LDA,N,IPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID C OVERFLOW. C C SOLVE TRANS(U)*W = E C EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE DO 100 K = 1, N IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 S = ABS(A(K,K))/ABS(EK-Z(K)) CALL DSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) IF (A(K,K) .EQ. 0.0D0) GO TO 40 WK = WK/A(K,K) WKM = WKM/A(K,K) GO TO 50 40 CONTINUE WK = 1.0D0 WKM = 1.0D0 50 CONTINUE KP1 = K + 1 IF (KP1 .GT. N) GO TO 90 DO 60 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 T = WKM - WK WK = WKM DO 70 J = KP1, N Z(J) = Z(J) + T*A(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C C SOLVE TRANS(L)*Y = W C DO 120 KB = 1, N K = N + 1 - KB IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0D0) GO TO 110 S = 1.0D0/ABS(Z(K)) CALL DSCAL(N,S,Z,1) 110 CONTINUE L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T 120 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C YNORM = 1.0D0 C C SOLVE L*V = Y C DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0D0) GO TO 130 S = 1.0D0/ABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 130 CONTINUE 140 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE U*Z = V C DO 160 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 S = ABS(A(K,K))/ABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 T = -Z(K) CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE C MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 RETURN END PDL-2.018/Lib/Slatec/slatec/dgedi.f0000644060175006010010000001043512562522364015025 0ustar chmNone*DECK DGEDI SUBROUTINE DGEDI (A, LDA, N, IPVT, DET, WORK, JOB) C***BEGIN PROLOGUE DGEDI C***PURPOSE Compute the determinant and inverse of a matrix using the C factors computed by DGECO or DGEFA. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D3A1, D2A1 C***TYPE DOUBLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C) C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C DGEDI computes the determinant and inverse of a matrix C using the factors computed by DGECO or DGEFA. C C On Entry C C A DOUBLE PRECISION(LDA, N) C the output from DGECO or DGEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from DGECO or DGEFA. C C WORK DOUBLE PRECISION(N) C work vector. Contents destroyed. C C JOB INTEGER C = 11 both determinant and inverse. C = 01 inverse only. C = 10 determinant only. C C On Return C C A inverse of original matrix if requested. C Otherwise unchanged. C C DET DOUBLE PRECISION(2) C determinant of original matrix if requested. C Otherwise not referenced. C Determinant = DET(1) * 10.0**DET(2) C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 C or DET(1) .EQ. 0.0 . C C Error Condition C C A division by zero will occur if the input factor contains C a zero on the diagonal and the inverse is requested. C It will not occur if the subroutines are called correctly C and if DGECO has set RCOND .GT. 0.0 or DGEFA has set C INFO .EQ. 0 . C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED DAXPY, DSCAL, DSWAP C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DGEDI INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),DET(2),WORK(*) C DOUBLE PRECISION T DOUBLE PRECISION TEN INTEGER I,J,K,KB,KP1,L,NM1 C***FIRST EXECUTABLE STATEMENT DGEDI C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) IF (DET(1) .EQ. 0.0D0) GO TO 60 10 IF (ABS(DET(1)) .GE. 1.0D0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(U) C IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = 1.0D0/A(K,K) T = -A(K,K) CALL DSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0D0 CALL DAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(U)*INVERSE(L) C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = 0.0D0 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL DAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dgefa.f0000644060175006010010000000676112562522364015026 0ustar chmNone*DECK DGEFA SUBROUTINE DGEFA (A, LDA, N, IPVT, INFO) C***BEGIN PROLOGUE DGEFA C***PURPOSE Factor a matrix using Gaussian elimination. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2A1 C***TYPE DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, C MATRIX FACTORIZATION C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C DGEFA factors a double precision matrix by Gaussian elimination. C C DGEFA is usually called by DGECO, but it can be called C directly with a saving in time if RCOND is not needed. C (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . C C On Entry C C A DOUBLE PRECISION(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an integer vector of pivot indices. C C INFO INTEGER C = 0 normal value. C = K if U(K,K) .EQ. 0.0 . This is not an error C condition for this subroutine, but it does C indicate that DGESL or DGEDI will divide by zero C if called. Use RCOND in DGECO for a reliable C indication of singularity. C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DGEFA INTEGER LDA,N,IPVT(*),INFO DOUBLE PRECISION A(LDA,*) C DOUBLE PRECISION T INTEGER IDAMAX,J,K,KP1,L,NM1 C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C C***FIRST EXECUTABLE STATEMENT DGEFA INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = IDAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0D0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0D0/A(K,K) CALL DSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN END PDL-2.018/Lib/Slatec/slatec/dgesl.f0000644060175006010010000001012712562522364015045 0ustar chmNone* ====================================================================== * NIST Guide to Available Math Software. * Source for module DGESL from package SLATEC. * Retrieved from CAMSUN on Sat Sep 25 04:27:36 1999. * ====================================================================== *DECK DGESL SUBROUTINE DGESL (A, LDA, N, IPVT, B, JOB) C***BEGIN PROLOGUE DGESL C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the C factors computed by DGECO or DGEFA. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2A1 C***TYPE DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C) C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C DGESL solves the double precision system C A * X = B or TRANS(A) * X = B C using the factors computed by DGECO or DGEFA. C C On Entry C C A DOUBLE PRECISION(LDA, N) C the output from DGECO or DGEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from DGECO or DGEFA. C C B DOUBLE PRECISION(N) C the right hand side vector. C C JOB INTEGER C = 0 to solve A*X = B , C = nonzero to solve TRANS(A)*X = B where C TRANS(A) is the transpose. C C On Return C C B the solution vector X . C C Error Condition C C A division by zero will occur if the input factor contains a C zero on the diagonal. Technically this indicates singularity C but it is often caused by improper arguments or improper C setting of LDA . It will not occur if the subroutines are C called correctly and if DGECO has set RCOND .GT. 0.0 C or DGEFA has set INFO .EQ. 0 . C C To compute INVERSE(A) * C where C is a matrix C with P columns C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND is too small) GO TO ... C DO 10 J = 1, P C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED DAXPY, DDOT C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DGESL INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),B(*) C DOUBLE PRECISION DDOT,T INTEGER K,KB,L,NM1 C***FIRST EXECUTABLE STATEMENT DGESL NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N T = DDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dp1vlu.f0000644060175006010010000001174612562522364015172 0ustar chmNone*DECK DP1VLU SUBROUTINE DP1VLU (L, NDER, X, YFIT, YP, A) C***BEGIN PROLOGUE DP1VLU C***PURPOSE Use the coefficients generated by DPOLFT to evaluate the C polynomial fit of degree L, along with the first NDER of C its derivatives, at a specified point. C***LIBRARY SLATEC C***CATEGORY K6 C***TYPE DOUBLE PRECISION (PVALUE-S, DP1VLU-D) C***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION C***AUTHOR Shampine, L. F., (SNLA) C Davenport, S. M., (SNLA) C***DESCRIPTION C C Abstract C C The subroutine DP1VLU uses the coefficients generated by DPOLFT C to evaluate the polynomial fit of degree L , along with the first C NDER of its derivatives, at a specified point. Computationally C stable recurrence relations are used to perform this task. C C The parameters for DP1VLU are C C Input -- ALL TYPE REAL variables are DOUBLE PRECISION C L - the degree of polynomial to be evaluated. L may be C any non-negative integer which is less than or equal C to NDEG , the highest degree polynomial provided C by DPOLFT . C NDER - the number of derivatives to be evaluated. NDER C may be 0 or any positive value. If NDER is less C than 0, it will be treated as 0. C X - the argument at which the polynomial and its C derivatives are to be evaluated. C A - work and output array containing values from last C call to DPOLFT . C C Output -- ALL TYPE REAL variables are DOUBLE PRECISION C YFIT - value of the fitting polynomial of degree L at X C YP - array containing the first through NDER derivatives C of the polynomial of degree L . YP must be C dimensioned at least NDER in the calling program. C C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, C Curve fitting by polynomials in one variable, Report C SLA-74-0270, Sandia Laboratories, June 1974. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 740601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890911 Removed unnecessary intrinsics. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900510 Convert XERRWV calls to XERMSG calls. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DP1VLU IMPLICIT DOUBLE PRECISION (A-H,O-Z) INTEGER I,IC,ILO,IN,INP1,IUP,K1,K1I,K2,K3,K3P1,K3PN,K4,K4P1,K4PN, * KC,L,LM1,LP1,MAXORD,N,NDER,NDO,NDP1,NORD DOUBLE PRECISION A(*),CC,DIF,VAL,X,YFIT,YP(*) CHARACTER*8 XERN1, XERN2 C***FIRST EXECUTABLE STATEMENT DP1VLU IF (L .LT. 0) GO TO 12 NDO = MAX(NDER,0) NDO = MIN(NDO,L) MAXORD = A(1) + 0.5D0 K1 = MAXORD + 1 K2 = K1 + MAXORD K3 = K2 + MAXORD + 2 NORD = A(K3) + 0.5D0 IF (L .GT. NORD) GO TO 11 K4 = K3 + L + 1 IF (NDER .LT. 1) GO TO 2 DO 1 I = 1,NDER 1 YP(I) = 0.0D0 2 IF (L .GE. 2) GO TO 4 IF (L .EQ. 1) GO TO 3 C C L IS 0 C VAL = A(K2+1) GO TO 10 C C L IS 1 C 3 CC = A(K2+2) VAL = A(K2+1) + (X-A(2))*CC IF (NDER .GE. 1) YP(1) = CC GO TO 10 C C L IS GREATER THAN 1 C 4 NDP1 = NDO + 1 K3P1 = K3 + 1 K4P1 = K4 + 1 LP1 = L + 1 LM1 = L - 1 ILO = K3 + 3 IUP = K4 + NDP1 DO 5 I = ILO,IUP 5 A(I) = 0.0D0 DIF = X - A(LP1) KC = K2 + LP1 A(K4P1) = A(KC) A(K3P1) = A(KC-1) + DIF*A(K4P1) A(K3+2) = A(K4P1) C C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES C DO 9 I = 1,LM1 IN = L - I INP1 = IN + 1 K1I = K1 + INP1 IC = K2 + IN DIF = X - A(INP1) VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1) IF (NDO .LE. 0) GO TO 8 DO 6 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) C C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS C DO 7 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N A(K4PN) = A(K3PN) 7 A(K3PN) = YP(N) 8 A(K4P1) = A(K3P1) 9 A(K3P1) = VAL C C NORMAL RETURN OR ABORT DUE TO ERROR C 10 YFIT = VAL RETURN C 11 WRITE (XERN1, '(I8)') L WRITE (XERN2, '(I8)') NORD CALL XERMSG ('SLATEC', 'DP1VLU', * 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // * ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // * ', COMPUTED BY DPOLFT -- EXECUTION TERMINATED.', 8, 2) RETURN C 12 CALL XERMSG ('SLATEC', 'DP1VLU', + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // + 'REQUESTED IS NEGATIVE.', 2, 2) RETURN END PDL-2.018/Lib/Slatec/slatec/dpchbs.f0000644060175006010010000002020112562522364015204 0ustar chmNone*DECK DPCHBS SUBROUTINE DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, + NDIM, KORD, IERR) C***BEGIN PROLOGUE DPCHBS C***PURPOSE Piecewise Cubic Hermite to B-Spline converter. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE DOUBLE PRECISION (PCHBS-S, DPCHBS-D) C***KEYWORDS B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION, C PIECEWISE CUBIC INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Computing and Mathematics Research Division C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C *Usage: C C INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR C PARAMETER (INCFD = ...) C DOUBLE PRECISION X(nmax), F(INCFD,nmax), D(INCFD,nmax), C * T(2*nmax+4), BCOEF(2*nmax) C C CALL DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, C * NDIM, KORD, IERR) C C *Arguments: C C N:IN is the number of data points, N.ge.2 . (not checked) C C X:IN is the real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. (not checked) C nmax, the dimension of X, must be .ge.N. C C F:IN is the real array of dependent variable values. C F(1+(I-1)*INCFD) is the value corresponding to X(I). C nmax, the second dimension of F, must be .ge.N. C C D:IN is the real array of derivative values at the data points. C D(1+(I-1)*INCFD) is the value corresponding to X(I). C nmax, the second dimension of D, must be .ge.N. C C INCFD:IN is the increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C It may have the value 1 for one-dimensional applications, C in which case F and D may be singly-subscripted arrays. C C KNOTYP:IN is a flag to control the knot sequence. C The knot sequence T is normally computed from X by putting C a double knot at each X and setting the end knot pairs C according to the value of KNOTYP: C KNOTYP = 0: Quadruple knots at X(1) and X(N). (default) C KNOTYP = 1: Replicate lengths of extreme subintervals: C T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1)) ; C T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)). C KNOTYP = 2: Periodic placement of boundary knots: C T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1)); C T(M+4) = T(M+3) = X(N) + (X(2)-X(1)) . C Here M=NDIM=2*N. C If the input value of KNOTYP is negative, however, it is C assumed that NKNOTS and T were set in a previous call. C This option is provided for improved efficiency when used C in a parametric setting. C C NKNOTS:INOUT is the number of knots. C If KNOTYP.GE.0, then NKNOTS will be set to NDIM+4. C If KNOTYP.LT.0, then NKNOTS is an input variable, and an C error return will be taken if it is not equal to NDIM+4. C C T:INOUT is the array of 2*N+4 knots for the B-representation. C If KNOTYP.GE.0, T will be returned by DPCHBS with the C interior double knots equal to the X-values and the C boundary knots set as indicated above. C If KNOTYP.LT.0, it is assumed that T was set by a C previous call to DPCHBS. (This routine does **not** C verify that T forms a legitimate knot sequence.) C C BCOEF:OUT is the array of 2*N B-spline coefficients. C C NDIM:OUT is the dimension of the B-spline space. (Set to 2*N.) C C KORD:OUT is the order of the B-spline. (Set to 4.) C C IERR:OUT is an error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -4 if KNOTYP.GT.2 . C IERR = -5 if KNOTYP.LT.0 and NKNOTS.NE.(2*N+4). C C *Description: C DPCHBS computes the B-spline representation of the PCH function C determined by N,X,F,D. To be compatible with the rest of PCHIP, C DPCHBS includes INCFD, the increment between successive values of C the F- and D-arrays. C C The output is the B-representation for the function: NKNOTS, T, C BCOEF, NDIM, KORD. C C *Caution: C Since it is assumed that the input PCH function has been C computed by one of the other routines in the package PCHIP, C input arguments N, X, INCFD are **not** checked for validity. C C *Restrictions/assumptions: C 1. N.GE.2 . (not checked) C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) C 3. INCFD.GT.0 . (not checked) C 4. KNOTYP.LE.2 . (error return if not) C *5. NKNOTS = NDIM+4 = 2*N+4 . (error return if not) C *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N . (not checked) C C * Indicates this applies only if KNOTYP.LT.0 . C C *Portability: C Argument INCFD is used only to cause the compiler to generate C efficient code for the subscript expressions (1+(I-1)*INCFD) . C The normal usage, in which DPCHBS is called with one-dimensional C arrays F and D, is probably non-Fortran 77, in the strict sense, C but it works on all systems on which DPCHBS has been tested. C C *See Also: C PCHIC, PCHIM, or PCHSP can be used to determine an interpolating C PCH function from a set of data. C The B-spline routine DBVALU can be used to evaluate the C B-representation that is output by DPCHBS. C (See BSPDOC for more information.) C C***REFERENCES F. N. Fritsch, "Representations for parametric cubic C splines," Computer Aided Geometric Design 6 (1989), C pp.79-82. C***ROUTINES CALLED DPCHKT, XERMSG C***REVISION HISTORY (YYMMDD) C 870701 DATE WRITTEN C 900405 Converted Fortran to upper case. C 900405 Removed requirement that X be dimensioned N+1. C 900406 Modified to make PCHKT a subsidiary routine to simplify C usage. In the process, added argument INCFD to be com- C patible with the rest of PCHIP. C 900410 Converted prologue to SLATEC 4.0 format. C 900410 Added calls to XERMSG and changed constant 3. to 3 to C reduce single/double differences. C 900411 Added reference. C 900430 Produced double precision version. C 900501 Corrected declarations. C 930317 Minor cosmetic changes. (FNF) C 930514 Corrected problems with dimensioning of arguments and C clarified DESCRIPTION. (FNF) C 930604 Removed NKNOTS from DPCHKT call list. (FNF) C***END PROLOGUE DPCHBS C C*Internal Notes: C C**End C C Declare arguments. C INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*) C C Declare local variables. C INTEGER K, KK DOUBLE PRECISION DOV3, HNEW, HOLD CHARACTER*8 LIBNAM, SUBNAM C***FIRST EXECUTABLE STATEMENT DPCHBS C C Initialize. C NDIM = 2*N KORD = 4 IERR = 0 LIBNAM = 'SLATEC' SUBNAM = 'DPCHBS' C C Check argument validity. Set up knot sequence if OK. C IF ( KNOTYP.GT.2 ) THEN IERR = -1 CALL XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1) RETURN ENDIF IF ( KNOTYP.LT.0 ) THEN IF ( NKNOTS.NE.NDIM+4 ) THEN IERR = -2 CALL XERMSG (LIBNAM, SUBNAM, * 'KNOTYP.LT.0 AND NKNOTS.NE.(2*N+4)', IERR, 1) RETURN ENDIF ELSE C Set up knot sequence. NKNOTS = NDIM + 4 CALL DPCHKT (N, X, KNOTYP, T) ENDIF C C Compute B-spline coefficients. C HNEW = T(3) - T(1) DO 40 K = 1, N KK = 2*K HOLD = HNEW C The following requires mixed mode arithmetic. DOV3 = D(1,K)/3 BCOEF(KK-1) = F(1,K) - HOLD*DOV3 C The following assumes T(2*K+1) = X(K). HNEW = T(KK+3) - T(KK+1) BCOEF(KK) = F(1,K) + HNEW*DOV3 40 CONTINUE C C Terminate. C RETURN C------------- LAST LINE OF DPCHBS FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchce.f0000644060175006010010000002066112562522364015201 0ustar chmNone*DECK DPCHCE SUBROUTINE DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) C***BEGIN PROLOGUE DPCHCE C***SUBSIDIARY C***PURPOSE Set boundary conditions for DPCHIC C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHCE-S, DPCHCE-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHCE: DPCHIC End Derivative Setter. C C Called by DPCHIC to set end derivatives as requested by the user. C It must be called after interior derivative values have been set. C ----- C C To facilitate two-dimensional applications, includes an increment C between successive values of the D-array. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER IC(2), N, IERR C DOUBLE PRECISION VC(2), X(N), H(N), SLOPE(N), D(INCFD,N) C C CALL DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) C C Parameters: C C IC -- (input) integer array of length 2 specifying desired C boundary conditions: C IC(1) = IBEG, desired condition at beginning of data. C IC(2) = IEND, desired condition at end of data. C ( see prologue to DPCHIC for details. ) C C VC -- (input) real*8 array of length 2 specifying desired boundary C values. VC(1) need be set only if IC(1) = 2 or 3 . C VC(2) need be set only if IC(2) = 2 or 3 . C C N -- (input) number of data points. (assumes N.GE.2) C C X -- (input) real*8 array of independent variable values. (the C elements of X are assumed to be strictly increasing.) C C H -- (input) real*8 array of interval lengths. C SLOPE -- (input) real*8 array of data slopes. C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: C H(I) = X(I+1)-X(I), C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. C C D -- (input) real*8 array of derivative values at the data points. C The value corresponding to X(I) must be stored in C D(1+(I-1)*INCFD), I=1(1)N. C (output) the value of D at X(1) and/or X(N) is changed, if C necessary, to produce the requested boundary conditions. C no other entries in D are changed. C C INCFD -- (input) increment between successive values in D. C This argument is provided primarily for 2-D applications. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning errors: C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for C monotonicity. C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be C adjusted for monotonicity. C IERR = 3 if both of the above are true. C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS. C C***SEE ALSO DPCHIC C***ROUTINES CALLED DPCHDF, DPCHST, XERMSG C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870707 Corrected XERROR calls for d.p. name(s). C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE DPCHCE C C Programming notes: C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C 2. One could reduce the number of arguments and amount of local C storage, at the expense of reduced code clarity, by passing in C the array WK (rather than splitting it into H and SLOPE) and C increasing its length enough to incorporate STEMP and XTEMP. C 3. The two monotonicity checks only use the sufficient conditions. C Thus, it is possible (but unlikely) for a boundary condition to C be changed, even though the original interpolant was monotonic. C (At least the result is a continuous function of the data.) C**End C C DECLARE ARGUMENTS. C INTEGER IC(2), N, INCFD, IERR DOUBLE PRECISION VC(2), X(*), H(*), SLOPE(*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER IBEG, IEND, IERF, INDEX, J, K DOUBLE PRECISION HALF, STEMP(3), THREE, TWO, XTEMP(4), ZERO SAVE ZERO, HALF, TWO, THREE DOUBLE PRECISION DPCHDF, DPCHST C C INITIALIZE. C DATA ZERO /0.D0/, HALF/.5D0/, TWO/2.D0/, THREE/3.D0/ C C***FIRST EXECUTABLE STATEMENT DPCHCE IBEG = IC(1) IEND = IC(2) IERR = 0 C C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. C IF ( ABS(IBEG).GT.N ) IBEG = 0 IF ( ABS(IEND).GT.N ) IEND = 0 C C TREAT BEGINNING BOUNDARY CONDITION. C IF (IBEG .EQ. 0) GO TO 2000 K = ABS(IBEG) IF (K .EQ. 1) THEN C BOUNDARY VALUE PROVIDED. D(1,1) = VC(1) ELSE IF (K .EQ. 2) THEN C BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,1) = HALF*( (THREE*SLOPE(1) - D(1,2)) - HALF*VC(1)*H(1) ) ELSE IF (K .LT. 5) THEN C USE K-POINT DERIVATIVE FORMULA. C PICK UP FIRST K POINTS, IN REVERSE ORDER. DO 10 J = 1, K INDEX = K-J+1 C INDEX RUNS FROM K DOWN TO 1. XTEMP(J) = X(INDEX) IF (J .LT. K) STEMP(J) = SLOPE(INDEX-1) 10 CONTINUE C ----------------------------- D(1,1) = DPCHDF (K, XTEMP, STEMP, IERF) C ----------------------------- IF (IERF .NE. 0) GO TO 5001 ELSE C USE 'NOT A KNOT' CONDITION. D(1,1) = ( THREE*(H(1)*SLOPE(2) + H(2)*SLOPE(1)) * - TWO*(H(1)+H(2))*D(1,2) - H(1)*D(1,3) ) / H(2) ENDIF C IF (IBEG .GT. 0) GO TO 2000 C C CHECK D(1,1) FOR COMPATIBILITY WITH MONOTONICITY. C IF (SLOPE(1) .EQ. ZERO) THEN IF (D(1,1) .NE. ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ENDIF ELSE IF ( DPCHST(D(1,1),SLOPE(1)) .LT. ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ELSE IF ( ABS(D(1,1)) .GT. THREE*ABS(SLOPE(1)) ) THEN D(1,1) = THREE*SLOPE(1) IERR = IERR + 1 ENDIF C C TREAT END BOUNDARY CONDITION. C 2000 CONTINUE IF (IEND .EQ. 0) GO TO 5000 K = ABS(IEND) IF (K .EQ. 1) THEN C BOUNDARY VALUE PROVIDED. D(1,N) = VC(2) ELSE IF (K .EQ. 2) THEN C BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,N) = HALF*( (THREE*SLOPE(N-1) - D(1,N-1)) + * HALF*VC(2)*H(N-1) ) ELSE IF (K .LT. 5) THEN C USE K-POINT DERIVATIVE FORMULA. C PICK UP LAST K POINTS. DO 2010 J = 1, K INDEX = N-K+J C INDEX RUNS FROM N+1-K UP TO N. XTEMP(J) = X(INDEX) IF (J .LT. K) STEMP(J) = SLOPE(INDEX) 2010 CONTINUE C ----------------------------- D(1,N) = DPCHDF (K, XTEMP, STEMP, IERF) C ----------------------------- IF (IERF .NE. 0) GO TO 5001 ELSE C USE 'NOT A KNOT' CONDITION. D(1,N) = ( THREE*(H(N-1)*SLOPE(N-2) + H(N-2)*SLOPE(N-1)) * - TWO*(H(N-1)+H(N-2))*D(1,N-1) - H(N-1)*D(1,N-2) ) * / H(N-2) ENDIF C IF (IEND .GT. 0) GO TO 5000 C C CHECK D(1,N) FOR COMPATIBILITY WITH MONOTONICITY. C IF (SLOPE(N-1) .EQ. ZERO) THEN IF (D(1,N) .NE. ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ENDIF ELSE IF ( DPCHST(D(1,N),SLOPE(N-1)) .LT. ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ELSE IF ( ABS(D(1,N)) .GT. THREE*ABS(SLOPE(N-1)) ) THEN D(1,N) = THREE*SLOPE(N-1) IERR = IERR + 2 ENDIF C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURN. C 5001 CONTINUE C ERROR RETURN FROM DPCHDF. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -1 CALL XERMSG ('SLATEC', 'DPCHCE', 'ERROR RETURN FROM DPCHDF', + IERR, 1) RETURN C------------- LAST LINE OF DPCHCE FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchci.f0000644060175006010010000001322112562522364015177 0ustar chmNone*DECK DPCHCI SUBROUTINE DPCHCI (N, H, SLOPE, D, INCFD) C***BEGIN PROLOGUE DPCHCI C***SUBSIDIARY C***PURPOSE Set interior derivatives for DPCHIC C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHCI-S, DPCHCI-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHCI: DPCHIC Initial Derivative Setter. C C Called by DPCHIC to set derivatives needed to determine a monotone C piecewise cubic Hermite interpolant to the data. C C Default boundary conditions are provided which are compatible C with monotonicity. If the data are only piecewise monotonic, the C interpolant will have an extremum at each point where monotonicity C switches direction. C C To facilitate two-dimensional applications, includes an increment C between successive values of the D-array. C C The resulting piecewise cubic Hermite function should be identical C (within roundoff error) to that produced by DPCHIM. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N C DOUBLE PRECISION H(N), SLOPE(N), D(INCFD,N) C C CALL DPCHCI (N, H, SLOPE, D, INCFD) C C Parameters: C C N -- (input) number of data points. C If N=2, simply does linear interpolation. C C H -- (input) real*8 array of interval lengths. C SLOPE -- (input) real*8 array of data slopes. C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: C H(I) = X(I+1)-X(I), C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. C C D -- (output) real*8 array of derivative values at data points. C If the data are monotonic, these values will determine a C a monotone cubic Hermite function. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in D. C This argument is provided primarily for 2-D applications. C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS, MAX, MIN. C C***SEE ALSO DPCHIC C***ROUTINES CALLED DPCHST C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820601 Modified end conditions to be continuous functions of C data when monotonicity switches in next interval. C 820602 1. Modified formulas so end conditions are less prone C to over/underflow problems. C 2. Minor modification to HSUM calculation. C 820805 Converted to SLATEC library version. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE DPCHCI C C Programming notes: C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD DOUBLE PRECISION H(*), SLOPE(*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER I, NLESS1 DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM, * HSUMT3, THREE, W1, W2, ZERO SAVE ZERO, THREE DOUBLE PRECISION DPCHST C C INITIALIZE. C DATA ZERO /0.D0/, THREE/3.D0/ C***FIRST EXECUTABLE STATEMENT DPCHCI NLESS1 = N - 1 DEL1 = SLOPE(1) C C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. C IF (NLESS1 .GT. 1) GO TO 10 D(1,1) = DEL1 D(1,N) = DEL1 GO TO 5000 C C NORMAL CASE (N .GE. 3). C 10 CONTINUE DEL2 = SLOPE(2) C C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C HSUM = H(1) + H(2) W1 = (H(1) + HSUM)/HSUM W2 = -H(1)/HSUM D(1,1) = W1*DEL1 + W2*DEL2 IF ( DPCHST(D(1,1),DEL1) .LE. ZERO) THEN D(1,1) = ZERO ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL1 IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX ENDIF C C LOOP THROUGH INTERIOR POINTS. C DO 50 I = 2, NLESS1 IF (I .EQ. 2) GO TO 40 C HSUM = H(I-1) + H(I) DEL1 = DEL2 DEL2 = SLOPE(I) 40 CONTINUE C C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. C D(1,I) = ZERO IF ( DPCHST(DEL1,DEL2) .LE. ZERO) GO TO 50 C C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. C HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H(I-1))/HSUMT3 W2 = (HSUM + H(I) )/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) C 50 CONTINUE C C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C W1 = -H(N-1)/HSUM W2 = (H(N-1) + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 IF ( DPCHST(D(1,N),DEL2) .LE. ZERO) THEN D(1,N) = ZERO ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL2 IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX ENDIF C C NORMAL RETURN. C 5000 CONTINUE RETURN C------------- LAST LINE OF DPCHCI FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchcm.f0000644060175006010010000002163312562522364015211 0ustar chmNone*DECK DPCHCM SUBROUTINE DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) C***BEGIN PROLOGUE DPCHCM C***PURPOSE Check a cubic Hermite function for monotonicity. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE DOUBLE PRECISION (PCHCM-S, DPCHCM-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, C PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE C***AUTHOR Fritsch, F. N., (LLNL) C Computing & Mathematics Research Division C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C *Usage: C C PARAMETER (INCFD = ...) C INTEGER N, ISMON(N), IERR C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) C LOGICAL SKIP C C CALL DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) C C *Arguments: C C N:IN is the number of data points. (Error return if N.LT.2 .) C C X:IN is a real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F:IN is a real*8 array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D:IN is a real*8 array of derivative values. D(1+(I-1)*INCFD) is C is the value corresponding to X(I). C C INCFD:IN is the increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP:INOUT is a logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed. C SKIP will be set to .TRUE. on normal return. C C ISMON:OUT is an integer array indicating on which intervals the C PCH function defined by N, X, F, D is monotonic. C For data interval [X(I),X(I+1)], C ISMON(I) = -3 if function is probably decreasing; C ISMON(I) = -1 if function is strictly decreasing; C ISMON(I) = 0 if function is constant; C ISMON(I) = 1 if function is strictly increasing; C ISMON(I) = 2 if function is non-monotonic; C ISMON(I) = 3 if function is probably increasing. C If ABS(ISMON)=3, this means that the D-values are near C the boundary of the monotonicity region. A small C increase produces non-monotonicity; decrease, strict C monotonicity. C The above applies to I=1(1)N-1. ISMON(N) indicates whether C the entire function is monotonic on [X(1),X(N)]. C C IERR:OUT is an error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C (The ISMON-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C *Description: C C DPCHCM: Piecewise Cubic Hermite -- Check Monotonicity. C C Checks the piecewise cubic Hermite function defined by N,X,F,D C for monotonicity. C C To provide compatibility with DPCHIM and DPCHIC, includes an C increment between successive values of the F- and D-arrays. C C *Cautions: C This provides the same capability as old DPCHMC, except that a C new output value, -3, was added February 1989. (Formerly, -3 C and +3 were lumped together in the single value 3.) Codes that C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. C Codes that check via "IF (ISMON.GE.3)" should change the test to C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". C C***REFERENCES F. N. Fritsch and R. E. Carlson, Monotone piecewise C cubic interpolation, SIAM Journal on Numerical Ana- C lysis 17, 2 (April 1980), pp. 238-246. C***ROUTINES CALLED DCHFCM, XERMSG C***REVISION HISTORY (YYMMDD) C 820518 DATE WRITTEN C 820804 Converted to SLATEC library version. C 831201 Reversed order of subscripts of F and D, so that the C routine will work properly when INCFD.GT.1 . (Bug!) C 870707 Corrected XERROR calls for d.p. name(s). C 890206 Corrected XERROR calls. C 890209 Added possible ISMON value of -3 and modified code so C that 1,3,-1 produces ISMON(N)=2, rather than 3. C 890306 Added caution about changed output. C 890407 Changed name from DPCHMC to DPCHCM, as requested at the C March 1989 SLATEC CML meeting, and made a few other C minor modifications necessitated by this change. C 890407 Converted to new SLATEC format. C 890407 Modified DESCRIPTION to LDOC format. C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE DPCHCM C C Fortran intrinsics used: ISIGN. C Other routines used: CHFCM, XERMSG. C C ---------------------------------------------------------------------- C C Programming notes: C C An alternate organization would have separate loops for computing C ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N). The C first loop can be readily parallelized, since the NSEG calls to C CHFCM are independent. The second loop can be cut short if C ISMON(N) is ever equal to 2, for it cannot be changed further. C C To produce a single precision version, simply: C a. Change DPCHCM to PCHCM wherever it occurs, C b. Change DCHFCM to CHFCM wherever it occurs, and C c. Change the double precision declarations to real. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, ISMON(N), IERR DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, NSEG DOUBLE PRECISION DELTA INTEGER DCHFCM C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DPCHCM IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE SKIP = .TRUE. C C FUNCTION DEFINITION IS OK -- GO ON. C 5 CONTINUE NSEG = N - 1 DO 90 I = 1, NSEG DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I)) C ------------------------------- ISMON(I) = DCHFCM (D(1,I), D(1,I+1), DELTA) C ------------------------------- IF (I .EQ. 1) THEN ISMON(N) = ISMON(1) ELSE C Need to figure out cumulative monotonicity from following C "multiplication table": C C + I S M O N (I) C + -3 -1 0 1 3 2 C +------------------------+ C I -3 I -3 -3 -3 2 2 2 I C S -1 I -3 -1 -1 2 2 2 I C M 0 I -3 -1 0 1 3 2 I C O 1 I 2 2 1 1 3 2 I C N 3 I 2 2 3 3 3 2 I C (N) 2 I 2 2 2 2 2 2 I C +------------------------+ C Note that the 2 row and column are out of order so as not C to obscure the symmetry in the rest of the table. C C No change needed if equal or constant on this interval or C already declared nonmonotonic. IF ( (ISMON(I).NE.ISMON(N)) .AND. (ISMON(I).NE.0) . .AND. (ISMON(N).NE.2) ) THEN IF ( (ISMON(I).EQ.2) .OR. (ISMON(N).EQ.0) ) THEN ISMON(N) = ISMON(I) ELSE IF (ISMON(I)*ISMON(N) .LT. 0) THEN C This interval has opposite sense from curve so far. ISMON(N) = 2 ELSE C At this point, both are nonzero with same sign, and C we have already eliminated case both +-1. ISMON(N) = ISIGN (3, ISMON(N)) ENDIF ENDIF ENDIF 90 CONTINUE C C NORMAL RETURN. C IERR = 0 RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHCM', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHCM', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHCM', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) RETURN C------------- LAST LINE OF DPCHCM FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchcs.f0000644060175006010010000002105312562522364015213 0ustar chmNone*DECK DPCHCS SUBROUTINE DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) C***BEGIN PROLOGUE DPCHCS C***SUBSIDIARY C***PURPOSE Adjusts derivative values for DPCHIC C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHCS-S, DPCHCS-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHCS: DPCHIC Monotonicity Switch Derivative Setter. C C Called by DPCHIC to adjust the values of D in the vicinity of a C switch in direction of monotonicity, to produce a more "visually C pleasing" curve than that given by DPCHIM . C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IERR C DOUBLE PRECISION SWITCH, H(N), SLOPE(N), D(INCFD,N) C C CALL DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) C C Parameters: C C SWITCH -- (input) indicates the amount of control desired over C local excursions from data. C C N -- (input) number of data points. (assumes N.GT.2 .) C C H -- (input) real*8 array of interval lengths. C SLOPE -- (input) real*8 array of data slopes. C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: C H(I) = X(I+1)-X(I), C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. C C D -- (input) real*8 array of derivative values at the data points, C as determined by DPCHCI. C (output) derivatives in the vicinity of switches in direction C of monotonicity may be adjusted to produce a more "visually C pleasing" curve. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in D. C This argument is provided primarily for 2-D applications. C C IERR -- (output) error flag. should be zero. C If negative, trouble in DPCHSW. (should never happen.) C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS, MAX, MIN. C C***SEE ALSO DPCHIC C***ROUTINES CALLED DPCHST, DPCHSW C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820617 Redesigned to (1) fix problem with lack of continuity C approaching a flat-topped peak (2) be cleaner and C easier to verify. C Eliminated subroutines PCHSA and PCHSX in the process. C 820622 1. Limited fact to not exceed one, so computed D is a C convex combination of DPCHCI value and DPCHSD value. C 2. Changed fudge from 1 to 4 (based on experiments). C 820623 Moved PCHSD to an inline function (eliminating MSWTYP). C 820805 Converted to SLATEC library version. C 870707 Corrected conversion to double precision. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Modified spacing in computation of DFLOC. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE DPCHCS C C Programming notes: C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IERR DOUBLE PRECISION SWITCH, H(*), SLOPE(*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER I, INDX, K, NLESS1 DOUBLE PRECISION DEL(3), DEXT, DFLOC, DFMX, FACT, FUDGE, ONE, * SLMAX, WTAVE(2), ZERO SAVE ZERO, ONE, FUDGE DOUBLE PRECISION DPCHST C C DEFINE INLINE FUNCTION FOR WEIGHTED AVERAGE OF SLOPES. C DOUBLE PRECISION DPCHSD, S1, S2, H1, H2 DPCHSD(S1,S2,H1,H2) = (H2/(H1+H2))*S1 + (H1/(H1+H2))*S2 C C INITIALIZE. C DATA ZERO /0.D0/, ONE/1.D0/ DATA FUDGE /4.D0/ C***FIRST EXECUTABLE STATEMENT DPCHCS IERR = 0 NLESS1 = N - 1 C C LOOP OVER SEGMENTS. C DO 900 I = 2, NLESS1 IF ( DPCHST(SLOPE(I-1),SLOPE(I)) ) 100, 300, 900 C -------------------------- C 100 CONTINUE C C....... SLOPE SWITCHES MONOTONICITY AT I-TH POINT ..................... C C DO NOT CHANGE D IF 'UP-DOWN-UP'. IF (I .GT. 2) THEN IF ( DPCHST(SLOPE(I-2),SLOPE(I)) .GT. ZERO) GO TO 900 C -------------------------- ENDIF IF (I .LT. NLESS1) THEN IF ( DPCHST(SLOPE(I+1),SLOPE(I-1)) .GT. ZERO) GO TO 900 C ---------------------------- ENDIF C C ....... COMPUTE PROVISIONAL VALUE FOR D(1,I). C DEXT = DPCHSD (SLOPE(I-1), SLOPE(I), H(I-1), H(I)) C C ....... DETERMINE WHICH INTERVAL CONTAINS THE EXTREMUM. C IF ( DPCHST(DEXT, SLOPE(I-1)) ) 200, 900, 250 C ----------------------- C 200 CONTINUE C DEXT AND SLOPE(I-1) HAVE OPPOSITE SIGNS -- C EXTREMUM IS IN (X(I-1),X(I)). K = I-1 C SET UP TO COMPUTE NEW VALUES FOR D(1,I-1) AND D(1,I). WTAVE(2) = DEXT IF (K .GT. 1) * WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) GO TO 400 C 250 CONTINUE C DEXT AND SLOPE(I) HAVE OPPOSITE SIGNS -- C EXTREMUM IS IN (X(I),X(I+1)). K = I C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = DEXT IF (K .LT. NLESS1) * WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) GO TO 400 C 300 CONTINUE C C....... AT LEAST ONE OF SLOPE(I-1) AND SLOPE(I) IS ZERO -- C CHECK FOR FLAT-TOPPED PEAK ....................... C IF (I .EQ. NLESS1) GO TO 900 IF ( DPCHST(SLOPE(I-1), SLOPE(I+1)) .GE. ZERO) GO TO 900 C ----------------------------- C C WE HAVE FLAT-TOPPED PEAK ON (X(I),X(I+1)). K = I C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) C 400 CONTINUE C C....... AT THIS POINT WE HAVE DETERMINED THAT THERE WILL BE AN EXTREMUM C ON (X(K),X(K+1)), WHERE K=I OR I-1, AND HAVE SET ARRAY WTAVE-- C WTAVE(1) IS A WEIGHTED AVERAGE OF SLOPE(K-1) AND SLOPE(K), C IF K.GT.1 C WTAVE(2) IS A WEIGHTED AVERAGE OF SLOPE(K) AND SLOPE(K+1), C IF K.LT.N-1 C SLMAX = ABS(SLOPE(K)) IF (K .GT. 1) SLMAX = MAX( SLMAX, ABS(SLOPE(K-1)) ) IF (K.LT.NLESS1) SLMAX = MAX( SLMAX, ABS(SLOPE(K+1)) ) C IF (K .GT. 1) DEL(1) = SLOPE(K-1) / SLMAX DEL(2) = SLOPE(K) / SLMAX IF (K.LT.NLESS1) DEL(3) = SLOPE(K+1) / SLMAX C IF ((K.GT.1) .AND. (K.LT.NLESS1)) THEN C NORMAL CASE -- EXTREMUM IS NOT IN A BOUNDARY INTERVAL. FACT = FUDGE* ABS(DEL(3)*(DEL(1)-DEL(2))*(WTAVE(2)/SLMAX)) D(1,K) = D(1,K) + MIN(FACT,ONE)*(WTAVE(1) - D(1,K)) FACT = FUDGE* ABS(DEL(1)*(DEL(3)-DEL(2))*(WTAVE(1)/SLMAX)) D(1,K+1) = D(1,K+1) + MIN(FACT,ONE)*(WTAVE(2) - D(1,K+1)) ELSE C SPECIAL CASE K=1 (WHICH CAN OCCUR ONLY IF I=2) OR C K=NLESS1 (WHICH CAN OCCUR ONLY IF I=NLESS1). FACT = FUDGE* ABS(DEL(2)) D(1,I) = MIN(FACT,ONE) * WTAVE(I-K+1) C NOTE THAT I-K+1 = 1 IF K=I (=NLESS1), C I-K+1 = 2 IF K=I-1(=1). ENDIF C C C....... ADJUST IF NECESSARY TO LIMIT EXCURSIONS FROM DATA. C IF (SWITCH .LE. ZERO) GO TO 900 C DFLOC = H(K)*ABS(SLOPE(K)) IF (K .GT. 1) DFLOC = MAX( DFLOC, H(K-1)*ABS(SLOPE(K-1)) ) IF (K.LT.NLESS1) DFLOC = MAX( DFLOC, H(K+1)*ABS(SLOPE(K+1)) ) DFMX = SWITCH*DFLOC INDX = I-K+1 C INDX = 1 IF K=I, 2 IF K=I-1. C --------------------------------------------------------------- CALL DPCHSW(DFMX, INDX, D(1,K), D(1,K+1), H(K), SLOPE(K), IERR) C --------------------------------------------------------------- IF (IERR .NE. 0) RETURN C C....... END OF SEGMENT LOOP. C 900 CONTINUE C RETURN C------------- LAST LINE OF DPCHCS FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchdf.f0000644060175006010010000000640212562522364015200 0ustar chmNone*DECK DPCHDF DOUBLE PRECISION FUNCTION DPCHDF (K, X, S, IERR) C***BEGIN PROLOGUE DPCHDF C***SUBSIDIARY C***PURPOSE Computes divided differences for DPCHCE and DPCHSP C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHDF-S, DPCHDF-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHDF: DPCHIP Finite Difference Formula C C Uses a divided difference formulation to compute a K-point approx- C imation to the derivative at X(K) based on the data in X and S. C C Called by DPCHCE and DPCHSP to compute 3- and 4-point boundary C derivative approximations. C C ---------------------------------------------------------------------- C C On input: C K is the order of the desired derivative approximation. C K must be at least 3 (error return if not). C X contains the K values of the independent variable. C X need not be ordered, but the values **MUST** be C distinct. (Not checked here.) C S contains the associated slope values: C S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1. C (Note that S need only be of length K-1.) C C On return: C S will be destroyed. C IERR will be set to -1 if K.LT.2 . C DPCHDF will be set to the desired derivative approximation if C IERR=0 or to zero if IERR=-1. C C ---------------------------------------------------------------------- C C***SEE ALSO DPCHCE, DPCHSP C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- C Verlag, New York, 1978, pp. 10-16. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 820503 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870707 Corrected XERROR calls for d.p. name(s). C 870813 Minor cosmetic changes. C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890411 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) C 920429 Revised format and order of references. (WRB,FNF) C 930503 Improved purpose. (FNF) C***END PROLOGUE DPCHDF C C**End C C DECLARE ARGUMENTS. C INTEGER K, IERR DOUBLE PRECISION X(K), S(K) C C DECLARE LOCAL VARIABLES. C INTEGER I, J DOUBLE PRECISION VALUE, ZERO SAVE ZERO DATA ZERO /0.D0/ C C CHECK FOR LEGAL VALUE OF K. C C***FIRST EXECUTABLE STATEMENT DPCHDF IF (K .LT. 3) GO TO 5001 C C COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. C DO 10 J = 2, K-1 DO 9 I = 1, K-J S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) 9 CONTINUE 10 CONTINUE C C EVALUATE DERIVATIVE AT X(K). C VALUE = S(1) DO 20 I = 2, K-1 VALUE = S(I) + VALUE*(X(K)-X(I)) 20 CONTINUE C C NORMAL RETURN. C IERR = 0 DPCHDF = VALUE RETURN C C ERROR RETURN. C 5001 CONTINUE C K.LT.3 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHDF', 'K LESS THAN THREE', IERR, 1) DPCHDF = ZERO RETURN C------------- LAST LINE OF DPCHDF FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchfd.f0000644060175006010010000002535112562522364015204 0ustar chmNone*DECK DPCHFD SUBROUTINE DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) C***BEGIN PROLOGUE DPCHFD C***PURPOSE Evaluate a piecewise cubic Hermite function and its first C derivative at an array of points. May be used by itself C for Hermite interpolation, or as an evaluator for DPCHIM C or DPCHIC. If only function values are required, use C DPCHFE instead. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H1 C***TYPE DOUBLE PRECISION (PCHFD-S, DPCHFD-D) C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, C HERMITE INTERPOLATION, PCHIP, PIECEWISE CUBIC EVALUATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DPCHFD: Piecewise Cubic Hermite Function and Derivative C evaluator C C Evaluates the cubic Hermite function defined by N, X, F, D, to- C gether with its first derivative, at the points XE(J), J=1(1)NE. C C If only function values are required, use DPCHFE, instead. C C To provide compatibility with DPCHIM and DPCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, NE, IERR C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE), C DE(NE) C LOGICAL SKIP C C CALL DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) C C Parameters: C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) C is the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in DPCHIM or DPCHIC). C SKIP will be set to .TRUE. on normal return. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real*8 array of points at which the functions are to C be evaluated. C C C NOTES: C 1. The evaluation will be most efficient if the elements C of XE are increasing relative to X; C that is, XE(J) .GE. X(I) C implies XE(K) .GE. X(I), all K.GE.J . C 2. If any of the XE are outside the interval [X(1),X(N)], C values are extrapolated from the nearest extreme cubic, C and a warning error is returned. C C FE -- (output) real*8 array of values of the cubic Hermite C function defined by N, X, F, D at the points XE. C C DE -- (output) real*8 array of values of the first derivative of C the same function at the points XE. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning error: C IERR.GT.0 means that extrapolation was performed at C IERR points. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if NE.LT.1 . C (Output arrays have not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C IERR = -5 if an error has occurred in the lower-level C routine DCHFDV. NB: this should never happen. C Notify the author **IMMEDIATELY** if it does. C C***REFERENCES (NONE) C***ROUTINES CALLED DCHFDV, XERMSG C***REVISION HISTORY (YYMMDD) C 811020 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 870707 Corrected XERROR calls for d.p. name(s). C 890206 Corrected XERROR calls. C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE DPCHFD C Programming notes: C C 1. To produce a single precision version, simply: C a. Change DPCHFD to PCHFD, and DCHFDV to CHFDV, wherever they C occur, C b. Change the double precision declaration to real, C C 2. Most of the coding between the call to DCHFDV and the end of C the IR-loop could be eliminated if it were permissible to C assume that XE is ordered relative to X. C C 3. DCHFDV does not assume that X1 is less than X2. thus, it would C be possible to write a version of DPCHFD that assumes a strict- C ly decreasing X-array by simply running the IR-loop backwards C (and reversing the order of appropriate tests). C C 4. The present code has a minor bug, which I have decided is not C worth the effort that would be required to fix it. C If XE contains points in [X(N-1),X(N)], followed by points .LT. C X(N-1), followed by points .GT.X(N), the extrapolation points C will be counted (at least) twice in the total returned in IERR. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, NE, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*), * DE(*) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DPCHFD IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE IF ( NE.LT.1 ) GO TO 5004 IERR = 0 SKIP = .TRUE. C C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE C C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. C IF (JFIRST .GT. NE) GO TO 5000 C C LOCATE ALL POINTS IN INTERVAL. C DO 20 J = JFIRST, NE IF (XE(J) .GE. X(IR)) GO TO 30 20 CONTINUE J = NE + 1 GO TO 40 C C HAVE LOCATED FIRST POINT BEYOND INTERVAL. C 30 CONTINUE IF (IR .EQ. N) J = NE + 1 C 40 CONTINUE NJ = J - JFIRST C C SKIP EVALUATION IF NO POINTS IN INTERVAL. C IF (NJ .EQ. 0) GO TO 50 C C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . C C ---------------------------------------------------------------- CALL DCHFDV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR) * ,NJ, XE(JFIRST), FE(JFIRST), DE(JFIRST), NEXT, IERC) C ---------------------------------------------------------------- IF (IERC .LT. 0) GO TO 5005 C IF (NEXT(2) .EQ. 0) GO TO 42 C IF (NEXT(2) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE C RIGHT OF X(IR). C IF (IR .LT. N) GO TO 41 C IF (IR .EQ. N) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) GO TO 42 41 CONTINUE C ELSE C WE SHOULD NEVER HAVE GOTTEN HERE. GO TO 5005 C ENDIF C ENDIF 42 CONTINUE C IF (NEXT(1) .EQ. 0) GO TO 49 C IF (NEXT(1) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE C LEFT OF X(IR-1). C IF (IR .GT. 2) GO TO 43 C IF (IR .EQ. 2) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) GO TO 49 43 CONTINUE C ELSE C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST C EVALUATION INTERVAL. C C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 IF (XE(I) .LT. X(IR-1)) GO TO 45 44 CONTINUE C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR C IN DCHFDV. GO TO 5005 C 45 CONTINUE C RESET J. (THIS WILL BE THE NEW JFIRST.) J = I C C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 IF (XE(J) .LT. X(I)) GO TO 47 46 CONTINUE C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). C 47 CONTINUE C AT THIS POINT, EITHER XE(J) .LT. X(1) C OR X(I-1) .LE. XE(J) .LT. X(I) . C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE C CYCLING. IR = MAX(1, I-1) C ENDIF C ENDIF 49 CONTINUE C JFIRST = J C C END OF IR-LOOP. C 50 CONTINUE IR = IR + 1 IF (IR .LE. N) GO TO 10 C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHFD', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHFD', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHFD', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) RETURN C 5004 CONTINUE C NE.LT.1 RETURN. IERR = -4 CALL XERMSG ('SLATEC', 'DPCHFD', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5005 CONTINUE C ERROR RETURN FROM DCHFDV. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 CALL XERMSG ('SLATEC', 'DPCHFD', + 'ERROR RETURN FROM DCHFDV -- FATAL', IERR, 2) RETURN C------------- LAST LINE OF DPCHFD FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchfe.f0000644060175006010010000002405012562522364015200 0ustar chmNone*DECK DPCHFE SUBROUTINE DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) C***BEGIN PROLOGUE DPCHFE C***PURPOSE Evaluate a piecewise cubic Hermite function at an array of C points. May be used by itself for Hermite interpolation, C or as an evaluator for DPCHIM or DPCHIC. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE DOUBLE PRECISION (PCHFE-S, DPCHFE-D) C***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, C PIECEWISE CUBIC EVALUATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DPCHFE: Piecewise Cubic Hermite Function Evaluator C C Evaluates the cubic Hermite function defined by N, X, F, D at C the points XE(J), J=1(1)NE. C C To provide compatibility with DPCHIM and DPCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, NE, IERR C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) C LOGICAL SKIP C C CALL DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) C C Parameters: C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) C is the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in DPCHIM or DPCHIC). C SKIP will be set to .TRUE. on normal return. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real*8 array of points at which the function is to C be evaluated. C C NOTES: C 1. The evaluation will be most efficient if the elements C of XE are increasing relative to X; C that is, XE(J) .GE. X(I) C implies XE(K) .GE. X(I), all K.GE.J . C 2. If any of the XE are outside the interval [X(1),X(N)], C values are extrapolated from the nearest extreme cubic, C and a warning error is returned. C C FE -- (output) real*8 array of values of the cubic Hermite C function defined by N, X, F, D at the points XE. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning error: C IERR.GT.0 means that extrapolation was performed at C IERR points. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if NE.LT.1 . C (The FE-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES (NONE) C***ROUTINES CALLED DCHFEV, XERMSG C***REVISION HISTORY (YYMMDD) C 811020 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 870707 Corrected XERROR calls for d.p. name(s). C 890206 Corrected XERROR calls. C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE DPCHFE C Programming notes: C C 1. To produce a single precision version, simply: C a. Change DPCHFE to PCHFE, and DCHFEV to CHFEV, wherever they C occur, C b. Change the double precision declaration to real, C C 2. Most of the coding between the call to DCHFEV and the end of C the IR-loop could be eliminated if it were permissible to C assume that XE is ordered relative to X. C C 3. DCHFEV does not assume that X1 is less than X2. thus, it would C be possible to write a version of DPCHFE that assumes a C decreasing X-array by simply running the IR-loop backwards C (and reversing the order of appropriate tests). C C 4. The present code has a minor bug, which I have decided is not C worth the effort that would be required to fix it. C If XE contains points in [X(N-1),X(N)], followed by points .LT. C X(N-1), followed by points .GT.X(N), the extrapolation points C will be counted (at least) twice in the total returned in IERR. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, NE, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DPCHFE IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE IF ( NE.LT.1 ) GO TO 5004 IERR = 0 SKIP = .TRUE. C C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE C C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. C IF (JFIRST .GT. NE) GO TO 5000 C C LOCATE ALL POINTS IN INTERVAL. C DO 20 J = JFIRST, NE IF (XE(J) .GE. X(IR)) GO TO 30 20 CONTINUE J = NE + 1 GO TO 40 C C HAVE LOCATED FIRST POINT BEYOND INTERVAL. C 30 CONTINUE IF (IR .EQ. N) J = NE + 1 C 40 CONTINUE NJ = J - JFIRST C C SKIP EVALUATION IF NO POINTS IN INTERVAL. C IF (NJ .EQ. 0) GO TO 50 C C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . C C ---------------------------------------------------------------- CALL DCHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR) * ,NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) C ---------------------------------------------------------------- IF (IERC .LT. 0) GO TO 5005 C IF (NEXT(2) .EQ. 0) GO TO 42 C IF (NEXT(2) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE C RIGHT OF X(IR). C IF (IR .LT. N) GO TO 41 C IF (IR .EQ. N) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) GO TO 42 41 CONTINUE C ELSE C WE SHOULD NEVER HAVE GOTTEN HERE. GO TO 5005 C ENDIF C ENDIF 42 CONTINUE C IF (NEXT(1) .EQ. 0) GO TO 49 C IF (NEXT(1) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE C LEFT OF X(IR-1). C IF (IR .GT. 2) GO TO 43 C IF (IR .EQ. 2) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) GO TO 49 43 CONTINUE C ELSE C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST C EVALUATION INTERVAL. C C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 IF (XE(I) .LT. X(IR-1)) GO TO 45 44 CONTINUE C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR C IN DCHFEV. GO TO 5005 C 45 CONTINUE C RESET J. (THIS WILL BE THE NEW JFIRST.) J = I C C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 IF (XE(J) .LT. X(I)) GO TO 47 46 CONTINUE C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). C 47 CONTINUE C AT THIS POINT, EITHER XE(J) .LT. X(1) C OR X(I-1) .LE. XE(J) .LT. X(I) . C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE C CYCLING. IR = MAX(1, I-1) C ENDIF C ENDIF 49 CONTINUE C JFIRST = J C C END OF IR-LOOP. C 50 CONTINUE IR = IR + 1 IF (IR .LE. N) GO TO 10 C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHFE', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHFE', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHFE', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) RETURN C 5004 CONTINUE C NE.LT.1 RETURN. IERR = -4 CALL XERMSG ('SLATEC', 'DPCHFE', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5005 CONTINUE C ERROR RETURN FROM DCHFEV. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 CALL XERMSG ('SLATEC', 'DPCHFE', + 'ERROR RETURN FROM DCHFEV -- FATAL', IERR, 2) RETURN C------------- LAST LINE OF DPCHFE FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchia.f0000644060175006010010000002322412562522364015201 0ustar chmNone*DECK DPCHIA DOUBLE PRECISION FUNCTION DPCHIA (N, X, F, D, INCFD, SKIP, A, B, + IERR) C***BEGIN PROLOGUE DPCHIA C***PURPOSE Evaluate the definite integral of a piecewise cubic C Hermite function over an arbitrary interval. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H2A1B2 C***TYPE DOUBLE PRECISION (PCHIA-S, DPCHIA-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, C QUADRATURE C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DPCHIA: Piecewise Cubic Hermite Integrator, Arbitrary limits C C Evaluates the definite integral of the cubic Hermite function C defined by N, X, F, D over the interval [A, B]. C C To provide compatibility with DPCHIM and DPCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IERR C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N), A, B C DOUBLE PRECISION VALUE, DPCHIA C LOGICAL SKIP C C VALUE = DPCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) C C Parameters: C C VALUE -- (output) value of the requested integral. C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) C is the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in DPCHIM or DPCHIC). C SKIP will be set to .TRUE. on return with IERR.GE.0 . C C A,B -- (input) the limits of integration. C NOTE: There is no requirement that [A,B] be contained in C [X(1),X(N)]. However, the resulting integral value C will be highly suspect, if not. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning errors: C IERR = 1 if A is outside the interval [X(1),X(N)]. C IERR = 2 if B is outside the interval [X(1),X(N)]. C IERR = 3 if both of the above are true. (Note that this C means that either [A,B] contains data interval C or the intervals do not intersect at all.) C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C (VALUE will be zero in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C IERR = -4 in case of an error return from DPCHID (which C should never occur). C C***REFERENCES (NONE) C***ROUTINES CALLED DCHFIE, DPCHID, XERMSG C***REVISION HISTORY (YYMMDD) C 820730 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870707 Corrected XERROR calls for d.p. name(s). C 870707 Corrected conversion to double precision. C 870813 Minor cosmetic changes. C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 930503 Corrected to set VALUE=0 when IERR.lt.0. (FNF) C 930504 Changed DCHFIV to DCHFIE. (FNF) C***END PROLOGUE DPCHIA C C Programming notes: C 1. The error flag from DPCHID is tested, because a logic flaw C could conceivably result in IERD=-4, which should be reported. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*), A, B LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IA, IB, IERD, IL, IR DOUBLE PRECISION VALUE, XA, XB, ZERO SAVE ZERO DOUBLE PRECISION DCHFIE, DPCHID C C INITIALIZE. C DATA ZERO /0.D0/ C***FIRST EXECUTABLE STATEMENT DPCHIA VALUE = ZERO C C VALIDITY-CHECK ARGUMENTS. C IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE SKIP = .TRUE. IERR = 0 IF ( (A.LT.X(1)) .OR. (A.GT.X(N)) ) IERR = IERR + 1 IF ( (B.LT.X(1)) .OR. (B.GT.X(N)) ) IERR = IERR + 2 C C COMPUTE INTEGRAL VALUE. C IF (A .NE. B) THEN XA = MIN (A, B) XB = MAX (A, B) IF (XB .LE. X(2)) THEN C INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC. C --------------------------------------- VALUE = DCHFIE (X(1),X(2), F(1,1),F(1,2), + D(1,1),D(1,2), A, B) C --------------------------------------- ELSE IF (XA .GE. X(N-1)) THEN C INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC. C ------------------------------------------ VALUE = DCHFIE(X(N-1),X(N), F(1,N-1),F(1,N), + D(1,N-1),D(1,N), A, B) C ------------------------------------------ ELSE C 'NORMAL' CASE -- XA.LT.XB, XA.LT.X(N-1), XB.GT.X(2). C ......LOCATE IA AND IB SUCH THAT C X(IA-1).LT.XA.LE.X(IA).LE.X(IB).LE.XB.LE.X(IB+1) IA = 1 DO 10 I = 1, N-1 IF (XA .GT. X(I)) IA = I + 1 10 CONTINUE C IA = 1 IMPLIES XA.LT.X(1) . OTHERWISE, C IA IS LARGEST INDEX SUCH THAT X(IA-1).LT.XA,. C IB = N DO 20 I = N, IA, -1 IF (XB .LT. X(I)) IB = I - 1 20 CONTINUE C IB = N IMPLIES XB.GT.X(N) . OTHERWISE, C IB IS SMALLEST INDEX SUCH THAT XB.LT.X(IB+1) . C C ......COMPUTE THE INTEGRAL. IF (IB .LT. IA) THEN C THIS MEANS IB = IA-1 AND C (A,B) IS A SUBSET OF (X(IB),X(IA)). C ------------------------------------------- VALUE = DCHFIE (X(IB),X(IA), F(1,IB),F(1,IA), + D(1,IB),D(1,IA), A, B) C ------------------------------------------- ELSE C C FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)). C (Case (IB .EQ. IA) is taken care of by initialization C of VALUE to ZERO.) IF (IB .GT. IA) THEN C --------------------------------------------- VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD) C --------------------------------------------- IF (IERD .LT. 0) GO TO 5004 ENDIF C C THEN ADD ON INTEGRAL OVER (XA,X(IA)). IF (XA .LT. X(IA)) THEN IL = MAX(1, IA-1) IR = IL + 1 C ------------------------------------- VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR), + D(1,IL),D(1,IR), XA, X(IA)) C ------------------------------------- ENDIF C C THEN ADD ON INTEGRAL OVER (X(IB),XB). IF (XB .GT. X(IB)) THEN IR = MIN (IB+1, N) IL = IR - 1 C ------------------------------------- VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR), + D(1,IL),D(1,IR), X(IB), XB) C ------------------------------------- ENDIF C C FINALLY, ADJUST SIGN IF NECESSARY. IF (A .GT. B) VALUE = -VALUE ENDIF ENDIF ENDIF C C NORMAL RETURN. C 5000 CONTINUE DPCHIA = VALUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHIA', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) GO TO 5000 C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHIA', 'INCREMENT LESS THAN ONE', IERR, + 1) GO TO 5000 C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHIA', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) GO TO 5000 C 5004 CONTINUE C TROUBLE IN DPCHID. (SHOULD NEVER OCCUR.) IERR = -4 CALL XERMSG ('SLATEC', 'DPCHIA', 'TROUBLE IN DPCHID', IERR, 1) GO TO 5000 C------------- LAST LINE OF DPCHIA FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchic.f0000644060175006010010000003264312562522364015210 0ustar chmNone*DECK DPCHIC SUBROUTINE DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, + IERR) C***BEGIN PROLOGUE DPCHIC C***PURPOSE Set derivatives needed to determine a piecewise monotone C piecewise cubic Hermite interpolant to given data. C User control is available over boundary conditions and/or C treatment of points where monotonicity switches direction. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E1A C***TYPE DOUBLE PRECISION (PCHIC-S, DPCHIC-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, C PCHIP, PIECEWISE CUBIC INTERPOLATION, C SHAPE-PRESERVING INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DPCHIC: Piecewise Cubic Hermite Interpolation Coefficients. C C Sets derivatives needed to determine a piecewise monotone piece- C wise cubic interpolant to the data given in X and F satisfying the C boundary conditions specified by IC and VC. C C The treatment of points where monotonicity switches direction is C controlled by argument SWITCH. C C To facilitate two-dimensional applications, includes an increment C between successive values of the F- and D-arrays. C C The resulting piecewise cubic Hermite function may be evaluated C by DPCHFE or DPCHFD. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER IC(2), N, NWK, IERR C DOUBLE PRECISION VC(2), SWITCH, X(N), F(INCFD,N), D(INCFD,N), C WK(NWK) C C CALL DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, IERR) C C Parameters: C C IC -- (input) integer array of length 2 specifying desired C boundary conditions: C IC(1) = IBEG, desired condition at beginning of data. C IC(2) = IEND, desired condition at end of data. C C IBEG = 0 for the default boundary condition (the same as C used by DPCHIM). C If IBEG.NE.0, then its sign indicates whether the boundary C derivative is to be adjusted, if necessary, to be C compatible with monotonicity: C IBEG.GT.0 if no adjustment is to be performed. C IBEG.LT.0 if the derivative is to be adjusted for C monotonicity. C C Allowable values for the magnitude of IBEG are: C IBEG = 1 if first derivative at X(1) is given in VC(1). C IBEG = 2 if second derivative at X(1) is given in VC(1). C IBEG = 3 to use the 3-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.3 .) C IBEG = 4 to use the 4-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.4 .) C IBEG = 5 to set D(1) so that the second derivative is con- C tinuous at X(2). (Reverts to the default b.c. if N.LT.4.) C This option is somewhat analogous to the "not a knot" C boundary condition provided by DPCHSP. C C NOTES (IBEG): C 1. An error return is taken if ABS(IBEG).GT.5 . C 2. Only in case IBEG.LE.0 is it guaranteed that the C interpolant will be monotonic in the first interval. C If the returned value of D(1) lies between zero and C 3*SLOPE(1), the interpolant will be monotonic. This C is **NOT** checked if IBEG.GT.0 . C 3. If IBEG.LT.0 and D(1) had to be changed to achieve mono- C tonicity, a warning error is returned. C C IEND may take on the same values as IBEG, but applied to C derivative at X(N). In case IEND = 1 or 2, the value is C given in VC(2). C C NOTES (IEND): C 1. An error return is taken if ABS(IEND).GT.5 . C 2. Only in case IEND.LE.0 is it guaranteed that the C interpolant will be monotonic in the last interval. C If the returned value of D(1+(N-1)*INCFD) lies between C zero and 3*SLOPE(N-1), the interpolant will be monotonic. C This is **NOT** checked if IEND.GT.0 . C 3. If IEND.LT.0 and D(1+(N-1)*INCFD) had to be changed to C achieve monotonicity, a warning error is returned. C C VC -- (input) real*8 array of length 2 specifying desired boundary C values, as indicated above. C VC(1) need be set only if IC(1) = 1 or 2 . C VC(2) need be set only if IC(2) = 1 or 2 . C C SWITCH -- (input) indicates desired treatment of points where C direction of monotonicity switches: C Set SWITCH to zero if interpolant is required to be mono- C tonic in each interval, regardless of monotonicity of data. C NOTES: C 1. This will cause D to be set to zero at all switch C points, thus forcing extrema there. C 2. The result of using this option with the default boun- C dary conditions will be identical to using DPCHIM, but C will generally cost more compute time. C This option is provided only to facilitate comparison C of different switch and/or boundary conditions. C Set SWITCH nonzero to use a formula based on the 3-point C difference formula in the vicinity of switch points. C If SWITCH is positive, the interpolant on each interval C containing an extremum is controlled to not deviate from C the data by more than SWITCH*DFLOC, where DFLOC is the C maximum of the change of F on this interval and its two C immediate neighbors. C If SWITCH is negative, no such control is to be imposed. C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real*8 array of dependent variable values to be C interpolated. F(1+(I-1)*INCFD) is value corresponding to C X(I). C C D -- (output) real*8 array of derivative values at the data C points. These values will determine a monotone cubic C Hermite function on each subinterval on which the data C are monotonic, except possibly adjacent to switches in C monotonicity. The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C (Error return if INCFD.LT.1 .) C C WK -- (scratch) real*8 array of working storage. The user may C wish to know that the returned values are: C WK(I) = H(I) = X(I+1) - X(I) ; C WK(N-1+I) = SLOPE(I) = (F(1,I+1) - F(1,I)) / H(I) C for I = 1(1)N-1. C C NWK -- (input) length of work array. C (Error return if NWK.LT.2*(N-1) .) C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning errors: C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for C monotonicity. C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be C adjusted for monotonicity. C IERR = 3 if both of the above are true. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if ABS(IBEG).GT.5 . C IERR = -5 if ABS(IEND).GT.5 . C IERR = -6 if both of the above are true. C IERR = -7 if NWK.LT.2*(N-1) . C (The D-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES 1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation C Package, Report UCRL-87285, Lawrence Livermore Natio- C nal Laboratory, July 1982. [Poster presented at the C SIAM 30th Anniversary Meeting, 19-23 July 1982.] C 2. F. N. Fritsch and J. Butland, A method for construc- C ting local monotone piecewise cubic interpolants, SIAM C Journal on Scientific and Statistical Computing 5, 2 C (June 1984), pp. 300-304. C 3. F. N. Fritsch and R. E. Carlson, Monotone piecewise C cubic interpolation, SIAM Journal on Numerical Ana- C lysis 17, 2 (April 1980), pp. 238-246. C***ROUTINES CALLED DPCHCE, DPCHCI, DPCHCS, XERMSG C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870707 Corrected XERROR calls for d.p. name(s). C 870813 Updated Reference 2. C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE DPCHIC C Programming notes: C C To produce a single precision version, simply: C a. Change DPCHIC to PCHIC wherever it occurs, C b. Change DPCHCE to PCHCE wherever it occurs, C c. Change DPCHCI to PCHCI wherever it occurs, C d. Change DPCHCS to PCHCS wherever it occurs, C e. Change the double precision declarations to real, and C f. Change the constant ZERO to single precision. C C DECLARE ARGUMENTS. C INTEGER IC(2), N, INCFD, NWK, IERR DOUBLE PRECISION VC(2), SWITCH, X(*), F(INCFD,*), D(INCFD,*), * WK(NWK) C C DECLARE LOCAL VARIABLES. C INTEGER I, IBEG, IEND, NLESS1 DOUBLE PRECISION ZERO SAVE ZERO DATA ZERO /0.D0/ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DPCHIC IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C IBEG = IC(1) IEND = IC(2) IERR = 0 IF (ABS(IBEG) .GT. 5) IERR = IERR - 1 IF (ABS(IEND) .GT. 5) IERR = IERR - 2 IF (IERR .LT. 0) GO TO 5004 C C FUNCTION DEFINITION IS OK -- GO ON. C NLESS1 = N - 1 IF ( NWK .LT. 2*NLESS1 ) GO TO 5007 C C SET UP H AND SLOPE ARRAYS. C DO 20 I = 1, NLESS1 WK(I) = X(I+1) - X(I) WK(NLESS1+I) = (F(1,I+1) - F(1,I)) / WK(I) 20 CONTINUE C C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. C IF (NLESS1 .GT. 1) GO TO 1000 D(1,1) = WK(2) D(1,N) = WK(2) GO TO 3000 C C NORMAL CASE (N .GE. 3) . C 1000 CONTINUE C C SET INTERIOR DERIVATIVES AND DEFAULT END CONDITIONS. C C -------------------------------------- CALL DPCHCI (N, WK(1), WK(N), D, INCFD) C -------------------------------------- C C SET DERIVATIVES AT POINTS WHERE MONOTONICITY SWITCHES DIRECTION. C IF (SWITCH .EQ. ZERO) GO TO 3000 C ---------------------------------------------------- CALL DPCHCS (SWITCH, N, WK(1), WK(N), D, INCFD, IERR) C ---------------------------------------------------- IF (IERR .NE. 0) GO TO 5008 C C SET END CONDITIONS. C 3000 CONTINUE IF ( (IBEG.EQ.0) .AND. (IEND.EQ.0) ) GO TO 5000 C ------------------------------------------------------- CALL DPCHCE (IC, VC, N, X, WK(1), WK(N), D, INCFD, IERR) C ------------------------------------------------------- IF (IERR .LT. 0) GO TO 5009 C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHIC', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHIC', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHIC', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) RETURN C 5004 CONTINUE C IC OUT OF RANGE RETURN. IERR = IERR - 3 CALL XERMSG ('SLATEC', 'DPCHIC', 'IC OUT OF RANGE', IERR, 1) RETURN C 5007 CONTINUE C NWK .LT. 2*(N-1) RETURN. IERR = -7 CALL XERMSG ('SLATEC', 'DPCHIC', 'WORK ARRAY TOO SMALL', IERR, 1) RETURN C 5008 CONTINUE C ERROR RETURN FROM DPCHCS. IERR = -8 CALL XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCS', + IERR, 1) RETURN C 5009 CONTINUE C ERROR RETURN FROM DPCHCE. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 CALL XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCE', + IERR, 1) RETURN C------------- LAST LINE OF DPCHIC FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchid.f0000644060175006010010000001423112562522364015202 0ustar chmNone*DECK DPCHID DOUBLE PRECISION FUNCTION DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, + IERR) C***BEGIN PROLOGUE DPCHID C***PURPOSE Evaluate the definite integral of a piecewise cubic C Hermite function over an interval whose endpoints are data C points. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H2A1B2 C***TYPE DOUBLE PRECISION (PCHID-S, DPCHID-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, C QUADRATURE C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DPCHID: Piecewise Cubic Hermite Integrator, Data limits C C Evaluates the definite integral of the cubic Hermite function C defined by N, X, F, D over the interval [X(IA), X(IB)]. C C To provide compatibility with DPCHIM and DPCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IA, IB, IERR C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) C LOGICAL SKIP C C VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) C C Parameters: C C VALUE -- (output) value of the requested integral. C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real*8 array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real*8 array of derivative values. D(1+(I-1)*INCFD) C is the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in DPCHIM or DPCHIC). C SKIP will be set to .TRUE. on return with IERR = 0 or -4. C C IA,IB -- (input) indices in X-array for the limits of integration. C both must be in the range [1,N]. (Error return if not.) C No restrictions on their relative values. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if IA or IB is out of range. C (VALUE will be zero in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 820723 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870707 Corrected XERROR calls for d.p. name(s). C 870813 Minor cosmetic changes. C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 930504 Corrected to set VALUE=0 when IERR.ne.0. (FNF) C***END PROLOGUE DPCHID C C Programming notes: C 1. This routine uses a special formula that is valid only for C integrals whose limits coincide with data values. This is C mathematically equivalent to, but much more efficient than, C calls to DCHFIE. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IA, IB, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IUP, LOW DOUBLE PRECISION H, HALF, SIX, SUM, VALUE, ZERO SAVE ZERO, HALF, SIX C C INITIALIZE. C DATA ZERO /0.D0/, HALF/.5D0/, SIX/6.D0/ C***FIRST EXECUTABLE STATEMENT DPCHID VALUE = ZERO C C VALIDITY-CHECK ARGUMENTS. C IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE SKIP = .TRUE. IF ((IA.LT.1) .OR. (IA.GT.N)) GO TO 5004 IF ((IB.LT.1) .OR. (IB.GT.N)) GO TO 5004 IERR = 0 C C COMPUTE INTEGRAL VALUE. C IF (IA .NE. IB) THEN LOW = MIN(IA, IB) IUP = MAX(IA, IB) - 1 SUM = ZERO DO 10 I = LOW, IUP H = X(I+1) - X(I) SUM = SUM + H*( (F(1,I) + F(1,I+1)) + * (D(1,I) - D(1,I+1))*(H/SIX) ) 10 CONTINUE VALUE = HALF * SUM IF (IA .GT. IB) VALUE = -VALUE ENDIF C C NORMAL RETURN. C 5000 CONTINUE DPCHID = VALUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHID', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) GO TO 5000 C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHID', 'INCREMENT LESS THAN ONE', IERR, + 1) GO TO 5000 C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHID', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) GO TO 5000 C 5004 CONTINUE C IA OR IB OUT OF RANGE RETURN. IERR = -4 CALL XERMSG ('SLATEC', 'DPCHID', 'IA OR IB OUT OF RANGE', IERR, + 1) GO TO 5000 C------------- LAST LINE OF DPCHID FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchim.f0000644060175006010010000002327412562522364015222 0ustar chmNone*DECK DPCHIM SUBROUTINE DPCHIM (N, X, F, D, INCFD, IERR) C***BEGIN PROLOGUE DPCHIM C***PURPOSE Set derivatives needed to determine a monotone piecewise C cubic Hermite interpolant to given data. Boundary values C are provided which are compatible with monotonicity. The C interpolant will have an extremum at each point where mono- C tonicity switches direction. (See DPCHIC if user control C is desired over boundary or switch conditions.) C***LIBRARY SLATEC (PCHIP) C***CATEGORY E1A C***TYPE DOUBLE PRECISION (PCHIM-S, DPCHIM-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, C PCHIP, PIECEWISE CUBIC INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DPCHIM: Piecewise Cubic Hermite Interpolation to C Monotone data. C C Sets derivatives needed to determine a monotone piecewise cubic C Hermite interpolant to the data given in X and F. C C Default boundary conditions are provided which are compatible C with monotonicity. (See DPCHIC if user control of boundary con- C ditions is desired.) C C If the data are only piecewise monotonic, the interpolant will C have an extremum at each point where monotonicity switches direc- C tion. (See DPCHIC if user control is desired in such cases.) C C To facilitate two-dimensional applications, includes an increment C between successive values of the F- and D-arrays. C C The resulting piecewise cubic Hermite function may be evaluated C by DPCHFE or DPCHFD. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IERR C DOUBLE PRECISION X(N), F(INCFD,N), D(INCFD,N) C C CALL DPCHIM (N, X, F, D, INCFD, IERR) C C Parameters: C C N -- (input) number of data points. (Error return if N.LT.2 .) C If N=2, simply does linear interpolation. C C X -- (input) real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real*8 array of dependent variable values to be C interpolated. F(1+(I-1)*INCFD) is value corresponding to C X(I). DPCHIM is designed for monotonic data, but it will C work for any F-array. It will force extrema at points where C monotonicity switches direction. If some other treatment of C switch points is desired, DPCHIC should be used instead. C ----- C D -- (output) real*8 array of derivative values at the data C points. If the data are monotonic, these values will C determine a monotone cubic Hermite function. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C (Error return if INCFD.LT.1 .) C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning error: C IERR.GT.0 means that IERR switches in the direction C of monotonicity were detected. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C (The D-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- C ting local monotone piecewise cubic interpolants, SIAM C Journal on Scientific and Statistical Computing 5, 2 C (June 1984), pp. 300-304. C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise C cubic interpolation, SIAM Journal on Numerical Ana- C lysis 17, 2 (April 1980), pp. 238-246. C***ROUTINES CALLED DPCHST, XERMSG C***REVISION HISTORY (YYMMDD) C 811103 DATE WRITTEN C 820201 1. Introduced DPCHST to reduce possible over/under- C flow problems. C 2. Rearranged derivative formula for same reason. C 820602 1. Modified end conditions to be continuous functions C of data when monotonicity switches in next interval. C 2. Modified formulas so end conditions are less prone C of over/underflow problems. C 820803 Minor cosmetic changes for release 1. C 870707 Corrected XERROR calls for d.p. name(s). C 870813 Updated Reference 1. C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE DPCHIM C Programming notes: C C 1. The function DPCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C 2. To produce a single precision version, simply: C a. Change DPCHIM to PCHIM wherever it occurs, C b. Change DPCHST to PCHST wherever it occurs, C c. Change all references to the Fortran intrinsics to their C single precision equivalents, C d. Change the double precision declarations to real, and C e. Change the constants ZERO and THREE to single precision. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IERR DOUBLE PRECISION X(*), F(INCFD,*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER I, NLESS1 DOUBLE PRECISION DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO SAVE ZERO, THREE DOUBLE PRECISION DPCHST DATA ZERO /0.D0/, THREE/3.D0/ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DPCHIM IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C IERR = 0 NLESS1 = N - 1 H1 = X(2) - X(1) DEL1 = (F(1,2) - F(1,1))/H1 DSAVE = DEL1 C C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. C IF (NLESS1 .GT. 1) GO TO 10 D(1,1) = DEL1 D(1,N) = DEL1 GO TO 5000 C C NORMAL CASE (N .GE. 3). C 10 CONTINUE H2 = X(3) - X(2) DEL2 = (F(1,3) - F(1,2))/H2 C C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C HSUM = H1 + H2 W1 = (H1 + HSUM)/HSUM W2 = -H1/HSUM D(1,1) = W1*DEL1 + W2*DEL2 IF ( DPCHST(D(1,1),DEL1) .LE. ZERO) THEN D(1,1) = ZERO ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL1 IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX ENDIF C C LOOP THROUGH INTERIOR POINTS. C DO 50 I = 2, NLESS1 IF (I .EQ. 2) GO TO 40 C H1 = H2 H2 = X(I+1) - X(I) HSUM = H1 + H2 DEL1 = DEL2 DEL2 = (F(1,I+1) - F(1,I))/H2 40 CONTINUE C C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. C D(1,I) = ZERO IF ( DPCHST(DEL1,DEL2) ) 42, 41, 45 C C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. C 41 CONTINUE IF (DEL2 .EQ. ZERO) GO TO 50 IF ( DPCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 DSAVE = DEL2 GO TO 50 C 42 CONTINUE IERR = IERR + 1 DSAVE = DEL2 GO TO 50 C C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. C 45 CONTINUE HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H1)/HSUMT3 W2 = (HSUM + H2)/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) C 50 CONTINUE C C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C W1 = -H2/HSUM W2 = (H2 + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 IF ( DPCHST(D(1,N),DEL2) .LE. ZERO) THEN D(1,N) = ZERO ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL2 IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX ENDIF C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHIM', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHIM', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHIM', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) RETURN C------------- LAST LINE OF DPCHIM FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchkt.f0000644060175006010010000000501712562522364015226 0ustar chmNone*DECK DPCHKT SUBROUTINE DPCHKT (N, X, KNOTYP, T) C***BEGIN PROLOGUE DPCHKT C***SUBSIDIARY C***PURPOSE Compute B-spline knot sequence for DPCHBS. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE DOUBLE PRECISION (PCHKT-S, DPCHKT-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C Set a knot sequence for the B-spline representation of a PCH C function with breakpoints X. All knots will be at least double. C Endknots are set as: C (1) quadruple knots at endpoints if KNOTYP=0; C (2) extrapolate the length of end interval if KNOTYP=1; C (3) periodic if KNOTYP=2. C C Input arguments: N, X, KNOTYP. C Output arguments: T. C C Restrictions/assumptions: C 1. N.GE.2 . (not checked) C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) C 3. 0.LE.KNOTYP.LE.2 . (Acts like KNOTYP=0 for any other value.) C C***SEE ALSO DPCHBS C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 870701 DATE WRITTEN C 900405 Converted Fortran to upper case. C 900410 Converted prologue to SLATEC 4.0 format. C 900410 Minor cosmetic changes. C 900430 Produced double precision version. C 930514 Changed NKNOTS from an output to an input variable. (FNF) C 930604 Removed unused variable NKNOTS from argument list. (FNF) C***END PROLOGUE DPCHKT C C*Internal Notes: C C Since this is subsidiary to DPCHBS, which validates its input before C calling, it is unnecessary for such validation to be done here. C C**End C C Declare arguments. C INTEGER N, KNOTYP DOUBLE PRECISION X(*), T(*) C C Declare local variables. C INTEGER J, K, NDIM DOUBLE PRECISION HBEG, HEND C***FIRST EXECUTABLE STATEMENT DPCHKT C C Initialize. C NDIM = 2*N C C Set interior knots. C J = 1 DO 20 K = 1, N J = J + 2 T(J) = X(K) T(J+1) = T(J) 20 CONTINUE C Assertion: At this point T(3),...,T(NDIM+2) have been set and C J=NDIM+1. C C Set end knots according to KNOTYP. C HBEG = X(2) - X(1) HEND = X(N) - X(N-1) IF (KNOTYP.EQ.1 ) THEN C Extrapolate. T(2) = X(1) - HBEG T(NDIM+3) = X(N) + HEND ELSE IF ( KNOTYP.EQ.2 ) THEN C Periodic. T(2) = X(1) - HEND T(NDIM+3) = X(N) + HBEG ELSE C Quadruple end knots. T(2) = X(1) T(NDIM+3) = X(N) ENDIF T(1) = T(2) T(NDIM+4) = T(NDIM+3) C C Terminate. C RETURN C------------- LAST LINE OF DPCHKT FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchsp.f0000644060175006010010000003345212562522364015236 0ustar chmNone*DECK DPCHSP SUBROUTINE DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) C***BEGIN PROLOGUE DPCHSP C***PURPOSE Set derivatives needed to determine the Hermite represen- C tation of the cubic spline interpolant to given data, with C specified boundary conditions. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E1A C***TYPE DOUBLE PRECISION (PCHSP-S, DPCHSP-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, PCHIP, C PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C DPCHSP: Piecewise Cubic Hermite Spline C C Computes the Hermite representation of the cubic spline inter- C polant to the data given in X and F satisfying the boundary C conditions specified by IC and VC. C C To facilitate two-dimensional applications, includes an increment C between successive values of the F- and D-arrays. C C The resulting piecewise cubic Hermite function may be evaluated C by DPCHFE or DPCHFD. C C NOTE: This is a modified version of C. de Boor's cubic spline C routine CUBSPL. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER IC(2), N, NWK, IERR C DOUBLE PRECISION VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK) C C CALL DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) C C Parameters: C C IC -- (input) integer array of length 2 specifying desired C boundary conditions: C IC(1) = IBEG, desired condition at beginning of data. C IC(2) = IEND, desired condition at end of data. C C IBEG = 0 to set D(1) so that the third derivative is con- C tinuous at X(2). This is the "not a knot" condition C provided by de Boor's cubic spline routine CUBSPL. C < This is the default boundary condition. > C IBEG = 1 if first derivative at X(1) is given in VC(1). C IBEG = 2 if second derivative at X(1) is given in VC(1). C IBEG = 3 to use the 3-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.3 .) C IBEG = 4 to use the 4-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.4 .) C NOTES: C 1. An error return is taken if IBEG is out of range. C 2. For the "natural" boundary condition, use IBEG=2 and C VC(1)=0. C C IEND may take on the same values as IBEG, but applied to C derivative at X(N). In case IEND = 1 or 2, the value is C given in VC(2). C C NOTES: C 1. An error return is taken if IEND is out of range. C 2. For the "natural" boundary condition, use IEND=2 and C VC(2)=0. C C VC -- (input) real*8 array of length 2 specifying desired boundary C values, as indicated above. C VC(1) need be set only if IC(1) = 1 or 2 . C VC(2) need be set only if IC(2) = 1 or 2 . C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real*8 array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real*8 array of dependent variable values to be C interpolated. F(1+(I-1)*INCFD) is value corresponding to C X(I). C C D -- (output) real*8 array of derivative values at the data C points. These values will determine the cubic spline C interpolant with the requested boundary conditions. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C (Error return if INCFD.LT.1 .) C C WK -- (scratch) real*8 array of working storage. C C NWK -- (input) length of work array. C (Error return if NWK.LT.2*N .) C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if IBEG.LT.0 or IBEG.GT.4 . C IERR = -5 if IEND.LT.0 of IEND.GT.4 . C IERR = -6 if both of the above are true. C IERR = -7 if NWK is too small. C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C (The D-array has not been changed in any of these cases.) C IERR = -8 in case of trouble solving the linear system C for the interior derivative values. C (The D-array may have been changed in this case.) C ( Do **NOT** use it! ) C C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- C Verlag, New York, 1978, pp. 53-59. C***ROUTINES CALLED DPCHDF, XERMSG C***REVISION HISTORY (YYMMDD) C 820503 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870707 Corrected XERROR calls for d.p. name(s). C 890206 Corrected XERROR calls. C 890411 Added SAVE statements (Vers. 3.2). C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE DPCHSP C Programming notes: C C To produce a single precision version, simply: C a. Change DPCHSP to PCHSP wherever it occurs, C b. Change the double precision declarations to real, and C c. Change the constants ZERO, HALF, ... to single precision. C C DECLARE ARGUMENTS. C INTEGER IC(2), N, INCFD, NWK, IERR DOUBLE PRECISION VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*) C C DECLARE LOCAL VARIABLES. C INTEGER IBEG, IEND, INDEX, J, NM1 DOUBLE PRECISION G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), * ZERO SAVE ZERO, HALF, ONE, TWO, THREE DOUBLE PRECISION DPCHDF C DATA ZERO /0.D0/, HALF/.5D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT DPCHSP IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 J = 2, N IF ( X(J).LE.X(J-1) ) GO TO 5003 1 CONTINUE C IBEG = IC(1) IEND = IC(2) IERR = 0 IF ( (IBEG.LT.0).OR.(IBEG.GT.4) ) IERR = IERR - 1 IF ( (IEND.LT.0).OR.(IEND.GT.4) ) IERR = IERR - 2 IF ( IERR.LT.0 ) GO TO 5004 C C FUNCTION DEFINITION IS OK -- GO ON. C IF ( NWK .LT. 2*N ) GO TO 5007 C C COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, C COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). DO 5 J=2,N WK(1,J) = X(J) - X(J-1) WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) 5 CONTINUE C C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. C IF ( IBEG.GT.N ) IBEG = 0 IF ( IEND.GT.N ) IEND = 0 C C SET UP FOR BOUNDARY CONDITIONS. C IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) ) THEN D(1,1) = VC(1) ELSE IF (IBEG .GT. 2) THEN C PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. DO 10 J = 1, IBEG INDEX = IBEG-J+1 C INDEX RUNS FROM IBEG DOWN TO 1. XTEMP(J) = X(INDEX) IF (J .LT. IBEG) STEMP(J) = WK(2,INDEX) 10 CONTINUE C -------------------------------- D(1,1) = DPCHDF (IBEG, XTEMP, STEMP, IERR) C -------------------------------- IF (IERR .NE. 0) GO TO 5009 IBEG = 1 ENDIF C IF ( (IEND.EQ.1).OR.(IEND.EQ.2) ) THEN D(1,N) = VC(2) ELSE IF (IEND .GT. 2) THEN C PICK UP LAST IEND POINTS. DO 15 J = 1, IEND INDEX = N-IEND+J C INDEX RUNS FROM N+1-IEND UP TO N. XTEMP(J) = X(INDEX) IF (J .LT. IEND) STEMP(J) = WK(2,INDEX+1) 15 CONTINUE C -------------------------------- D(1,N) = DPCHDF (IEND, XTEMP, STEMP, IERR) C -------------------------------- IF (IERR .NE. 0) GO TO 5009 IEND = 1 ENDIF C C --------------------( BEGIN CODING FROM CUBSPL )-------------------- C C **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF C F AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM- C INATION, WITH S(J) ENDING UP IN D(1,J), ALL J. C WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE. C C CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM C WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) C IF (IBEG .EQ. 0) THEN IF (N .EQ. 2) THEN C NO CONDITION AT LEFT END AND N = 2. WK(2,1) = ONE WK(1,1) = ONE D(1,1) = TWO*WK(2,2) ELSE C NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2. WK(2,1) = WK(1,3) WK(1,1) = WK(1,2) + WK(1,3) D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) * + WK(1,2)**2*WK(2,3)) / WK(1,1) ENDIF ELSE IF (IBEG .EQ. 1) THEN C SLOPE PRESCRIBED AT LEFT END. WK(2,1) = ONE WK(1,1) = ZERO ELSE C SECOND DERIVATIVE PRESCRIBED AT LEFT END. WK(2,1) = TWO WK(1,1) = ONE D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1) ENDIF C C IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND C CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH C EQUATION READS WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J). C NM1 = N-1 IF (NM1 .GT. 1) THEN DO 20 J=2,NM1 IF (WK(2,J-1) .EQ. ZERO) GO TO 5008 G = -WK(1,J+1)/WK(2,J-1) D(1,J) = G*D(1,J-1) * + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) 20 CONTINUE ENDIF C C CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM C (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N) C C IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK- C SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT C AT THIS POINT. IF (IEND .EQ. 1) GO TO 30 C IF (IEND .EQ. 0) THEN IF (N.EQ.2 .AND. IBEG.EQ.0) THEN C NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. D(1,2) = WK(2,2) GO TO 30 ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0)) THEN C EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* C NOT-A-KNOT AT LEFT END POINT). D(1,N) = TWO*WK(2,N) WK(2,N) = ONE IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 G = -ONE/WK(2,N-1) ELSE C NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR ALSO NOT-A- C KNOT AT LEFT END POINT. G = WK(1,N-1) + WK(1,N) C DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES). D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) * + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 G = -G/WK(2,N-1) WK(2,N) = WK(1,N-1) ENDIF ELSE C SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT. D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) WK(2,N) = TWO IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 G = -ONE/WK(2,N-1) ENDIF C C COMPLETE FORWARD PASS OF GAUSS ELIMINATION. C WK(2,N) = G*WK(1,N-1) + WK(2,N) IF (WK(2,N) .EQ. ZERO) GO TO 5008 D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) C C CARRY OUT BACK SUBSTITUTION C 30 CONTINUE DO 40 J=NM1,1,-1 IF (WK(2,J) .EQ. ZERO) GO TO 5008 D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) 40 CONTINUE C --------------------( END CODING FROM CUBSPL )-------------------- C C NORMAL RETURN. C RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHSP', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'DPCHSP', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'DPCHSP', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) RETURN C 5004 CONTINUE C IC OUT OF RANGE RETURN. IERR = IERR - 3 CALL XERMSG ('SLATEC', 'DPCHSP', 'IC OUT OF RANGE', IERR, 1) RETURN C 5007 CONTINUE C NWK TOO SMALL RETURN. IERR = -7 CALL XERMSG ('SLATEC', 'DPCHSP', 'WORK ARRAY TOO SMALL', IERR, 1) RETURN C 5008 CONTINUE C SINGULAR SYSTEM. C *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES *** C *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). *** IERR = -8 CALL XERMSG ('SLATEC', 'DPCHSP', 'SINGULAR LINEAR SYSTEM', IERR, + 1) RETURN C 5009 CONTINUE C ERROR RETURN FROM DPCHDF. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 CALL XERMSG ('SLATEC', 'DPCHSP', 'ERROR RETURN FROM DPCHDF', + IERR, 1) RETURN C------------- LAST LINE OF DPCHSP FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchst.f0000644060175006010010000000325612562522364015241 0ustar chmNone*DECK DPCHST DOUBLE PRECISION FUNCTION DPCHST (ARG1, ARG2) C***BEGIN PROLOGUE DPCHST C***SUBSIDIARY C***PURPOSE DPCHIP Sign-Testing Routine C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHST-S, DPCHST-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHST: DPCHIP Sign-Testing Routine. C C C Returns: C -1. if ARG1 and ARG2 are of opposite sign. C 0. if either argument is zero. C +1. if ARG1 and ARG2 are of the same sign. C C The object is to do this without multiplying ARG1*ARG2, to avoid C possible over/underflow problems. C C Fortran intrinsics used: SIGN. C C***SEE ALSO DPCHCE, DPCHCI, DPCHCS, DPCHIM C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 811103 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE DPCHST C C**End C C DECLARE ARGUMENTS. C DOUBLE PRECISION ARG1, ARG2 C C DECLARE LOCAL VARIABLES. C DOUBLE PRECISION ONE, ZERO SAVE ZERO, ONE DATA ZERO /0.D0/, ONE/1.D0/ C C PERFORM THE TEST. C C***FIRST EXECUTABLE STATEMENT DPCHST DPCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) DPCHST = ZERO C RETURN C------------- LAST LINE OF DPCHST FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpchsw.f0000644060175006010010000001452712562522364015247 0ustar chmNone*DECK DPCHSW SUBROUTINE DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) C***BEGIN PROLOGUE DPCHSW C***SUBSIDIARY C***PURPOSE Limits excursion from data for DPCHCS C***LIBRARY SLATEC (PCHIP) C***TYPE DOUBLE PRECISION (PCHSW-S, DPCHSW-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C DPCHSW: DPCHCS Switch Excursion Limiter. C C Called by DPCHCS to adjust D1 and D2 if necessary to insure that C the extremum on this interval is not further than DFMAX from the C extreme data value. C C ---------------------------------------------------------------------- C C Calling sequence: C C INTEGER IEXTRM, IERR C DOUBLE PRECISION DFMAX, D1, D2, H, SLOPE C C CALL DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) C C Parameters: C C DFMAX -- (input) maximum allowed difference between F(IEXTRM) and C the cubic determined by derivative values D1,D2. (assumes C DFMAX.GT.0.) C C IEXTRM -- (input) index of the extreme data value. (assumes C IEXTRM = 1 or 2 . Any value .NE.1 is treated as 2.) C C D1,D2 -- (input) derivative values at the ends of the interval. C (Assumes D1*D2 .LE. 0.) C (output) may be modified if necessary to meet the restriction C imposed by DFMAX. C C H -- (input) interval length. (Assumes H.GT.0.) C C SLOPE -- (input) data slope on the interval. C C IERR -- (output) error flag. should be zero. C If IERR=-1, assumption on D1 and D2 is not satisfied. C If IERR=-2, quadratic equation locating extremum has C negative discriminant (should never occur). C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS, SIGN, SQRT. C C***SEE ALSO DPCHCS C***ROUTINES CALLED D1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870707 Corrected XERROR calls for d.p. name(s). C 870707 Replaced DATA statement for SMALL with a use of D1MACH. C 870813 Minor cosmetic changes. C 890206 Corrected XERROR calls. C 890411 1. Added SAVE statements (Vers. 3.2). C 2. Added DOUBLE PRECISION declaration for D1MACH. C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) C 920526 Eliminated possible divide by zero problem. (FNF) C 930503 Improved purpose. (FNF) C***END PROLOGUE DPCHSW C C**End C C DECLARE ARGUMENTS. C INTEGER IEXTRM, IERR DOUBLE PRECISION DFMAX, D1, D2, H, SLOPE C C DECLARE LOCAL VARIABLES. C DOUBLE PRECISION CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL, * RHO, SIGMA, SMALL, THAT, THIRD, THREE, TWO, ZERO SAVE ZERO, ONE, TWO, THREE, FACT SAVE THIRD DOUBLE PRECISION D1MACH C DATA ZERO /0.D0/, ONE /1.D0/, TWO /2.D0/, THREE /3.D0/, * FACT /100.D0/ C THIRD SHOULD BE SLIGHTLY LESS THAN 1/3. DATA THIRD /0.33333D0/ C C NOTATION AND GENERAL REMARKS. C C RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED. C LAMBDA IS THE RATIO OF D2 TO D1. C THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM. C PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO), C WHERE THAT = (XHAT - X1)/H . C THAT IS, P(XHAT)-F1 = D*H*PHI, WHERE D=D1 OR D2. C SIMILARLY, P(XHAT)-F2 = D*H*(PHI-RHO) . C C SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS. C***FIRST EXECUTABLE STATEMENT DPCHSW SMALL = FACT*D1MACH(4) C C DO MAIN CALCULATION. C IF (D1 .EQ. ZERO) THEN C C SPECIAL CASE -- D1.EQ.ZERO . C C IF D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED. IF (D2 .EQ. ZERO) GO TO 5001 C RHO = SLOPE/D2 C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . IF (RHO .GE. THIRD) GO TO 5000 THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE)) PHI = THAT**2 * ((THREE*RHO-ONE)/THREE) C C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . IF (IEXTRM .NE. 1) PHI = PHI - RHO C C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) IF (HPHI*ABS(D2) .GT. DFMAX) THEN C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. D2 = SIGN (DFMAX/HPHI, D2) ENDIF ELSE C RHO = SLOPE/D1 LAMBDA = -D2/D1 IF (D2 .EQ. ZERO) THEN C C SPECIAL CASE -- D2.EQ.ZERO . C C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . IF (RHO .GE. THIRD) GO TO 5000 CP = TWO - THREE*RHO NU = ONE - TWO*RHO THAT = ONE / (THREE*NU) ELSE IF (LAMBDA .LE. ZERO) GO TO 5001 C C NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS. C NU = ONE - LAMBDA - TWO*RHO SIGMA = ONE - RHO CP = NU + SIGMA IF (ABS(NU) .GT. SMALL) THEN RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2 IF (RADCAL .LT. ZERO) GO TO 5002 THAT = (CP - SQRT(RADCAL)) / (THREE*NU) ELSE THAT = ONE/(TWO*SIGMA) ENDIF ENDIF PHI = THAT*((NU*THAT - CP)*THAT + ONE) C C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . IF (IEXTRM .NE. 1) PHI = PHI - RHO C C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) IF (HPHI*ABS(D1) .GT. DFMAX) THEN C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. D1 = SIGN (DFMAX/HPHI, D1) D2 = -LAMBDA*D1 ENDIF ENDIF C C NORMAL RETURN. C 5000 CONTINUE IERR = 0 RETURN C C ERROR RETURNS. C 5001 CONTINUE C D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN. IERR = -1 CALL XERMSG ('SLATEC', 'DPCHSW', 'D1 AND/OR D2 INVALID', IERR, 1) RETURN C 5002 CONTINUE C NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR). IERR = -2 CALL XERMSG ('SLATEC', 'DPCHSW', 'NEGATIVE RADICAL', IERR, 1) RETURN C------------- LAST LINE OF DPCHSW FOLLOWS ----------------------------- END PDL-2.018/Lib/Slatec/slatec/dpcoef.f0000644060175006010010000000613512562522364015213 0ustar chmNone*DECK DPCOEF SUBROUTINE DPCOEF (L, C, TC, A) C***BEGIN PROLOGUE DPCOEF C***PURPOSE Convert the DPOLFT coefficients to Taylor series form. C***LIBRARY SLATEC C***CATEGORY K1A1A2 C***TYPE DOUBLE PRECISION (PCOEF-S, DPCOEF-D) C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT C***AUTHOR Shampine, L. F., (SNLA) C Davenport, S. M., (SNLA) C***DESCRIPTION C C Abstract C C DPOLFT computes the least squares polynomial fit of degree L as C a sum of orthogonal polynomials. DPCOEF changes this fit to its C Taylor expansion about any point C , i.e. writes the polynomial C as a sum of powers of (X-C). Taking C=0. gives the polynomial C in powers of X, but a suitable non-zero C often leads to C polynomials which are better scaled and more accurately evaluated. C C The parameters for DPCOEF are C C INPUT -- All TYPE REAL variables are DOUBLE PRECISION C L - Indicates the degree of polynomial to be changed to C its Taylor expansion. To obtain the Taylor C coefficients in reverse order, input L as the C negative of the degree desired. The absolute value C of L must be less than or equal to NDEG, the highest C degree polynomial fitted by DPOLFT . C C - The point about which the Taylor expansion is to be C made. C A - Work and output array containing values from last C call to DPOLFT . C C OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION C TC - Vector containing the first LL+1 Taylor coefficients C where LL=ABS(L). If L.GT.0 , the coefficients are C in the usual Taylor series order, i.e. C P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N C If L .LT. 0, the coefficients are in reverse order, C i.e. C P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) C C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, C Curve fitting by polynomials in one variable, Report C SLA-74-0270, Sandia Laboratories, June 1974. C***ROUTINES CALLED DP1VLU C***REVISION HISTORY (YYMMDD) C 740601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DPCOEF C INTEGER I,L,LL,LLP1,LLP2,NEW,NR DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*) C***FIRST EXECUTABLE STATEMENT DPCOEF LL = ABS(L) LLP1 = LL + 1 CALL DP1VLU (LL,LL,C,TC(1),TC(2),A) IF (LL .LT. 2) GO TO 2 FAC = 1.0D0 DO 1 I = 3,LLP1 FAC = FAC*(I-1) 1 TC(I) = TC(I)/FAC 2 IF (L .GE. 0) GO TO 4 NR = LLP1/2 LLP2 = LL + 2 DO 3 I = 1,NR SAVE = TC(I) NEW = LLP2 - I TC(I) = TC(NEW) 3 TC(NEW) = SAVE 4 RETURN END PDL-2.018/Lib/Slatec/slatec/dpoco.f0000644060175006010010000001542212562522364015056 0ustar chmNone*DECK DPOCO SUBROUTINE DPOCO (A, LDA, N, RCOND, Z, INFO) C***BEGIN PROLOGUE DPOCO C***PURPOSE Factor a real symmetric positive definite matrix C and estimate the condition of the matrix. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2B1B C***TYPE DOUBLE PRECISION (SPOCO-S, DPOCO-D, CPOCO-C) C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, C MATRIX FACTORIZATION, POSITIVE DEFINITE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C DPOCO factors a double precision symmetric positive definite C matrix and estimates the condition of the matrix. C C If RCOND is not needed, DPOFA is slightly faster. C To solve A*X = B , follow DPOCO by DPOSL. C To compute INVERSE(A)*C , follow DPOCO by DPOSL. C To compute DETERMINANT(A) , follow DPOCO by DPODI. C To compute INVERSE(A) , follow DPOCO by DPODI. C C On Entry C C A DOUBLE PRECISION(LDA, N) C the symmetric matrix to be factored. Only the C diagonal and upper triangle are used. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix R so that A = TRANS(R)*R C where TRANS(R) is the transpose. C The strict lower triangle is unaltered. C If INFO .NE. 0 , the factorization is not complete. C C RCOND DOUBLE PRECISION C an estimate of the reciprocal condition of A . C For the system A*X = B , relative perturbations C in A and B of size EPSILON may cause C relative perturbations in X of size EPSILON/RCOND . C If RCOND is so small that the logical expression C 1.0 + RCOND .EQ. 1.0 C is true, then A may be singular to working C precision. In particular, RCOND is zero if C exact singularity is detected or the estimate C underflows. If INFO .NE. 0 , RCOND is unchanged. C C Z DOUBLE PRECISION(N) C a work vector whose contents are usually unimportant. C If A is close to a singular matrix, then Z is C an approximate null vector in the sense that C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C If INFO .NE. 0 , Z is unchanged. C C INFO INTEGER C = 0 for normal return. C = K signals an error condition. The leading minor C of order K is not positive definite. C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED DASUM, DAXPY, DDOT, DPOFA, DSCAL C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DPOCO INTEGER LDA,N,INFO DOUBLE PRECISION A(LDA,*),Z(*) DOUBLE PRECISION RCOND C DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER I,J,JM1,K,KB,KP1 C C FIND NORM OF A USING ONLY UPPER HALF C C***FIRST EXECUTABLE STATEMENT DPOCO DO 30 J = 1, N Z(J) = DASUM(J,A(1,J),1) JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 I = 1, JM1 Z(I) = Z(I) + ABS(A(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0D0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE C C FACTOR C CALL DPOFA(A,LDA,N,INFO) IF (INFO .NE. 0) GO TO 180 C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C C SOLVE TRANS(R)*W = E C EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE DO 110 K = 1, N IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. A(K,K)) GO TO 60 S = A(K,K)/ABS(EK-Z(K)) CALL DSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/A(K,K) WKM = WKM/A(K,K) KP1 = K + 1 IF (KP1 .GT. N) GO TO 100 DO 70 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 70 CONTINUE IF (S .GE. SM) GO TO 90 T = WKM - WK WK = WKM DO 80 J = KP1, N Z(J) = Z(J) + T*A(K,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C C SOLVE R*Y = W C DO 130 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. A(K,K)) GO TO 120 S = A(K,K)/ABS(Z(K)) CALL DSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) 130 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C YNORM = 1.0D0 C C SOLVE TRANS(R)*V = Y C DO 150 K = 1, N Z(K) = Z(K) - DDOT(K-1,A(1,K),1,Z(1),1) IF (ABS(Z(K)) .LE. A(K,K)) GO TO 140 S = A(K,K)/ABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/A(K,K) 150 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE R*Z = V C DO 170 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. A(K,K)) GO TO 160 S = A(K,K)/ABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) 170 CONTINUE C MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 180 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dpodi.f0000644060175006010010000001052112562522364015044 0ustar chmNone*DECK DPODI SUBROUTINE DPODI (A, LDA, N, DET, JOB) C***BEGIN PROLOGUE DPODI C***PURPOSE Compute the determinant and inverse of a certain real C symmetric positive definite matrix using the factors C computed by DPOCO, DPOFA or DQRDC. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2B1B, D3B1B C***TYPE DOUBLE PRECISION (SPODI-S, DPODI-D, CPODI-C) C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, C POSITIVE DEFINITE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C DPODI computes the determinant and inverse of a certain C double precision symmetric positive definite matrix (see below) C using the factors computed by DPOCO, DPOFA or DQRDC. C C On Entry C C A DOUBLE PRECISION(LDA, N) C the output A from DPOCO or DPOFA C or the output X from DQRDC. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C JOB INTEGER C = 11 both determinant and inverse. C = 01 inverse only. C = 10 determinant only. C C On Return C C A If DPOCO or DPOFA was used to factor A , then C DPODI produces the upper half of INVERSE(A) . C If DQRDC was used to decompose X , then C DPODI produces the upper half of inverse(TRANS(X)*X) C where TRANS(X) is the transpose. C Elements of A below the diagonal are unchanged. C If the units digit of JOB is zero, A is unchanged. C C DET DOUBLE PRECISION(2) C determinant of A or of TRANS(X)*X if requested. C Otherwise not referenced. C Determinant = DET(1) * 10.0**DET(2) C with 1.0 .LE. DET(1) .LT. 10.0 C or DET(1) .EQ. 0.0 . C C Error Condition C C A division by zero will occur if the input factor contains C a zero on the diagonal and the inverse is requested. C It will not occur if the subroutines are called correctly C and if DPOCO or DPOFA has set INFO .EQ. 0 . C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED DAXPY, DSCAL C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DPODI INTEGER LDA,N,JOB DOUBLE PRECISION A(LDA,*) DOUBLE PRECISION DET(2) C DOUBLE PRECISION T DOUBLE PRECISION S INTEGER I,J,JM1,K,KP1 C***FIRST EXECUTABLE STATEMENT DPODI C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0D0 DET(2) = 0.0D0 S = 10.0D0 DO 50 I = 1, N DET(1) = A(I,I)**2*DET(1) IF (DET(1) .EQ. 0.0D0) GO TO 60 10 IF (DET(1) .GE. 1.0D0) GO TO 20 DET(1) = S*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (DET(1) .LT. S) GO TO 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0D0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(R) C IF (MOD(JOB,10) .EQ. 0) GO TO 140 DO 100 K = 1, N A(K,K) = 1.0D0/A(K,K) T = -A(K,K) CALL DSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0D0 CALL DAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(R) * TRANS(INVERSE(R)) C DO 130 J = 1, N JM1 = J - 1 IF (JM1 .LT. 1) GO TO 120 DO 110 K = 1, JM1 T = A(K,J) CALL DAXPY(K,T,A(1,J),1,A(1,K),1) 110 CONTINUE 120 CONTINUE T = A(J,J) CALL DSCAL(J,T,A(1,J),1) 130 CONTINUE 140 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dpofa.f0000644060175006010010000000527412562522364015047 0ustar chmNone*DECK DPOFA SUBROUTINE DPOFA (A, LDA, N, INFO) C***BEGIN PROLOGUE DPOFA C***PURPOSE Factor a real symmetric positive definite matrix. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2B1B C***TYPE DOUBLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C) C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, C POSITIVE DEFINITE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C DPOFA factors a double precision symmetric positive definite C matrix. C C DPOFA is usually called by DPOCO, but it can be called C directly with a saving in time if RCOND is not needed. C (time for DPOCO) = (1 + 18/N)*(time for DPOFA) . C C On Entry C C A DOUBLE PRECISION(LDA, N) C the symmetric matrix to be factored. Only the C diagonal and upper triangle are used. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix R so that A = TRANS(R)*R C where TRANS(R) is the transpose. C The strict lower triangle is unaltered. C If INFO .NE. 0 , the factorization is not complete. C C INFO INTEGER C = 0 for normal return. C = K signals an error condition. The leading minor C of order K is not positive definite. C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED DDOT C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DPOFA INTEGER LDA,N,INFO DOUBLE PRECISION A(LDA,*) C DOUBLE PRECISION DDOT,T DOUBLE PRECISION S INTEGER J,JM1,K C***FIRST EXECUTABLE STATEMENT DPOFA DO 30 J = 1, N INFO = J S = 0.0D0 JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 K = 1, JM1 T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) T = T/A(K,K) A(K,J) = T S = S + T*T 10 CONTINUE 20 CONTINUE S = A(J,J) - S IF (S .LE. 0.0D0) GO TO 40 A(J,J) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dpolft.f0000644060175006010010000003121612562522364015241 0ustar chmNone*DECK DPOLFT SUBROUTINE DPOLFT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) C***BEGIN PROLOGUE DPOLFT C***PURPOSE Fit discrete data in a least squares sense by polynomials C in one variable. C***LIBRARY SLATEC C***CATEGORY K1A1A2 C***TYPE DOUBLE PRECISION (POLFIT-S, DPOLFT-D) C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT C***AUTHOR Shampine, L. F., (SNLA) C Davenport, S. M., (SNLA) C Huddleston, R. E., (SNLL) C***DESCRIPTION C C Abstract C C Given a collection of points X(I) and a set of values Y(I) which C correspond to some function or measurement at each of the X(I), C subroutine DPOLFT computes the weighted least-squares polynomial C fits of all degrees up to some degree either specified by the user C or determined by the routine. The fits thus obtained are in C orthogonal polynomial form. Subroutine DP1VLU may then be C called to evaluate the fitted polynomials and any of their C derivatives at any point. The subroutine DPCOEF may be used to C express the polynomial fits as powers of (X-C) for any specified C point C. C C The parameters for DPOLFT are C C Input -- All TYPE REAL variables are DOUBLE PRECISION C N - the number of data points. The arrays X, Y and W C must be dimensioned at least N (N .GE. 1). C X - array of values of the independent variable. These C values may appear in any order and need not all be C distinct. C Y - array of corresponding function values. C W - array of positive values to be used as weights. If C W(1) is negative, DPOLFT will set all the weights C to 1.0, which means unweighted least squares error C will be minimized. To minimize relative error, the C user should set the weights to: W(I) = 1.0/Y(I)**2, C I = 1,...,N . C MAXDEG - maximum degree to be allowed for polynomial fit. C MAXDEG may be any non-negative integer less than N. C Note -- MAXDEG cannot be equal to N-1 when a C statistical test is to be used for degree selection, C i.e., when input value of EPS is negative. C EPS - specifies the criterion to be used in determining C the degree of fit to be computed. C (1) If EPS is input negative, DPOLFT chooses the C degree based on a statistical F test of C significance. One of three possible C significance levels will be used: .01, .05 or C .10. If EPS=-1.0 , the routine will C automatically select one of these levels based C on the number of data points and the maximum C degree to be considered. If EPS is input as C -.01, -.05, or -.10, a significance level of C .01, .05, or .10, respectively, will be used. C (2) If EPS is set to 0., DPOLFT computes the C polynomials of degrees 0 through MAXDEG . C (3) If EPS is input positive, EPS is the RMS C error tolerance which must be satisfied by the C fitted polynomial. DPOLFT will increase the C degree of fit until this criterion is met or C until the maximum degree is reached. C C Output -- All TYPE REAL variables are DOUBLE PRECISION C NDEG - degree of the highest degree fit computed. C EPS - RMS error of the polynomial of degree NDEG . C R - vector of dimension at least NDEG containing values C of the fit of degree NDEG at each of the X(I) . C Except when the statistical test is used, these C values are more accurate than results from subroutine C DP1VLU normally are. C IERR - error flag with the following possible values. C 1 -- indicates normal execution, i.e., either C (1) the input value of EPS was negative, and the C computed polynomial fit of degree NDEG C satisfies the specified F test, or C (2) the input value of EPS was 0., and the fits of C all degrees up to MAXDEG are complete, or C (3) the input value of EPS was positive, and the C polynomial of degree NDEG satisfies the RMS C error requirement. C 2 -- invalid input parameter. At least one of the input C parameters has an illegal value and must be corrected C before DPOLFT can proceed. Valid input results C when the following restrictions are observed C N .GE. 1 C 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. C 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. C W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . C 3 -- cannot satisfy the RMS error requirement with a C polynomial of degree no greater than MAXDEG . Best C fit found is of degree MAXDEG . C 4 -- cannot satisfy the test for significance using C current value of MAXDEG . Statistically, the C best fit found is of order NORD . (In this case, C NDEG will have one of the values: MAXDEG-2, C MAXDEG-1, or MAXDEG). Using a higher value of C MAXDEG may result in passing the test. C A - work and output array having at least 3N+3MAXDEG+3 C locations C C Note - DPOLFT calculates all fits of degrees up to and including C NDEG . Any or all of these fits can be evaluated or C expressed as powers of (X-C) using DP1VLU and DPCOEF C after just one call to DPOLFT . C C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, C Curve fitting by polynomials in one variable, Report C SLA-74-0270, Sandia Laboratories, June 1974. C***ROUTINES CALLED DP1VLU, XERMSG C***REVISION HISTORY (YYMMDD) C 740601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891006 Cosmetic changes to prologue. (WRB) C 891006 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900911 Added variable YP to DOUBLE PRECISION declaration. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C 920527 Corrected erroneous statements in DESCRIPTION. (WRB) C***END PROLOGUE DPOLFT INTEGER I,IDEGF,IERR,J,JP1,JPAS,K1,K1PJ,K2,K2PJ,K3,K3PI,K4, * K4PI,K5,K5PI,KSIG,M,MAXDEG,MOP1,NDEG,NDER,NFAIL DOUBLE PRECISION TEMD1,TEMD2 DOUBLE PRECISION A(*),DEGF,DEN,EPS,ETST,F,FCRIT,R(*),SIG,SIGJ, * SIGJM1,SIGPAS,TEMP,X(*),XM,Y(*),YP,W(*),W1,W11 DOUBLE PRECISION CO(4,3) SAVE CO DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), 2 CO(4,3)/-13.086850D0,-2.4648165D0,-3.3846535D0,-1.2973162D0, 3 -3.3381146D0,-1.7812271D0,-3.2578406D0,-1.6589279D0, 4 -1.6282703D0,-1.3152745D0,-3.2640179D0,-1.9829776D0/ C***FIRST EXECUTABLE STATEMENT DPOLFT M = ABS(N) IF (M .EQ. 0) GO TO 30 IF (MAXDEG .LT. 0) GO TO 30 A(1) = MAXDEG MOP1 = MAXDEG + 1 IF (M .LT. MOP1) GO TO 30 IF (EPS .LT. 0.0D0 .AND. M .EQ. MOP1) GO TO 30 XM = M ETST = EPS*EPS*XM IF (W(1) .LT. 0.0D0) GO TO 2 DO 1 I = 1,M IF (W(I) .LE. 0.0D0) GO TO 30 1 CONTINUE GO TO 4 2 DO 3 I = 1,M 3 W(I) = 1.0D0 4 IF (EPS .GE. 0.0D0) GO TO 8 C C DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR C CHOOSING DEGREE OF POLYNOMIAL FIT C IF (EPS .GT. (-.55D0)) GO TO 5 IDEGF = M - MAXDEG - 1 KSIG = 1 IF (IDEGF .LT. 10) KSIG = 2 IF (IDEGF .LT. 5) KSIG = 3 GO TO 8 5 KSIG = 1 IF (EPS .LT. (-.03D0)) KSIG = 2 IF (EPS .LT. (-.07D0)) KSIG = 3 C C INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING C 8 K1 = MAXDEG + 1 K2 = K1 + MAXDEG K3 = K2 + MAXDEG + 2 K4 = K3 + M K5 = K4 + M DO 9 I = 2,K4 9 A(I) = 0.0D0 W11 = 0.0D0 IF (N .LT. 0) GO TO 11 C C UNCONSTRAINED CASE C DO 10 I = 1,M K4PI = K4 + I A(K4PI) = 1.0D0 10 W11 = W11 + W(I) GO TO 13 C C CONSTRAINED CASE C 11 DO 12 I = 1,M K4PI = K4 + I 12 W11 = W11 + W(I)*A(K4PI)**2 C C COMPUTE FIT OF DEGREE ZERO C 13 TEMD1 = 0.0D0 DO 14 I = 1,M K4PI = K4 + I TEMD1 = TEMD1 + W(I)*Y(I)*A(K4PI) 14 CONTINUE TEMD1 = TEMD1/W11 A(K2+1) = TEMD1 SIGJ = 0.0D0 DO 15 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = TEMD1*A(K4PI) R(I) = TEMD2 A(K5PI) = TEMD2 - R(I) 15 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 J = 0 C C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION C IF (EPS) 24,26,27 C C INCREMENT DEGREE C 16 J = J + 1 JP1 = J + 1 K1PJ = K1 + J K2PJ = K2 + J SIGJM1 = SIGJ C C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 C IF (J .GT. 1) A(K1PJ) = W11/W1 C C COMPUTE NEW A COEFFICIENT C TEMD1 = 0.0D0 DO 18 I = 1,M K4PI = K4 + I TEMD2 = A(K4PI) TEMD1 = TEMD1 + X(I)*W(I)*TEMD2*TEMD2 18 CONTINUE A(JP1) = TEMD1/W11 C C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS C W1 = W11 W11 = 0.0D0 DO 19 I = 1,M K3PI = K3 + I K4PI = K4 + I TEMP = A(K3PI) A(K3PI) = A(K4PI) A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP 19 W11 = W11 + W(I)*A(K4PI)**2 C C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE C PRECISION C TEMD1 = 0.0D0 DO 20 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = W(I)*((Y(I)-R(I))-A(K5PI))*A(K4PI) 20 TEMD1 = TEMD1 + TEMD2 TEMD1 = TEMD1/W11 A(K2PJ+1) = TEMD1 C C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND C ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE C COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, C THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST C SIGNIFICANT BITS ARE IN A(K5PI) . C SIGJ = 0.0D0 DO 21 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = R(I) + A(K5PI) + TEMD1*A(K4PI) R(I) = TEMD2 A(K5PI) = TEMD2 - R(I) 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 C C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE C MAXDEG HAS BEEN REACHED C IF (EPS) 23,26,27 C C COMPUTE F STATISTICS (INPUT EPS .LT. 0.) C 23 IF (SIGJ .EQ. 0.0D0) GO TO 29 DEGF = M - J - 1 DEN = (CO(4,KSIG)*DEGF + 1.0D0)*DEGF FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN FCRIT = FCRIT*FCRIT F = (SIGJM1 - SIGJ)*DEGF/SIGJ IF (F .LT. FCRIT) GO TO 25 C C POLYNOMIAL OF DEGREE J SATISFIES F TEST C 24 SIGPAS = SIGJ JPAS = J NFAIL = 0 IF (MAXDEG .EQ. J) GO TO 32 GO TO 16 C C POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. C 25 NFAIL = NFAIL + 1 IF (NFAIL .GE. 3) GO TO 29 IF (MAXDEG .EQ. J) GO TO 32 GO TO 16 C C RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT C EPS = 0.) C 26 IF (MAXDEG .EQ. J) GO TO 28 GO TO 16 C C SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) C 27 IF (SIGJ .LE. ETST) GO TO 28 IF (MAXDEG .EQ. J) GO TO 31 GO TO 16 C C RETURNS C 28 IERR = 1 NDEG = J SIG = SIGJ GO TO 33 29 IERR = 1 NDEG = JPAS SIG = SIGPAS GO TO 33 30 IERR = 2 CALL XERMSG ('SLATEC', 'DPOLFT', 'INVALID INPUT PARAMETER.', 2, + 1) GO TO 37 31 IERR = 3 NDEG = MAXDEG SIG = SIGJ GO TO 33 32 IERR = 4 NDEG = JPAS SIG = SIGPAS C 33 A(K3) = NDEG C C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT C ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES C IF(EPS .GE. 0.0 .OR. NDEG .EQ. MAXDEG) GO TO 36 NDER = 0 DO 35 I = 1,M CALL DP1VLU (NDEG,NDER,X(I),R(I),YP,A) 35 CONTINUE 36 EPS = SQRT(SIG/XM) 37 RETURN END PDL-2.018/Lib/Slatec/slatec/dscal.f0000644060175006010010000000470312562522364015040 0ustar chmNone*DECK DSCAL SUBROUTINE DSCAL (N, DA, DX, INCX) C***BEGIN PROLOGUE DSCAL C***PURPOSE Multiply a vector by a constant. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A6 C***TYPE DOUBLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C DA double precision scale factor C DX double precision vector with N elements C INCX storage spacing between elements of DX C C --Output-- C DX double precision result (unchanged if N.LE.0) C C Replace double precision DX by double precision DA*DX. C For I = 0 to N-1, replace DX(IX+I*INCX) with DA * DX(IX+I*INCX), C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900821 Modified to correct problem with a negative increment. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DSCAL DOUBLE PRECISION DA, DX(*) INTEGER I, INCX, IX, M, MP1, N C***FIRST EXECUTABLE STATEMENT DSCAL IF (N .LE. 0) RETURN IF (INCX .EQ. 1) GOTO 20 C C Code for increment not equal to 1. C IX = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N DX(IX) = DA*DX(IX) IX = IX + INCX 10 CONTINUE RETURN C C Code for increment equal to 1. C C Clean-up loop so remaining vector length is a multiple of 5. C 20 M = MOD(N,5) IF (M .EQ. 0) GOTO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF (N .LT. 5) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I+1) = DA*DX(I+1) DX(I+2) = DA*DX(I+2) DX(I+3) = DA*DX(I+3) DX(I+4) = DA*DX(I+4) 50 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/dswap.f0000644060175006010010000000605212562522364015067 0ustar chmNone*DECK DSWAP SUBROUTINE DSWAP (N, DX, INCX, DY, INCY) C***BEGIN PROLOGUE DSWAP C***PURPOSE Interchange two vectors. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A5 C***TYPE DOUBLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) C***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C DX double precision vector with N elements C INCX storage spacing between elements of DX C DY double precision vector with N elements C INCY storage spacing between elements of DY C C --Output-- C DX input vector DY (unchanged if N .LE. 0) C DY input vector DX (unchanged if N .LE. 0) C C Interchange double precision DX and double precision DY. C For I = 0 to N-1, interchange DX(LX+I*INCX) and DY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is C defined in a similar way using INCY. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Corrected definition of LX in DESCRIPTION. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE DSWAP DOUBLE PRECISION DX(*), DY(*), DTEMP1, DTEMP2, DTEMP3 C***FIRST EXECUTABLE STATEMENT DSWAP IF (N .LE. 0) RETURN IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 C C Code for unequal or nonpositive increments. C 5 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP1 = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C Code for both increments equal to 1. C C Clean-up loop so remaining vector length is a multiple of 3. C 20 M = MOD(N,3) IF (M .EQ. 0) GO TO 40 DO 30 I = 1,M DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 30 CONTINUE IF (N .LT. 3) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 DTEMP1 = DX(I) DTEMP2 = DX(I+1) DTEMP3 = DX(I+2) DX(I) = DY(I) DX(I+1) = DY(I+1) DX(I+2) = DY(I+2) DY(I) = DTEMP1 DY(I+1) = DTEMP2 DY(I+2) = DTEMP3 50 CONTINUE RETURN C C Code for equal, positive, non-unit increments. C 60 NS = N*INCX DO 70 I = 1,NS,INCX DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 70 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/ezfft1.f0000644060175006010010000000504512562522364015151 0ustar chmNone*DECK EZFFT1 SUBROUTINE EZFFT1 (N, WA, IFAC) C***BEGIN PROLOGUE EZFFT1 C***SUBSIDIARY C***PURPOSE EZFFTI calls EZFFT1 with appropriate work array C partitioning. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (EZFFT1-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing references to intrinsic function FLOAT C to REAL, and C (c) changing definition of variable TPI by using C FORTRAN intrinsic function ATAN instead of a DATA C statement. C 881128 Modified by Dick Valent to meet prologue standards. C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE EZFFT1 DIMENSION WA(*), IFAC(*), NTRYH(4) SAVE NTRYH DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ C***FIRST EXECUTABLE STATEMENT EZFFT1 TPI = 8.*ATAN(1.) NL = N NF = 0 J = 0 101 J = J+1 IF (J-4) 102,102,103 102 NTRY = NTRYH(J) GO TO 104 103 NTRY = NTRY+2 104 NQ = NL/NTRY NR = NL-NTRY*NQ IF (NR) 101,105,101 105 NF = NF+1 IFAC(NF+2) = NTRY NL = NQ IF (NTRY .NE. 2) GO TO 107 IF (NF .EQ. 1) GO TO 107 DO 106 I=2,NF IB = NF-I+2 IFAC(IB+2) = IFAC(IB+1) 106 CONTINUE IFAC(3) = 2 107 IF (NL .NE. 1) GO TO 104 IFAC(1) = N IFAC(2) = NF ARGH = TPI/N IS = 0 NFM1 = NF-1 L1 = 1 IF (NFM1 .EQ. 0) RETURN DO 111 K1=1,NFM1 IP = IFAC(K1+2) L2 = L1*IP IDO = N/L2 IPM = IP-1 ARG1 = L1*ARGH CH1 = 1. SH1 = 0. DCH1 = COS(ARG1) DSH1 = SIN(ARG1) DO 110 J=1,IPM CH1H = DCH1*CH1-DSH1*SH1 SH1 = DCH1*SH1+DSH1*CH1 CH1 = CH1H I = IS+2 WA(I-1) = CH1 WA(I) = SH1 IF (IDO .LT. 5) GO TO 109 DO 108 II=5,IDO,2 I = I+2 WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2) WA(I) = CH1*WA(I-2)+SH1*WA(I-3) 108 CONTINUE 109 IS = IS+IDO 110 CONTINUE L1 = L2 111 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/ezfftb.f0000644060175006010010000000734412562522364015236 0ustar chmNone*DECK EZFFTB SUBROUTINE EZFFTB (N, R, AZERO, A, B, WSAVE) C***BEGIN PROLOGUE EZFFTB C***PURPOSE A simplified real, periodic, backward fast Fourier C transform. C***LIBRARY SLATEC (FFTPACK) C***CATEGORY J1A1 C***TYPE SINGLE PRECISION (EZFFTB-S) C***KEYWORDS FFTPACK, FOURIER TRANSFORM C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C Subroutine EZFFTB computes a real periodic sequence from its C Fourier coefficients (Fourier synthesis). The transform is C defined below at Output Parameter R. EZFFTB is a simplified C but slower version of RFFTB. C C Input Parameters C C N the length of the output array R. The method is most C efficient when N is the product of small primes. C C AZERO the constant Fourier coefficient C C A,B arrays which contain the remaining Fourier coefficients. C These arrays are not destroyed. C C The length of these arrays depends on whether N is even or C odd. C C If N is even, N/2 locations are required. C If N is odd, (N-1)/2 locations are required C C WSAVE a work array which must be dimensioned at least 3*N+15 C in the program that calls EZFFTB. The WSAVE array must be C initialized by calling subroutine EZFFTI(N,WSAVE), and a C different WSAVE array must be used for each different C value of N. This initialization does not have to be C repeated so long as N remains unchanged. Thus subsequent C transforms can be obtained faster than the first. C The same WSAVE array can be used by EZFFTF and EZFFTB. C C Output Parameters C C R if N is even, define KMAX=N/2 C if N is odd, define KMAX=(N-1)/2 C C Then for I=1,...,N C C R(I)=AZERO plus the sum from K=1 to K=KMAX of C C A(K)*COS(K*(I-1)*2*PI/N)+B(K)*SIN(K*(I-1)*2*PI/N) C C ********************* Complex Notation ************************** C C For J=1,...,N C C R(J) equals the sum from K=-KMAX to K=KMAX of C C C(K)*EXP(I*K*(J-1)*2*PI/N) C C where C C C(K) = .5*CMPLX(A(K),-B(K)) for K=1,...,KMAX C C C(-K) = CONJG(C(K)) C C C(0) = AZERO C C and I=SQRT(-1) C C *************** Amplitude - Phase Notation *********************** C C For I=1,...,N C C R(I) equals AZERO plus the sum from K=1 to K=KMAX of C C ALPHA(K)*COS(K*(I-1)*2*PI/N+BETA(K)) C C where C C ALPHA(K) = SQRT(A(K)*A(K)+B(K)*B(K)) C C COS(BETA(K))=A(K)/ALPHA(K) C C SIN(BETA(K))=-B(K)/ALPHA(K) C C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel C Computations (G. Rodrigue, ed.), Academic Press, C 1982, pp. 51-83. C***ROUTINES CALLED RFFTB C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*) C 861211 REVISION DATE from Version 3.2 C 881128 Modified by Dick Valent to meet prologue standards. C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE EZFFTB DIMENSION R(*), A(*), B(*), WSAVE(*) C***FIRST EXECUTABLE STATEMENT EZFFTB IF (N-2) 101,102,103 101 R(1) = AZERO RETURN 102 R(1) = AZERO+A(1) R(2) = AZERO-A(1) RETURN 103 NS2 = (N-1)/2 DO 104 I=1,NS2 R(2*I) = .5*A(I) R(2*I+1) = -.5*B(I) 104 CONTINUE R(1) = AZERO IF (MOD(N,2) .EQ. 0) R(N) = A(NS2+1) CALL RFFTB (N,R,WSAVE(N+1)) RETURN END PDL-2.018/Lib/Slatec/slatec/ezfftf.f0000644060175006010010000000645112562522364015240 0ustar chmNone*DECK EZFFTF SUBROUTINE EZFFTF (N, R, AZERO, A, B, WSAVE) C***BEGIN PROLOGUE EZFFTF C***PURPOSE Compute a simplified real, periodic, fast Fourier forward C transform. C***LIBRARY SLATEC (FFTPACK) C***CATEGORY J1A1 C***TYPE SINGLE PRECISION (EZFFTF-S) C***KEYWORDS FFTPACK, FOURIER TRANSFORM C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C Subroutine EZFFTF computes the Fourier coefficients of a real C periodic sequence (Fourier analysis). The transform is defined C below at Output Parameters AZERO, A and B. EZFFTF is a simplified C but slower version of RFFTF. C C Input Parameters C C N the length of the array R to be transformed. The method C is most efficient when N is the product of small primes. C C R a real array of length N which contains the sequence C to be transformed. R is not destroyed. C C C WSAVE a work array which must be dimensioned at least 3*N+15 C in the program that calls EZFFTF. The WSAVE array must be C initialized by calling subroutine EZFFTI(N,WSAVE), and a C different WSAVE array must be used for each different C value of N. This initialization does not have to be C repeated so long as N remains unchanged. Thus subsequent C transforms can be obtained faster than the first. C The same WSAVE array can be used by EZFFTF and EZFFTB. C C Output Parameters C C AZERO the sum from I=1 to I=N of R(I)/N C C A,B for N even B(N/2)=0. and A(N/2) is the sum from I=1 to C I=N of (-1)**(I-1)*R(I)/N C C for N even define KMAX=N/2-1 C for N odd define KMAX=(N-1)/2 C C then for K=1,...,KMAX C C A(K) equals the sum from I=1 to I=N of C C 2./N*R(I)*COS(K*(I-1)*2*PI/N) C C B(K) equals the sum from I=1 to I=N of C C 2./N*R(I)*SIN(K*(I-1)*2*PI/N) C C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel C Computations (G. Rodrigue, ed.), Academic Press, C 1982, pp. 51-83. C***ROUTINES CALLED RFFTF C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing references to intrinsic function FLOAT C to REAL. C 881128 Modified by Dick Valent to meet prologue standards. C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE EZFFTF DIMENSION R(*), A(*), B(*), WSAVE(*) C***FIRST EXECUTABLE STATEMENT EZFFTF IF (N-2) 101,102,103 101 AZERO = R(1) RETURN 102 AZERO = .5*(R(1)+R(2)) A(1) = .5*(R(1)-R(2)) RETURN 103 DO 104 I=1,N WSAVE(I) = R(I) 104 CONTINUE CALL RFFTF (N,WSAVE,WSAVE(N+1)) CF = 2./N CFM = -CF AZERO = .5*CF*WSAVE(1) NS2 = (N+1)/2 NS2M = NS2-1 DO 105 I=1,NS2M A(I) = CF*WSAVE(2*I) B(I) = CFM*WSAVE(2*I+1) 105 CONTINUE IF (MOD(N,2) .EQ. 0) A(NS2) = .5*CF*WSAVE(N) RETURN END PDL-2.018/Lib/Slatec/slatec/ezffti.f0000644060175006010010000000335112562522364015237 0ustar chmNone*DECK EZFFTI SUBROUTINE EZFFTI (N, WSAVE) C***BEGIN PROLOGUE EZFFTI C***PURPOSE Initialize a work array for EZFFTF and EZFFTB. C***LIBRARY SLATEC (FFTPACK) C***CATEGORY J1A1 C***TYPE SINGLE PRECISION (EZFFTI-S) C***KEYWORDS FFTPACK, FOURIER TRANSFORM C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C Subroutine EZFFTI initializes the work array WSAVE which is used in C both EZFFTF and EZFFTB. The prime factorization of N together with C a tabulation of the trigonometric functions are computed and C stored in WSAVE. C C Input Parameter C C N the length of the sequence to be transformed. C C Output Parameter C C WSAVE a work array which must be dimensioned at least 3*N+15. C The same work array can be used for both EZFFTF and EZFFTB C as long as N remains unchanged. Different WSAVE arrays C are required for different values of N. C C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel C Computations (G. Rodrigue, ed.), Academic Press, C 1982, pp. 51-83. C***ROUTINES CALLED EZFFT1 C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*). C 861211 REVISION DATE from Version 3.2 C 881128 Modified by Dick Valent to meet prologue standards. C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE EZFFTI DIMENSION WSAVE(*) C***FIRST EXECUTABLE STATEMENT EZFFTI IF (N .EQ. 1) RETURN CALL EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1)) RETURN END PDL-2.018/Lib/Slatec/slatec/fdump.f0000644060175006010010000000205412562522365015063 0ustar chmNone*DECK FDUMP SUBROUTINE FDUMP C***BEGIN PROLOGUE FDUMP C***PURPOSE Symbolic dump (should be locally written). C***LIBRARY SLATEC (XERROR) C***CATEGORY R3 C***TYPE ALL (FDUMP-A) C***KEYWORDS ERROR, XERMSG C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C ***Note*** Machine Dependent Routine C FDUMP is intended to be replaced by a locally written C version which produces a symbolic dump. Failing this, C it should be replaced by a version which prints the C subprogram nesting list. Note that this dump must be C printed on each of up to five files, as indicated by the C XGETUA routine. See XSETUA and XGETUA for details. C C Written by Ron Jones, with SLATEC Common Math Library Subcommittee C C***REFERENCES (NONE) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE FDUMP C***FIRST EXECUTABLE STATEMENT FDUMP RETURN END PDL-2.018/Lib/Slatec/slatec/i1mach.f0000644060175006010010000007177012562522365015125 0ustar chmNone*DECK I1MACH INTEGER FUNCTION I1MACH (I) C***BEGIN PROLOGUE I1MACH C***PURPOSE Return integer machine dependent constants. C***LIBRARY SLATEC C***CATEGORY R1 C***TYPE INTEGER (I1MACH-I) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Fox, P. A., (Bell Labs) C Hall, A. D., (Bell Labs) C Schryer, N. L., (Bell Labs) C***DESCRIPTION C C I1MACH can be used to obtain machine-dependent parameters for the C local machine environment. It is a function subprogram with one C (input) argument and can be referenced as follows: C C K = I1MACH(I) C C where I=1,...,16. The (output) value of K above is determined by C the (input) value of I. The results for various values of I are C discussed below. C C I/O unit numbers: C I1MACH( 1) = the standard input unit. C I1MACH( 2) = the standard output unit. C I1MACH( 3) = the standard punch unit. C I1MACH( 4) = the standard error message unit. C C Words: C I1MACH( 5) = the number of bits per integer storage unit. C I1MACH( 6) = the number of characters per integer storage unit. C C Integers: C assume integers are represented in the S-digit, base-A form C C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) C C where 0 .LE. X(I) .LT. A for I=0,...,S-1. C I1MACH( 7) = A, the base. C I1MACH( 8) = S, the number of base-A digits. C I1MACH( 9) = A**S - 1, the largest magnitude. C C Floating-Point Numbers: C Assume floating-point numbers are represented in the T-digit, C base-B form C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. C I1MACH(10) = B, the base. C C Single-Precision: C I1MACH(11) = T, the number of base-B digits. C I1MACH(12) = EMIN, the smallest exponent E. C I1MACH(13) = EMAX, the largest exponent E. C C Double-Precision: C I1MACH(14) = T, the number of base-B digits. C I1MACH(15) = EMIN, the smallest exponent E. C I1MACH(16) = EMAX, the largest exponent E. C C To alter this function for a particular environment, the desired C set of DATA statements should be activated by removing the C from C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be C checked for consistency with the local operating system. C C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for C a portable library, ACM Transactions on Mathematical C Software 4, 2 (June 1978), pp. 177-188. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 750101 DATE WRITTEN C 891012 Added VAX G-floating constants. (WRB) C 891012 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900618 Added DEC RISC constants. (WRB) C 900723 Added IBM RS 6000 constants. (WRB) C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. C (RWC) C 910710 Added HP 730 constants. (SMR) C 911114 Added Convex IEEE constants. (WRB) C 920121 Added SUN -r8 compiler option constants. (WRB) C 920229 Added Touchstone Delta i860 constants. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C 920625 Added Convex -p8 and -pd8 compiler option constants. C (BKS, WRB) C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler C options. (DWL, RWC and WRB). C***END PROLOGUE I1MACH C INTEGER IMACH(16),OUTPUT SAVE IMACH EQUIVALENCE (IMACH(4),OUTPUT) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT COMPILER C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1022 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE APOLLO C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 129 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1025 / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM C C DATA IMACH( 1) / 7 / C DATA IMACH( 2) / 2 / C DATA IMACH( 3) / 2 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 33 / C DATA IMACH( 9) / Z1FFFFFFFF / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -256 / C DATA IMACH(13) / 255 / C DATA IMACH(14) / 60 / C DATA IMACH(15) / -256 / C DATA IMACH(16) / 255 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -50 / C DATA IMACH(16) / 76 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -32754 / C DATA IMACH(16) / 32780 / C C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 9223372036854775807 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -4095 / C DATA IMACH(13) / 4094 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -4095 / C DATA IMACH(16) / 4094 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6LOUTPUT/ C DATA IMACH( 5) / 60 / C DATA IMACH( 6) / 10 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 48 / C DATA IMACH( 9) / 00007777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -929 / C DATA IMACH(13) / 1070 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -929 / C DATA IMACH(16) / 1069 / C C MACHINE CONSTANTS FOR THE CELERITY C1260 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / Z'7FFFFFFF' / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1022 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fn COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fi COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -p8 COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 9223372036854775807 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 53 / C DATA IMACH(12) / -1023 / C DATA IMACH(13) / 1023 / C DATA IMACH(14) / 113 / C DATA IMACH(15) / -16383 / C DATA IMACH(16) / 16383 / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -pd8 COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 9223372036854775807 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 53 / C DATA IMACH(12) / -1023 / C DATA IMACH(13) / 1023 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE CRAY C USING THE 46 BIT INTEGER COMPILER OPTION C C DATA IMACH( 1) / 100 / C DATA IMACH( 2) / 101 / C DATA IMACH( 3) / 102 / C DATA IMACH( 4) / 101 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 46 / C DATA IMACH( 9) / 1777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -8189 / C DATA IMACH(13) / 8190 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -8099 / C DATA IMACH(16) / 8190 / C C MACHINE CONSTANTS FOR THE CRAY C USING THE 64 BIT INTEGER COMPILER OPTION C C DATA IMACH( 1) / 100 / C DATA IMACH( 2) / 101 / C DATA IMACH( 3) / 102 / C DATA IMACH( 4) / 101 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 777777777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 47 / C DATA IMACH(12) / -8189 / C DATA IMACH(13) / 8190 / C DATA IMACH(14) / 94 / C DATA IMACH(15) / -8099 / C DATA IMACH(16) / 8190 / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C DATA IMACH( 1) / 11 / C DATA IMACH( 2) / 12 / C DATA IMACH( 3) / 8 / C DATA IMACH( 4) / 10 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING G_FLOAT C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING IEEE_FLOAT C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE DEC RISC C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE DEC VAX C USING D_FLOATING C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE DEC VAX C USING G_FLOATING C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1023 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE ELXSI 6400 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 32 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1022 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / 3 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 23 / C DATA IMACH( 9) / 8388607 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 38 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 43 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 63 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 730 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE HP 2100 C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 4 / C DATA IMACH( 4) / 1 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 39 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 4 / C DATA IMACH( 4) / 1 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 55 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HP 9000 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 7 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 32 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -126 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1015 / C DATA IMACH(16) / 1017 / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND C THE PERKIN ELMER (INTERDATA) 7/32. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / Z7FFFFFFF / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 / C C MACHINE CONSTANTS FOR THE IBM PC C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 0 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE INTEL i860 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 54 / C DATA IMACH(15) / -101 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 62 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE SUN C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -125 / C DATA IMACH(13) / 128 / C DATA IMACH(14) / 53 / C DATA IMACH(15) / -1021 / C DATA IMACH(16) / 1024 / C C MACHINE CONSTANTS FOR THE SUN C USING THE -r8 COMPILER OPTION C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 6 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 53 / C DATA IMACH(12) / -1021 / C DATA IMACH(13) / 1024 / C DATA IMACH(14) / 113 / C DATA IMACH(15) / -16381 / C DATA IMACH(16) / 16384 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 1 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 60 / C DATA IMACH(15) / -1024 / C DATA IMACH(16) / 1023 / C C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR C C DATA IMACH( 1) / 1 / C DATA IMACH( 2) / 1 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 1 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C***FIRST EXECUTABLE STATEMENT I1MACH IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 C I1MACH = IMACH(I) RETURN C 10 CONTINUE WRITE (UNIT = OUTPUT, FMT = 9000) 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') C C CALL FDUMP C STOP END PDL-2.018/Lib/Slatec/slatec/idamax.f0000644060175006010010000000474312562522365015222 0ustar chmNone*DECK IDAMAX INTEGER FUNCTION IDAMAX (N, DX, INCX) C***BEGIN PROLOGUE IDAMAX C***PURPOSE Find the smallest index of that component of a vector C having the maximum magnitude. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A2 C***TYPE DOUBLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C DX double precision vector with N elements C INCX storage spacing between elements of DX C C --Output-- C IDAMAX smallest index (zero if N .LE. 0) C C Find smallest index of maximum magnitude of double precision DX. C IDAMAX = first I, I = 1 to N, to maximize ABS(DX(IX+(I-1)*INCX)), C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900821 Modified to correct problem with a negative increment. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE IDAMAX DOUBLE PRECISION DX(*), DMAX, XMAG INTEGER I, INCX, IX, N C***FIRST EXECUTABLE STATEMENT IDAMAX IDAMAX = 0 IF (N .LE. 0) RETURN IDAMAX = 1 IF (N .EQ. 1) RETURN C IF (INCX .EQ. 1) GOTO 20 C C Code for increments not equal to 1. C IX = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 DMAX = ABS(DX(IX)) IX = IX + INCX DO 10 I = 2,N XMAG = ABS(DX(IX)) IF (XMAG .GT. DMAX) THEN IDAMAX = I DMAX = XMAG ENDIF IX = IX + INCX 10 CONTINUE RETURN C C Code for increments equal to 1. C 20 DMAX = ABS(DX(1)) DO 30 I = 2,N XMAG = ABS(DX(I)) IF (XMAG .GT. DMAX) THEN IDAMAX = I DMAX = XMAG ENDIF 30 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/isamax.f0000644060175006010010000000471612562522365015241 0ustar chmNone*DECK ISAMAX INTEGER FUNCTION ISAMAX (N, SX, INCX) C***BEGIN PROLOGUE ISAMAX C***PURPOSE Find the smallest index of that component of a vector C having the maximum magnitude. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A2 C***TYPE SINGLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SX single precision vector with N elements C INCX storage spacing between elements of SX C C --Output-- C ISAMAX smallest index (zero if N .LE. 0) C C Find smallest index of maximum magnitude of single precision SX. C ISAMAX = first I, I = 1 to N, to maximize ABS(SX(IX+(I-1)*INCX)), C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900821 Modified to correct problem with a negative increment. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C 920618 Slight restructuring of code. (RWC, WRB) C***END PROLOGUE ISAMAX REAL SX(*), SMAX, XMAG INTEGER I, INCX, IX, N C***FIRST EXECUTABLE STATEMENT ISAMAX ISAMAX = 0 IF (N .LE. 0) RETURN ISAMAX = 1 IF (N .EQ. 1) RETURN C IF (INCX .EQ. 1) GOTO 20 C C Code for increment not equal to 1. C IX = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 SMAX = ABS(SX(IX)) IX = IX + INCX DO 10 I = 2,N XMAG = ABS(SX(IX)) IF (XMAG .GT. SMAX) THEN ISAMAX = I SMAX = XMAG ENDIF IX = IX + INCX 10 CONTINUE RETURN C C Code for increments equal to 1. C 20 SMAX = ABS(SX(1)) DO 30 I = 2,N XMAG = ABS(SX(I)) IF (XMAG .GT. SMAX) THEN ISAMAX = I SMAX = XMAG ENDIF 30 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/j4save.f0000644060175006010010000000522312562522365015145 0ustar chmNone*DECK J4SAVE FUNCTION J4SAVE (IWHICH, IVALUE, ISET) C***BEGIN PROLOGUE J4SAVE C***SUBSIDIARY C***PURPOSE Save or recall global variables needed by error C handling routines. C***LIBRARY SLATEC (XERROR) C***TYPE INTEGER (J4SAVE-I) C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C J4SAVE saves and recalls several global variables needed C by the library error handling routines. C C Description of Parameters C --Input-- C IWHICH - Index of item desired. C = 1 Refers to current error number. C = 2 Refers to current error control flag. C = 3 Refers to current unit number to which error C messages are to be sent. (0 means use standard.) C = 4 Refers to the maximum number of times any C message is to be printed (as set by XERMAX). C = 5 Refers to the total number of units to which C each error message is to be written. C = 6 Refers to the 2nd unit for error messages C = 7 Refers to the 3rd unit for error messages C = 8 Refers to the 4th unit for error messages C = 9 Refers to the 5th unit for error messages C IVALUE - The value to be set for the IWHICH-th parameter, C if ISET is .TRUE. . C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE C given the value, IVALUE. If ISET=.FALSE., the C IWHICH-th parameter will be unchanged, and IVALUE C is a dummy parameter. C --Output-- C The (old) value of the IWHICH-th parameter will be returned C in the function value, J4SAVE. C C***SEE ALSO XERMSG C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 891214 Prologue converted to Version 4.0 format. (BAB) C 900205 Minor modifications to prologue. (WRB) C 900402 Added TYPE section. (WRB) C 910411 Added KEYWORDS section. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE J4SAVE LOGICAL ISET INTEGER IPARAM(9) SAVE IPARAM DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ DATA IPARAM(5)/1/ DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ C***FIRST EXECUTABLE STATEMENT J4SAVE J4SAVE = IPARAM(IWHICH) IF (ISET) IPARAM(IWHICH) = IVALUE RETURN END PDL-2.018/Lib/Slatec/slatec/pchbs.f0000644060175006010010000002003512562522365015046 0ustar chmNone*DECK PCHBS SUBROUTINE PCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, + NDIM, KORD, IERR) C***BEGIN PROLOGUE PCHBS C***PURPOSE Piecewise Cubic Hermite to B-Spline converter. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE SINGLE PRECISION (PCHBS-S, DPCHBS-D) C***KEYWORDS B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION, C PIECEWISE CUBIC INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Computing and Mathematics Research Division C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C *Usage: C C INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR C PARAMETER (INCFD = ...) C REAL X(nmax), F(INCFD,nmax), D(INCFD,nmax), T(2*nmax+4), C * BCOEF(2*nmax) C C CALL PCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF, C * NDIM, KORD, IERR) C C *Arguments: C C N:IN is the number of data points, N.ge.2 . (not checked) C C X:IN is the real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. (not checked) C nmax, the dimension of X, must be .ge.N. C C F:IN is the real array of dependent variable values. C F(1+(I-1)*INCFD) is the value corresponding to X(I). C nmax, the second dimension of F, must be .ge.N. C C D:IN is the real array of derivative values at the data points. C D(1+(I-1)*INCFD) is the value corresponding to X(I). C nmax, the second dimension of D, must be .ge.N. C C INCFD:IN is the increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C It may have the value 1 for one-dimensional applications, C in which case F and D may be singly-subscripted arrays. C C KNOTYP:IN is a flag to control the knot sequence. C The knot sequence T is normally computed from X by putting C a double knot at each X and setting the end knot pairs C according to the value of KNOTYP: C KNOTYP = 0: Quadruple knots at X(1) and X(N). (default) C KNOTYP = 1: Replicate lengths of extreme subintervals: C T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1)) ; C T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)). C KNOTYP = 2: Periodic placement of boundary knots: C T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1)); C T(M+4) = T(M+3) = X(N) + (X(2)-X(1)) . C Here M=NDIM=2*N. C If the input value of KNOTYP is negative, however, it is C assumed that NKNOTS and T were set in a previous call. C This option is provided for improved efficiency when used C in a parametric setting. C C NKNOTS:INOUT is the number of knots. C If KNOTYP.GE.0, then NKNOTS will be set to NDIM+4. C If KNOTYP.LT.0, then NKNOTS is an input variable, and an C error return will be taken if it is not equal to NDIM+4. C C T:INOUT is the array of 2*N+4 knots for the B-representation. C If KNOTYP.GE.0, T will be returned by PCHBS with the C interior double knots equal to the X-values and the C boundary knots set as indicated above. C If KNOTYP.LT.0, it is assumed that T was set by a C previous call to PCHBS. (This routine does **not** C verify that T forms a legitimate knot sequence.) C C BCOEF:OUT is the array of 2*N B-spline coefficients. C C NDIM:OUT is the dimension of the B-spline space. (Set to 2*N.) C C KORD:OUT is the order of the B-spline. (Set to 4.) C C IERR:OUT is an error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -4 if KNOTYP.GT.2 . C IERR = -5 if KNOTYP.LT.0 and NKNOTS.NE.(2*N+4). C C *Description: C PCHBS computes the B-spline representation of the PCH function C determined by N,X,F,D. To be compatible with the rest of PCHIP, C PCHBS includes INCFD, the increment between successive values of C the F- and D-arrays. C C The output is the B-representation for the function: NKNOTS, T, C BCOEF, NDIM, KORD. C C *Caution: C Since it is assumed that the input PCH function has been C computed by one of the other routines in the package PCHIP, C input arguments N, X, INCFD are **not** checked for validity. C C *Restrictions/assumptions: C 1. N.GE.2 . (not checked) C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) C 3. INCFD.GT.0 . (not checked) C 4. KNOTYP.LE.2 . (error return if not) C *5. NKNOTS = NDIM+4 = 2*N+4 . (error return if not) C *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N . (not checked) C C * Indicates this applies only if KNOTYP.LT.0 . C C *Portability: C Argument INCFD is used only to cause the compiler to generate C efficient code for the subscript expressions (1+(I-1)*INCFD) . C The normal usage, in which PCHBS is called with one-dimensional C arrays F and D, is probably non-Fortran 77, in the strict sense, C but it works on all systems on which PCHBS has been tested. C C *See Also: C PCHIC, PCHIM, or PCHSP can be used to determine an interpolating C PCH function from a set of data. C The B-spline routine BVALU can be used to evaluate the C B-representation that is output by PCHBS. C (See BSPDOC for more information.) C C***REFERENCES F. N. Fritsch, "Representations for parametric cubic C splines," Computer Aided Geometric Design 6 (1989), C pp.79-82. C***ROUTINES CALLED PCHKT, XERMSG C***REVISION HISTORY (YYMMDD) C 870701 DATE WRITTEN C 900405 Converted Fortran to upper case. C 900405 Removed requirement that X be dimensioned N+1. C 900406 Modified to make PCHKT a subsidiary routine to simplify C usage. In the process, added argument INCFD to be com- C patible with the rest of PCHIP. C 900410 Converted prologue to SLATEC 4.0 format. C 900410 Added calls to XERMSG and changed constant 3. to 3 to C reduce single/double differences. C 900411 Added reference. C 900501 Corrected declarations. C 930317 Minor cosmetic changes. (FNF) C 930514 Corrected problems with dimensioning of arguments and C clarified DESCRIPTION. (FNF) C 930604 Removed NKNOTS from PCHKT call list. (FNF) C***END PROLOGUE PCHBS C C*Internal Notes: C C**End C C Declare arguments. C INTEGER N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR REAL X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*) C C Declare local variables. C INTEGER K, KK REAL DOV3, HNEW, HOLD CHARACTER*8 LIBNAM, SUBNAM C***FIRST EXECUTABLE STATEMENT PCHBS C C Initialize. C NDIM = 2*N KORD = 4 IERR = 0 LIBNAM = 'SLATEC' SUBNAM = 'PCHBS' C C Check argument validity. Set up knot sequence if OK. C IF ( KNOTYP.GT.2 ) THEN IERR = -1 CALL XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1) RETURN ENDIF IF ( KNOTYP.LT.0 ) THEN IF ( NKNOTS.NE.NDIM+4 ) THEN IERR = -2 CALL XERMSG (LIBNAM, SUBNAM, * 'KNOTYP.LT.0 AND NKNOTS.NE.(2*N+4)', IERR, 1) RETURN ENDIF ELSE C Set up knot sequence. NKNOTS = NDIM + 4 CALL PCHKT (N, X, KNOTYP, T) ENDIF C C Compute B-spline coefficients. C HNEW = T(3) - T(1) DO 40 K = 1, N KK = 2*K HOLD = HNEW C The following requires mixed mode arithmetic. DOV3 = D(1,K)/3 BCOEF(KK-1) = F(1,K) - HOLD*DOV3 C The following assumes T(2*K+1) = X(K). HNEW = T(KK+3) - T(KK+1) BCOEF(KK) = F(1,K) + HNEW*DOV3 40 CONTINUE C C Terminate. C RETURN C------------- LAST LINE OF PCHBS FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchce.f0000644060175006010010000002046512562522365015040 0ustar chmNone*DECK PCHCE SUBROUTINE PCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) C***BEGIN PROLOGUE PCHCE C***SUBSIDIARY C***PURPOSE Set boundary conditions for PCHIC C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHCE-S, DPCHCE-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHCE: PCHIC End Derivative Setter. C C Called by PCHIC to set end derivatives as requested by the user. C It must be called after interior derivative values have been set. C ----- C C To facilitate two-dimensional applications, includes an increment C between successive values of the D-array. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER IC(2), N, IERR C REAL VC(2), X(N), H(N), SLOPE(N), D(INCFD,N) C C CALL PCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR) C C Parameters: C C IC -- (input) integer array of length 2 specifying desired C boundary conditions: C IC(1) = IBEG, desired condition at beginning of data. C IC(2) = IEND, desired condition at end of data. C ( see prologue to PCHIC for details. ) C C VC -- (input) real array of length 2 specifying desired boundary C values. VC(1) need be set only if IC(1) = 2 or 3 . C VC(2) need be set only if IC(2) = 2 or 3 . C C N -- (input) number of data points. (assumes N.GE.2) C C X -- (input) real array of independent variable values. (the C elements of X are assumed to be strictly increasing.) C C H -- (input) real array of interval lengths. C SLOPE -- (input) real array of data slopes. C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: C H(I) = X(I+1)-X(I), C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. C C D -- (input) real array of derivative values at the data points. C The value corresponding to X(I) must be stored in C D(1+(I-1)*INCFD), I=1(1)N. C (output) the value of D at X(1) and/or X(N) is changed, if C necessary, to produce the requested boundary conditions. C no other entries in D are changed. C C INCFD -- (input) increment between successive values in D. C This argument is provided primarily for 2-D applications. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning errors: C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for C monotonicity. C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be C adjusted for monotonicity. C IERR = 3 if both of the above are true. C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS. C C***SEE ALSO PCHIC C***ROUTINES CALLED PCHDF, PCHST, XERMSG C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870707 Minor corrections made to prologue.. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE PCHCE C C Programming notes: C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C 2. One could reduce the number of arguments and amount of local C storage, at the expense of reduced code clarity, by passing in C the array WK (rather than splitting it into H and SLOPE) and C increasing its length enough to incorporate STEMP and XTEMP. C 3. The two monotonicity checks only use the sufficient conditions. C Thus, it is possible (but unlikely) for a boundary condition to C be changed, even though the original interpolant was monotonic. C (At least the result is a continuous function of the data.) C**End C C DECLARE ARGUMENTS. C INTEGER IC(2), N, INCFD, IERR REAL VC(2), X(*), H(*), SLOPE(*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER IBEG, IEND, IERF, INDEX, J, K REAL HALF, STEMP(3), THREE, TWO, XTEMP(4), ZERO SAVE ZERO, HALF, TWO, THREE REAL PCHDF, PCHST C C INITIALIZE. C DATA ZERO /0./, HALF /0.5/, TWO /2./, THREE /3./ C C***FIRST EXECUTABLE STATEMENT PCHCE IBEG = IC(1) IEND = IC(2) IERR = 0 C C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. C IF ( ABS(IBEG).GT.N ) IBEG = 0 IF ( ABS(IEND).GT.N ) IEND = 0 C C TREAT BEGINNING BOUNDARY CONDITION. C IF (IBEG .EQ. 0) GO TO 2000 K = ABS(IBEG) IF (K .EQ. 1) THEN C BOUNDARY VALUE PROVIDED. D(1,1) = VC(1) ELSE IF (K .EQ. 2) THEN C BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,1) = HALF*( (THREE*SLOPE(1) - D(1,2)) - HALF*VC(1)*H(1) ) ELSE IF (K .LT. 5) THEN C USE K-POINT DERIVATIVE FORMULA. C PICK UP FIRST K POINTS, IN REVERSE ORDER. DO 10 J = 1, K INDEX = K-J+1 C INDEX RUNS FROM K DOWN TO 1. XTEMP(J) = X(INDEX) IF (J .LT. K) STEMP(J) = SLOPE(INDEX-1) 10 CONTINUE C ----------------------------- D(1,1) = PCHDF (K, XTEMP, STEMP, IERF) C ----------------------------- IF (IERF .NE. 0) GO TO 5001 ELSE C USE 'NOT A KNOT' CONDITION. D(1,1) = ( THREE*(H(1)*SLOPE(2) + H(2)*SLOPE(1)) * - TWO*(H(1)+H(2))*D(1,2) - H(1)*D(1,3) ) / H(2) ENDIF C IF (IBEG .GT. 0) GO TO 2000 C C CHECK D(1,1) FOR COMPATIBILITY WITH MONOTONICITY. C IF (SLOPE(1) .EQ. ZERO) THEN IF (D(1,1) .NE. ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ENDIF ELSE IF ( PCHST(D(1,1),SLOPE(1)) .LT. ZERO) THEN D(1,1) = ZERO IERR = IERR + 1 ELSE IF ( ABS(D(1,1)) .GT. THREE*ABS(SLOPE(1)) ) THEN D(1,1) = THREE*SLOPE(1) IERR = IERR + 1 ENDIF C C TREAT END BOUNDARY CONDITION. C 2000 CONTINUE IF (IEND .EQ. 0) GO TO 5000 K = ABS(IEND) IF (K .EQ. 1) THEN C BOUNDARY VALUE PROVIDED. D(1,N) = VC(2) ELSE IF (K .EQ. 2) THEN C BOUNDARY SECOND DERIVATIVE PROVIDED. D(1,N) = HALF*( (THREE*SLOPE(N-1) - D(1,N-1)) + * HALF*VC(2)*H(N-1) ) ELSE IF (K .LT. 5) THEN C USE K-POINT DERIVATIVE FORMULA. C PICK UP LAST K POINTS. DO 2010 J = 1, K INDEX = N-K+J C INDEX RUNS FROM N+1-K UP TO N. XTEMP(J) = X(INDEX) IF (J .LT. K) STEMP(J) = SLOPE(INDEX) 2010 CONTINUE C ----------------------------- D(1,N) = PCHDF (K, XTEMP, STEMP, IERF) C ----------------------------- IF (IERF .NE. 0) GO TO 5001 ELSE C USE 'NOT A KNOT' CONDITION. D(1,N) = ( THREE*(H(N-1)*SLOPE(N-2) + H(N-2)*SLOPE(N-1)) * - TWO*(H(N-1)+H(N-2))*D(1,N-1) - H(N-1)*D(1,N-2) ) * / H(N-2) ENDIF C IF (IEND .GT. 0) GO TO 5000 C C CHECK D(1,N) FOR COMPATIBILITY WITH MONOTONICITY. C IF (SLOPE(N-1) .EQ. ZERO) THEN IF (D(1,N) .NE. ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ENDIF ELSE IF ( PCHST(D(1,N),SLOPE(N-1)) .LT. ZERO) THEN D(1,N) = ZERO IERR = IERR + 2 ELSE IF ( ABS(D(1,N)) .GT. THREE*ABS(SLOPE(N-1)) ) THEN D(1,N) = THREE*SLOPE(N-1) IERR = IERR + 2 ENDIF C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURN. C 5001 CONTINUE C ERROR RETURN FROM PCHDF. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -1 CALL XERMSG ('SLATEC', 'PCHCE', 'ERROR RETURN FROM PCHDF', IERR, + 1) RETURN C------------- LAST LINE OF PCHCE FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchci.f0000644060175006010010000001304512562522365015040 0ustar chmNone*DECK PCHCI SUBROUTINE PCHCI (N, H, SLOPE, D, INCFD) C***BEGIN PROLOGUE PCHCI C***SUBSIDIARY C***PURPOSE Set interior derivatives for PCHIC C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHCI-S, DPCHCI-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHCI: PCHIC Initial Derivative Setter. C C Called by PCHIC to set derivatives needed to determine a monotone C piecewise cubic Hermite interpolant to the data. C C Default boundary conditions are provided which are compatible C with monotonicity. If the data are only piecewise monotonic, the C interpolant will have an extremum at each point where monotonicity C switches direction. C C To facilitate two-dimensional applications, includes an increment C between successive values of the D-array. C C The resulting piecewise cubic Hermite function should be identical C (within roundoff error) to that produced by PCHIM. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N C REAL H(N), SLOPE(N), D(INCFD,N) C C CALL PCHCI (N, H, SLOPE, D, INCFD) C C Parameters: C C N -- (input) number of data points. C If N=2, simply does linear interpolation. C C H -- (input) real array of interval lengths. C SLOPE -- (input) real array of data slopes. C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: C H(I) = X(I+1)-X(I), C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. C C D -- (output) real array of derivative values at the data points. C If the data are monotonic, these values will determine a C a monotone cubic Hermite function. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in D. C This argument is provided primarily for 2-D applications. C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS, MAX, MIN. C C***SEE ALSO PCHIC C***ROUTINES CALLED PCHST C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820601 Modified end conditions to be continuous functions of C data when monotonicity switches in next interval. C 820602 1. Modified formulas so end conditions are less prone C to over/underflow problems. C 2. Minor modification to HSUM calculation. C 820805 Converted to SLATEC library version. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE PCHCI C C Programming notes: C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD REAL H(*), SLOPE(*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER I, NLESS1 REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM, HSUMT3, THREE, * W1, W2, ZERO SAVE ZERO, THREE REAL PCHST C C INITIALIZE. C DATA ZERO /0./, THREE /3./ C***FIRST EXECUTABLE STATEMENT PCHCI NLESS1 = N - 1 DEL1 = SLOPE(1) C C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. C IF (NLESS1 .GT. 1) GO TO 10 D(1,1) = DEL1 D(1,N) = DEL1 GO TO 5000 C C NORMAL CASE (N .GE. 3). C 10 CONTINUE DEL2 = SLOPE(2) C C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C HSUM = H(1) + H(2) W1 = (H(1) + HSUM)/HSUM W2 = -H(1)/HSUM D(1,1) = W1*DEL1 + W2*DEL2 IF ( PCHST(D(1,1),DEL1) .LE. ZERO) THEN D(1,1) = ZERO ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL1 IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX ENDIF C C LOOP THROUGH INTERIOR POINTS. C DO 50 I = 2, NLESS1 IF (I .EQ. 2) GO TO 40 C HSUM = H(I-1) + H(I) DEL1 = DEL2 DEL2 = SLOPE(I) 40 CONTINUE C C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. C D(1,I) = ZERO IF ( PCHST(DEL1,DEL2) .LE. ZERO) GO TO 50 C C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. C HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H(I-1))/HSUMT3 W2 = (HSUM + H(I) )/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) C 50 CONTINUE C C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C W1 = -H(N-1)/HSUM W2 = (H(N-1) + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 IF ( PCHST(D(1,N),DEL2) .LE. ZERO) THEN D(1,N) = ZERO ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL2 IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX ENDIF C C NORMAL RETURN. C 5000 CONTINUE RETURN C------------- LAST LINE OF PCHCI FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchcm.f0000644060175006010010000002147012562522365015045 0ustar chmNone*DECK PCHCM SUBROUTINE PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) C***BEGIN PROLOGUE PCHCM C***PURPOSE Check a cubic Hermite function for monotonicity. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE SINGLE PRECISION (PCHCM-S, DPCHCM-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, C PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE C***AUTHOR Fritsch, F. N., (LLNL) C Computing & Mathematics Research Division C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C *Usage: C C PARAMETER (INCFD = ...) C INTEGER N, ISMON(N), IERR C REAL X(N), F(INCFD,N), D(INCFD,N) C LOGICAL SKIP C C CALL PCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) C C *Arguments: C C N:IN is the number of data points. (Error return if N.LT.2 .) C C X:IN is a real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F:IN is a real array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D:IN is a real array of derivative values. D(1+(I-1)*INCFD) is C the value corresponding to X(I). C C INCFD:IN is the increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP:INOUT is a logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed. C SKIP will be set to .TRUE. on normal return. C C ISMON:OUT is an integer array indicating on which intervals the C PCH function defined by N, X, F, D is monotonic. C For data interval [X(I),X(I+1)], C ISMON(I) = -3 if function is probably decreasing; C ISMON(I) = -1 if function is strictly decreasing; C ISMON(I) = 0 if function is constant; C ISMON(I) = 1 if function is strictly increasing; C ISMON(I) = 2 if function is non-monotonic; C ISMON(I) = 3 if function is probably increasing. C If ABS(ISMON)=3, this means that the D-values are near C the boundary of the monotonicity region. A small C increase produces non-monotonicity; decrease, strict C monotonicity. C The above applies to I=1(1)N-1. ISMON(N) indicates whether C the entire function is monotonic on [X(1),X(N)]. C C IERR:OUT is an error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C (The ISMON-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C *Description: C C PCHCM: Piecewise Cubic Hermite -- Check Monotonicity. C C Checks the piecewise cubic Hermite function defined by N,X,F,D C for monotonicity. C C To provide compatibility with PCHIM and PCHIC, includes an C increment between successive values of the F- and D-arrays. C C *Cautions: C This provides the same capability as old PCHMC, except that a C new output value, -3, was added February 1989. (Formerly, -3 C and +3 were lumped together in the single value 3.) Codes that C flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed. C Codes that check via "IF (ISMON.GE.3)" should change the test to C "IF (IABS(ISMON).GE.3)". Codes that declare monotonicity via C "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)". C C***REFERENCES F. N. Fritsch and R. E. Carlson, Monotone piecewise C cubic interpolation, SIAM Journal on Numerical Ana- C lysis 17, 2 (April 1980), pp. 238-246. C***ROUTINES CALLED CHFCM, XERMSG C***REVISION HISTORY (YYMMDD) C 820518 DATE WRITTEN C 820804 Converted to SLATEC library version. C 831201 Reversed order of subscripts of F and D, so that the C routine will work properly when INCFD.GT.1 . (Bug!!) C 870707 Minor cosmetic changes to prologue. C 890208 Added possible ISMON value of -3 and modified code so C that 1,3,-1 produces ISMON(N)=2, rather than 3. C 890306 Added caution about changed output. C 890407 Changed name from PCHMC to PCHCM, as requested at the C March 1989 SLATEC CML meeting, and made a few other C minor modifications necessitated by this change. C 890407 Converted to new SLATEC format. C 890407 Modified DESCRIPTION to LDOC format. C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE PCHCM C C Fortran intrinsics used: ISIGN. C Other routines used: CHFCM, XERMSG. C C ---------------------------------------------------------------------- C C Programming notes: C C An alternate organization would have separate loops for computing C ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N). The C first loop can be readily parallelized, since the NSEG calls to C CHFCM are independent. The second loop can be cut short if C ISMON(N) is ever equal to 2, for it cannot be changed further. C C To produce a double precision version, simply: C a. Change PCHCM to DPCHCM wherever it occurs, C b. Change CHFCM to DCHFCM wherever it occurs, and C c. Change the real declarations to double precision. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, ISMON(N), IERR REAL X(N), F(INCFD,N), D(INCFD,N) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, NSEG REAL DELTA INTEGER CHFCM C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT PCHCM IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE SKIP = .TRUE. C C FUNCTION DEFINITION IS OK -- GO ON. C 5 CONTINUE NSEG = N - 1 DO 90 I = 1, NSEG DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I)) C ------------------------------- ISMON(I) = CHFCM (D(1,I), D(1,I+1), DELTA) C ------------------------------- IF (I .EQ. 1) THEN ISMON(N) = ISMON(1) ELSE C Need to figure out cumulative monotonicity from following C "multiplication table": C C + I S M O N (I) C + -3 -1 0 1 3 2 C +------------------------+ C I -3 I -3 -3 -3 2 2 2 I C S -1 I -3 -1 -1 2 2 2 I C M 0 I -3 -1 0 1 3 2 I C O 1 I 2 2 1 1 3 2 I C N 3 I 2 2 3 3 3 2 I C (N) 2 I 2 2 2 2 2 2 I C +------------------------+ C Note that the 2 row and column are out of order so as not C to obscure the symmetry in the rest of the table. C C No change needed if equal or constant on this interval or C already declared nonmonotonic. IF ( (ISMON(I).NE.ISMON(N)) .AND. (ISMON(I).NE.0) . .AND. (ISMON(N).NE.2) ) THEN IF ( (ISMON(I).EQ.2) .OR. (ISMON(N).EQ.0) ) THEN ISMON(N) = ISMON(I) ELSE IF (ISMON(I)*ISMON(N) .LT. 0) THEN C This interval has opposite sense from curve so far. ISMON(N) = 2 ELSE C At this point, both are nonzero with same sign, and C we have already eliminated case both +-1. ISMON(N) = ISIGN (3, ISMON(N)) ENDIF ENDIF ENDIF 90 CONTINUE C C NORMAL RETURN. C IERR = 0 RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHCM', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHCM', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHCM', 'X-ARRAY NOT STRICTLY INCREASING' + , IERR, 1) RETURN C------------- LAST LINE OF PCHCM FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchcs.f0000644060175006010010000002052112562522365015047 0ustar chmNone*DECK PCHCS SUBROUTINE PCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) C***BEGIN PROLOGUE PCHCS C***SUBSIDIARY C***PURPOSE Adjusts derivative values for PCHIC C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHCS-S, DPCHCS-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHCS: PCHIC Monotonicity Switch Derivative Setter. C C Called by PCHIC to adjust the values of D in the vicinity of a C switch in direction of monotonicity, to produce a more "visually C pleasing" curve than that given by PCHIM . C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IERR C REAL SWITCH, H(N), SLOPE(N), D(INCFD,N) C C CALL PCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR) C C Parameters: C C SWITCH -- (input) indicates the amount of control desired over C local excursions from data. C C N -- (input) number of data points. (assumes N.GT.2 .) C C H -- (input) real array of interval lengths. C SLOPE -- (input) real array of data slopes. C If the data are (X(I),Y(I)), I=1(1)N, then these inputs are: C H(I) = X(I+1)-X(I), C SLOPE(I) = (Y(I+1)-Y(I))/H(I), I=1(1)N-1. C C D -- (input) real array of derivative values at the data points, C as determined by PCHCI. C (output) derivatives in the vicinity of switches in direction C of monotonicity may be adjusted to produce a more "visually C pleasing" curve. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in D. C This argument is provided primarily for 2-D applications. C C IERR -- (output) error flag. should be zero. C If negative, trouble in PCHSW. (should never happen.) C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS, MAX, MIN. C C***SEE ALSO PCHIC C***ROUTINES CALLED PCHST, PCHSW C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820617 Redesigned to (1) fix problem with lack of continuity C approaching a flat-topped peak (2) be cleaner and C easier to verify. C Eliminated subroutines PCHSA and PCHSX in the process. C 820622 1. Limited fact to not exceed one, so computed D is a C convex combination of PCHCI value and PCHSD value. C 2. Changed fudge from 1 to 4 (based on experiments). C 820623 Moved PCHSD to an inline function (eliminating MSWTYP). C 820805 Converted to SLATEC library version. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR section in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE PCHCS C C Programming notes: C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IERR REAL SWITCH, H(*), SLOPE(*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER I, INDX, K, NLESS1 REAL DEL(3), DEXT, DFLOC, DFMX, FACT, FUDGE, ONE, SLMAX, * WTAVE(2), ZERO SAVE ZERO, ONE, FUDGE REAL PCHST C C DEFINE INLINE FUNCTION FOR WEIGHTED AVERAGE OF SLOPES. C REAL PCHSD, S1, S2, H1, H2 PCHSD(S1,S2,H1,H2) = (H2/(H1+H2))*S1 + (H1/(H1+H2))*S2 C C INITIALIZE. C DATA ZERO /0./, ONE /1./ DATA FUDGE /4./ C***FIRST EXECUTABLE STATEMENT PCHCS IERR = 0 NLESS1 = N - 1 C C LOOP OVER SEGMENTS. C DO 900 I = 2, NLESS1 IF ( PCHST(SLOPE(I-1),SLOPE(I)) ) 100, 300, 900 C -------------------------- C 100 CONTINUE C C....... SLOPE SWITCHES MONOTONICITY AT I-TH POINT ..................... C C DO NOT CHANGE D IF 'UP-DOWN-UP'. IF (I .GT. 2) THEN IF ( PCHST(SLOPE(I-2),SLOPE(I)) .GT. ZERO) GO TO 900 C -------------------------- ENDIF IF (I .LT. NLESS1) THEN IF ( PCHST(SLOPE(I+1),SLOPE(I-1)) .GT. ZERO) GO TO 900 C ---------------------------- ENDIF C C ....... COMPUTE PROVISIONAL VALUE FOR D(1,I). C DEXT = PCHSD (SLOPE(I-1), SLOPE(I), H(I-1), H(I)) C C ....... DETERMINE WHICH INTERVAL CONTAINS THE EXTREMUM. C IF ( PCHST(DEXT, SLOPE(I-1)) ) 200, 900, 250 C ----------------------- C 200 CONTINUE C DEXT AND SLOPE(I-1) HAVE OPPOSITE SIGNS -- C EXTREMUM IS IN (X(I-1),X(I)). K = I-1 C SET UP TO COMPUTE NEW VALUES FOR D(1,I-1) AND D(1,I). WTAVE(2) = DEXT IF (K .GT. 1) * WTAVE(1) = PCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) GO TO 400 C 250 CONTINUE C DEXT AND SLOPE(I) HAVE OPPOSITE SIGNS -- C EXTREMUM IS IN (X(I),X(I+1)). K = I C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = DEXT IF (K .LT. NLESS1) * WTAVE(2) = PCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) GO TO 400 C 300 CONTINUE C C....... AT LEAST ONE OF SLOPE(I-1) AND SLOPE(I) IS ZERO -- C CHECK FOR FLAT-TOPPED PEAK ....................... C IF (I .EQ. NLESS1) GO TO 900 IF ( PCHST(SLOPE(I-1), SLOPE(I+1)) .GE. ZERO) GO TO 900 C ----------------------------- C C WE HAVE FLAT-TOPPED PEAK ON (X(I),X(I+1)). K = I C SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1). WTAVE(1) = PCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K)) WTAVE(2) = PCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1)) C 400 CONTINUE C C....... AT THIS POINT WE HAVE DETERMINED THAT THERE WILL BE AN EXTREMUM C ON (X(K),X(K+1)), WHERE K=I OR I-1, AND HAVE SET ARRAY WTAVE-- C WTAVE(1) IS A WEIGHTED AVERAGE OF SLOPE(K-1) AND SLOPE(K), C IF K.GT.1 C WTAVE(2) IS A WEIGHTED AVERAGE OF SLOPE(K) AND SLOPE(K+1), C IF K.LT.N-1 C SLMAX = ABS(SLOPE(K)) IF (K .GT. 1) SLMAX = MAX( SLMAX, ABS(SLOPE(K-1)) ) IF (K.LT.NLESS1) SLMAX = MAX( SLMAX, ABS(SLOPE(K+1)) ) C IF (K .GT. 1) DEL(1) = SLOPE(K-1) / SLMAX DEL(2) = SLOPE(K) / SLMAX IF (K.LT.NLESS1) DEL(3) = SLOPE(K+1) / SLMAX C IF ((K.GT.1) .AND. (K.LT.NLESS1)) THEN C NORMAL CASE -- EXTREMUM IS NOT IN A BOUNDARY INTERVAL. FACT = FUDGE* ABS(DEL(3)*(DEL(1)-DEL(2))*(WTAVE(2)/SLMAX)) D(1,K) = D(1,K) + MIN(FACT,ONE)*(WTAVE(1) - D(1,K)) FACT = FUDGE* ABS(DEL(1)*(DEL(3)-DEL(2))*(WTAVE(1)/SLMAX)) D(1,K+1) = D(1,K+1) + MIN(FACT,ONE)*(WTAVE(2) - D(1,K+1)) ELSE C SPECIAL CASE K=1 (WHICH CAN OCCUR ONLY IF I=2) OR C K=NLESS1 (WHICH CAN OCCUR ONLY IF I=NLESS1). FACT = FUDGE* ABS(DEL(2)) D(1,I) = MIN(FACT,ONE) * WTAVE(I-K+1) C NOTE THAT I-K+1 = 1 IF K=I (=NLESS1), C I-K+1 = 2 IF K=I-1(=1). ENDIF C C C....... ADJUST IF NECESSARY TO LIMIT EXCURSIONS FROM DATA. C IF (SWITCH .LE. ZERO) GO TO 900 C DFLOC = H(K)*ABS(SLOPE(K)) IF (K .GT. 1) DFLOC = MAX( DFLOC, H(K-1)*ABS(SLOPE(K-1)) ) IF (K.LT.NLESS1) DFLOC = MAX( DFLOC, H(K+1)*ABS(SLOPE(K+1)) ) DFMX = SWITCH*DFLOC INDX = I-K+1 C INDX = 1 IF K=I, 2 IF K=I-1. C --------------------------------------------------------------- CALL PCHSW (DFMX, INDX, D(1,K), D(1,K+1), H(K), SLOPE(K), IERR) C --------------------------------------------------------------- IF (IERR .NE. 0) RETURN C C....... END OF SEGMENT LOOP. C 900 CONTINUE C RETURN C------------- LAST LINE OF PCHCS FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchdf.f0000644060175006010010000000616212562522365015040 0ustar chmNone*DECK PCHDF REAL FUNCTION PCHDF (K, X, S, IERR) C***BEGIN PROLOGUE PCHDF C***SUBSIDIARY C***PURPOSE Computes divided differences for PCHCE and PCHSP C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHDF-S, DPCHDF-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHDF: PCHIP Finite Difference Formula C C Uses a divided difference formulation to compute a K-point approx- C imation to the derivative at X(K) based on the data in X and S. C C Called by PCHCE and PCHSP to compute 3- and 4-point boundary C derivative approximations. C C ---------------------------------------------------------------------- C C On input: C K is the order of the desired derivative approximation. C K must be at least 3 (error return if not). C X contains the K values of the independent variable. C X need not be ordered, but the values **MUST** be C distinct. (Not checked here.) C S contains the associated slope values: C S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1. C (Note that S need only be of length K-1.) C C On return: C S will be destroyed. C IERR will be set to -1 if K.LT.2 . C PCHDF will be set to the desired derivative approximation if C IERR=0 or to zero if IERR=-1. C C ---------------------------------------------------------------------- C C***SEE ALSO PCHCE, PCHSP C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- C Verlag, New York, 1978, pp. 10-16. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 820503 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890411 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) C 920429 Revised format and order of references. (WRB,FNF) C 930503 Improved purpose. (FNF) C***END PROLOGUE PCHDF C C**End C C DECLARE ARGUMENTS. C INTEGER K, IERR REAL X(K), S(K) C C DECLARE LOCAL VARIABLES. C INTEGER I, J REAL VALUE, ZERO SAVE ZERO DATA ZERO /0./ C C CHECK FOR LEGAL VALUE OF K. C C***FIRST EXECUTABLE STATEMENT PCHDF IF (K .LT. 3) GO TO 5001 C C COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL. C DO 10 J = 2, K-1 DO 9 I = 1, K-J S(I) = (S(I+1)-S(I))/(X(I+J)-X(I)) 9 CONTINUE 10 CONTINUE C C EVALUATE DERIVATIVE AT X(K). C VALUE = S(1) DO 20 I = 2, K-1 VALUE = S(I) + VALUE*(X(K)-X(I)) 20 CONTINUE C C NORMAL RETURN. C IERR = 0 PCHDF = VALUE RETURN C C ERROR RETURN. C 5001 CONTINUE C K.LT.3 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHDF', 'K LESS THAN THREE', IERR, 1) PCHDF = ZERO RETURN C------------- LAST LINE OF PCHDF FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchfd.f0000644060175006010010000002505612562522365015043 0ustar chmNone*DECK PCHFD SUBROUTINE PCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) C***BEGIN PROLOGUE PCHFD C***PURPOSE Evaluate a piecewise cubic Hermite function and its first C derivative at an array of points. May be used by itself C for Hermite interpolation, or as an evaluator for PCHIM C or PCHIC. If only function values are required, use C PCHFE instead. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H1 C***TYPE SINGLE PRECISION (PCHFD-S, DPCHFD-D) C***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, C HERMITE INTERPOLATION, PCHIP, PIECEWISE CUBIC EVALUATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C PCHFD: Piecewise Cubic Hermite Function and Derivative C evaluator C C Evaluates the cubic Hermite function defined by N, X, F, D, to- C gether with its first derivative, at the points XE(J), J=1(1)NE. C C If only function values are required, use PCHFE, instead. C C To provide compatibility with PCHIM and PCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, NE, IERR C REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE), DE(NE) C LOGICAL SKIP C C CALL PCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR) C C Parameters: C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is C the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in PCHIM or PCHIC). C SKIP will be set to .TRUE. on normal return. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real array of points at which the functions are to C be evaluated. C C C NOTES: C 1. The evaluation will be most efficient if the elements C of XE are increasing relative to X; C that is, XE(J) .GE. X(I) C implies XE(K) .GE. X(I), all K.GE.J . C 2. If any of the XE are outside the interval [X(1),X(N)], C values are extrapolated from the nearest extreme cubic, C and a warning error is returned. C C FE -- (output) real array of values of the cubic Hermite function C defined by N, X, F, D at the points XE. C C DE -- (output) real array of values of the first derivative of C the same function at the points XE. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning error: C IERR.GT.0 means that extrapolation was performed at C IERR points. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if NE.LT.1 . C (Output arrays have not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C IERR = -5 if an error has occurred in the lower-level C routine CHFDV. NB: this should never happen. C Notify the author **IMMEDIATELY** if it does. C C***REFERENCES (NONE) C***ROUTINES CALLED CHFDV, XERMSG C***REVISION HISTORY (YYMMDD) C 811020 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 870707 Minor cosmetic changes to prologue. C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE PCHFD C Programming notes: C C 1. To produce a double precision version, simply: C a. Change PCHFD to DPCHFD, and CHFDV to DCHFDV, wherever they C occur, C b. Change the real declaration to double precision, C C 2. Most of the coding between the call to CHFDV and the end of C the IR-loop could be eliminated if it were permissible to C assume that XE is ordered relative to X. C C 3. CHFDV does not assume that X1 is less than X2. thus, it would C be possible to write a version of PCHFD that assumes a strict- C ly decreasing X-array by simply running the IR-loop backwards C (and reversing the order of appropriate tests). C C 4. The present code has a minor bug, which I have decided is not C worth the effort that would be required to fix it. C If XE contains points in [X(N-1),X(N)], followed by points .LT. C X(N-1), followed by points .GT.X(N), the extrapolation points C will be counted (at least) twice in the total returned in IERR. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, NE, IERR REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*), DE(*) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT PCHFD IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE IF ( NE.LT.1 ) GO TO 5004 IERR = 0 SKIP = .TRUE. C C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE C C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. C IF (JFIRST .GT. NE) GO TO 5000 C C LOCATE ALL POINTS IN INTERVAL. C DO 20 J = JFIRST, NE IF (XE(J) .GE. X(IR)) GO TO 30 20 CONTINUE J = NE + 1 GO TO 40 C C HAVE LOCATED FIRST POINT BEYOND INTERVAL. C 30 CONTINUE IF (IR .EQ. N) J = NE + 1 C 40 CONTINUE NJ = J - JFIRST C C SKIP EVALUATION IF NO POINTS IN INTERVAL. C IF (NJ .EQ. 0) GO TO 50 C C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . C C ---------------------------------------------------------------- CALL CHFDV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), * NJ, XE(JFIRST), FE(JFIRST), DE(JFIRST), NEXT, IERC) C ---------------------------------------------------------------- IF (IERC .LT. 0) GO TO 5005 C IF (NEXT(2) .EQ. 0) GO TO 42 C IF (NEXT(2) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE C RIGHT OF X(IR). C IF (IR .LT. N) GO TO 41 C IF (IR .EQ. N) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) GO TO 42 41 CONTINUE C ELSE C WE SHOULD NEVER HAVE GOTTEN HERE. GO TO 5005 C ENDIF C ENDIF 42 CONTINUE C IF (NEXT(1) .EQ. 0) GO TO 49 C IF (NEXT(1) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE C LEFT OF X(IR-1). C IF (IR .GT. 2) GO TO 43 C IF (IR .EQ. 2) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) GO TO 49 43 CONTINUE C ELSE C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST C EVALUATION INTERVAL. C C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 IF (XE(I) .LT. X(IR-1)) GO TO 45 44 CONTINUE C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR C IN CHFDV. GO TO 5005 C 45 CONTINUE C RESET J. (THIS WILL BE THE NEW JFIRST.) J = I C C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 IF (XE(J) .LT. X(I)) GO TO 47 46 CONTINUE C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). C 47 CONTINUE C AT THIS POINT, EITHER XE(J) .LT. X(1) C OR X(I-1) .LE. XE(J) .LT. X(I) . C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE C CYCLING. IR = MAX(1, I-1) C ENDIF C ENDIF 49 CONTINUE C JFIRST = J C C END OF IR-LOOP. C 50 CONTINUE IR = IR + 1 IF (IR .LE. N) GO TO 10 C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHFD', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHFD', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHFD', 'X-ARRAY NOT STRICTLY INCREASING' + , IERR, 1) RETURN C 5004 CONTINUE C NE.LT.1 RETURN. IERR = -4 CALL XERMSG ('SLATEC', 'PCHFD', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5005 CONTINUE C ERROR RETURN FROM CHFDV. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 CALL XERMSG ('SLATEC', 'PCHFD', + 'ERROR RETURN FROM CHFDV -- FATAL', IERR, 2) RETURN C------------- LAST LINE OF PCHFD FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchfe.f0000644060175006010010000002363612562522365015046 0ustar chmNone*DECK PCHFE SUBROUTINE PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) C***BEGIN PROLOGUE PCHFE C***PURPOSE Evaluate a piecewise cubic Hermite function at an array of C points. May be used by itself for Hermite interpolation, C or as an evaluator for PCHIM or PCHIC. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE SINGLE PRECISION (PCHFE-S, DPCHFE-D) C***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, C PIECEWISE CUBIC EVALUATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C PCHFE: Piecewise Cubic Hermite Function Evaluator C C Evaluates the cubic Hermite function defined by N, X, F, D at C the points XE(J), J=1(1)NE. C C To provide compatibility with PCHIM and PCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, NE, IERR C REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) C LOGICAL SKIP C C CALL PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) C C Parameters: C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is C the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in PCHIM or PCHIC). C SKIP will be set to .TRUE. on normal return. C C NE -- (input) number of evaluation points. (Error return if C NE.LT.1 .) C C XE -- (input) real array of points at which the function is to be C evaluated. C C NOTES: C 1. The evaluation will be most efficient if the elements C of XE are increasing relative to X; C that is, XE(J) .GE. X(I) C implies XE(K) .GE. X(I), all K.GE.J . C 2. If any of the XE are outside the interval [X(1),X(N)], C values are extrapolated from the nearest extreme cubic, C and a warning error is returned. C C FE -- (output) real array of values of the cubic Hermite function C defined by N, X, F, D at the points XE. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning error: C IERR.GT.0 means that extrapolation was performed at C IERR points. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if NE.LT.1 . C (The FE-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES (NONE) C***ROUTINES CALLED CHFEV, XERMSG C***REVISION HISTORY (YYMMDD) C 811020 DATE WRITTEN C 820803 Minor cosmetic changes for release 1. C 870707 Minor cosmetic changes to prologue. C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C***END PROLOGUE PCHFE C Programming notes: C C 1. To produce a double precision version, simply: C a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they C occur, C b. Change the real declaration to double precision, C C 2. Most of the coding between the call to CHFEV and the end of C the IR-loop could be eliminated if it were permissible to C assume that XE is ordered relative to X. C C 3. CHFEV does not assume that X1 is less than X2. thus, it would C be possible to write a version of PCHFE that assumes a strict- C ly decreasing X-array by simply running the IR-loop backwards C (and reversing the order of appropriate tests). C C 4. The present code has a minor bug, which I have decided is not C worth the effort that would be required to fix it. C If XE contains points in [X(N-1),X(N)], followed by points .LT. C X(N-1), followed by points .GT.X(N), the extrapolation points C will be counted (at least) twice in the total returned in IERR. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, NE, IERR REAL X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IERC, IR, J, JFIRST, NEXT(2), NJ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT PCHFE IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE IF ( NE.LT.1 ) GO TO 5004 IERR = 0 SKIP = .TRUE. C C LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) C ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) JFIRST = 1 IR = 2 10 CONTINUE C C SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. C IF (JFIRST .GT. NE) GO TO 5000 C C LOCATE ALL POINTS IN INTERVAL. C DO 20 J = JFIRST, NE IF (XE(J) .GE. X(IR)) GO TO 30 20 CONTINUE J = NE + 1 GO TO 40 C C HAVE LOCATED FIRST POINT BEYOND INTERVAL. C 30 CONTINUE IF (IR .EQ. N) J = NE + 1 C 40 CONTINUE NJ = J - JFIRST C C SKIP EVALUATION IF NO POINTS IN INTERVAL. C IF (NJ .EQ. 0) GO TO 50 C C EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . C C ---------------------------------------------------------------- CALL CHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR), * NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC) C ---------------------------------------------------------------- IF (IERC .LT. 0) GO TO 5005 C IF (NEXT(2) .EQ. 0) GO TO 42 C IF (NEXT(2) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE C RIGHT OF X(IR). C IF (IR .LT. N) GO TO 41 C IF (IR .EQ. N) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(2) GO TO 42 41 CONTINUE C ELSE C WE SHOULD NEVER HAVE GOTTEN HERE. GO TO 5005 C ENDIF C ENDIF 42 CONTINUE C IF (NEXT(1) .EQ. 0) GO TO 49 C IF (NEXT(1) .GT. 0) THEN C IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE C LEFT OF X(IR-1). C IF (IR .GT. 2) GO TO 43 C IF (IR .EQ. 2) THEN C THESE ARE ACTUALLY EXTRAPOLATION POINTS. IERR = IERR + NEXT(1) GO TO 49 43 CONTINUE C ELSE C XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST C EVALUATION INTERVAL. C C FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). DO 44 I = JFIRST, J-1 IF (XE(I) .LT. X(IR-1)) GO TO 45 44 CONTINUE C NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR C IN CHFEV. GO TO 5005 C 45 CONTINUE C RESET J. (THIS WILL BE THE NEW JFIRST.) J = I C C NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. DO 46 I = 1, IR-1 IF (XE(J) .LT. X(I)) GO TO 47 46 CONTINUE C NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). C 47 CONTINUE C AT THIS POINT, EITHER XE(J) .LT. X(1) C OR X(I-1) .LE. XE(J) .LT. X(I) . C RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE C CYCLING. IR = MAX(1, I-1) C ENDIF C ENDIF 49 CONTINUE C JFIRST = J C C END OF IR-LOOP. C 50 CONTINUE IR = IR + 1 IF (IR .LE. N) GO TO 10 C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHFE', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHFE', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHFE', 'X-ARRAY NOT STRICTLY INCREASING' + , IERR, 1) RETURN C 5004 CONTINUE C NE.LT.1 RETURN. IERR = -4 CALL XERMSG ('SLATEC', 'PCHFE', + 'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1) RETURN C 5005 CONTINUE C ERROR RETURN FROM CHFEV. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -5 CALL XERMSG ('SLATEC', 'PCHFE', + 'ERROR RETURN FROM CHFEV -- FATAL', IERR, 2) RETURN C------------- LAST LINE OF PCHFE FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchia.f0000644060175006010010000002262112562522365015036 0ustar chmNone*DECK PCHIA REAL FUNCTION PCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) C***BEGIN PROLOGUE PCHIA C***PURPOSE Evaluate the definite integral of a piecewise cubic C Hermite function over an arbitrary interval. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H2A1B2 C***TYPE SINGLE PRECISION (PCHIA-S, DPCHIA-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, C QUADRATURE C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C PCHIA: Piecewise Cubic Hermite Integrator, Arbitrary limits C C Evaluates the definite integral of the cubic Hermite function C defined by N, X, F, D over the interval [A, B]. C C To provide compatibility with PCHIM and PCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IERR C REAL X(N), F(INCFD,N), D(INCFD,N), A, B C REAL VALUE, PCHIA C LOGICAL SKIP C C VALUE = PCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR) C C Parameters: C C VALUE -- (output) value of the requested integral. C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is C the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in PCHIM or PCHIC). C SKIP will be set to .TRUE. on return with IERR.GE.0 . C C A,B -- (input) the limits of integration. C NOTE: There is no requirement that [A,B] be contained in C [X(1),X(N)]. However, the resulting integral value C will be highly suspect, if not. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning errors: C IERR = 1 if A is outside the interval [X(1),X(N)]. C IERR = 2 if B is outside the interval [X(1),X(N)]. C IERR = 3 if both of the above are true. (Note that this C means that either [A,B] contains data interval C or the intervals do not intersect at all.) C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C (VALUE will be zero in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C IERR = -4 in case of an error return from PCHID (which C should never occur). C C***REFERENCES (NONE) C***ROUTINES CALLED CHFIE, PCHID, XERMSG C***REVISION HISTORY (YYMMDD) C 820730 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870707 Corrected double precision conversion instructions. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 930503 Corrected to set VALUE=0 when IERR.lt.0. (FNF) C 930504 Changed CHFIV to CHFIE. (FNF) C***END PROLOGUE PCHIA C C Programming notes: C 1. The error flag from PCHID is tested, because a logic flaw C could conceivably result in IERD=-4, which should be reported. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IERR REAL X(*), F(INCFD,*), D(INCFD,*), A, B LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IA, IB, IERD, IL, IR REAL VALUE, XA, XB, ZERO SAVE ZERO REAL CHFIE, PCHID C C INITIALIZE. C DATA ZERO /0./ C***FIRST EXECUTABLE STATEMENT PCHIA VALUE = ZERO C C VALIDITY-CHECK ARGUMENTS. C IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE SKIP = .TRUE. IERR = 0 IF ( (A.LT.X(1)) .OR. (A.GT.X(N)) ) IERR = IERR + 1 IF ( (B.LT.X(1)) .OR. (B.GT.X(N)) ) IERR = IERR + 2 C C COMPUTE INTEGRAL VALUE. C IF (A .NE. B) THEN XA = MIN (A, B) XB = MAX (A, B) IF (XB .LE. X(2)) THEN C INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC. C -------------------------------------- VALUE = CHFIE (X(1),X(2), F(1,1),F(1,2), + D(1,1),D(1,2), A, B) C -------------------------------------- ELSE IF (XA .GE. X(N-1)) THEN C INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC. C ----------------------------------------- VALUE = CHFIE(X(N-1),X(N), F(1,N-1),F(1,N), + D(1,N-1),D(1,N), A, B) C ----------------------------------------- ELSE C 'NORMAL' CASE -- XA.LT.XB, XA.LT.X(N-1), XB.GT.X(2). C ......LOCATE IA AND IB SUCH THAT C X(IA-1).LT.XA.LE.X(IA).LE.X(IB).LE.XB.LE.X(IB+1) IA = 1 DO 10 I = 1, N-1 IF (XA .GT. X(I)) IA = I + 1 10 CONTINUE C IA = 1 IMPLIES XA.LT.X(1) . OTHERWISE, C IA IS LARGEST INDEX SUCH THAT X(IA-1).LT.XA,. C IB = N DO 20 I = N, IA, -1 IF (XB .LT. X(I)) IB = I - 1 20 CONTINUE C IB = N IMPLIES XB.GT.X(N) . OTHERWISE, C IB IS SMALLEST INDEX SUCH THAT XB.LT.X(IB+1) . C C ......COMPUTE THE INTEGRAL. IF (IB .LT. IA) THEN C THIS MEANS IB = IA-1 AND C (A,B) IS A SUBSET OF (X(IB),X(IA)). C ------------------------------------------ VALUE = CHFIE (X(IB),X(IA), F(1,IB),F(1,IA), + D(1,IB),D(1,IA), A, B) C ------------------------------------------ ELSE C C FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)). C (Case (IB .EQ. IA) is taken care of by initialization C of VALUE to ZERO.) IF (IB .GT. IA) THEN C --------------------------------------------- VALUE = PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD) C --------------------------------------------- IF (IERD .LT. 0) GO TO 5004 ENDIF C C THEN ADD ON INTEGRAL OVER (XA,X(IA)). IF (XA .LT. X(IA)) THEN IL = MAX(1, IA-1) IR = IL + 1 C ------------------------------------- VALUE = VALUE + CHFIE (X(IL),X(IR), F(1,IL),F(1,IR), + D(1,IL),D(1,IR), XA, X(IA)) C ------------------------------------- ENDIF C C THEN ADD ON INTEGRAL OVER (X(IB),XB). IF (XB .GT. X(IB)) THEN IR = MIN (IB+1, N) IL = IR - 1 C ------------------------------------- VALUE = VALUE + CHFIE (X(IL),X(IR), F(1,IL),F(1,IR), + D(1,IL),D(1,IR), X(IB), XB) C ------------------------------------- ENDIF C C FINALLY, ADJUST SIGN IF NECESSARY. IF (A .GT. B) VALUE = -VALUE ENDIF ENDIF ENDIF C C NORMAL RETURN. C 5000 CONTINUE PCHIA = VALUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHIA', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) GO TO 5000 C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHIA', 'INCREMENT LESS THAN ONE', IERR, + 1) GO TO 5000 C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHIA', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) GO TO 5000 C 5004 CONTINUE C TROUBLE IN PCHID. (SHOULD NEVER OCCUR.) IERR = -4 CALL XERMSG ('SLATEC', 'PCHIA', 'TROUBLE IN PCHID', IERR, 1) GO TO 5000 C------------- LAST LINE OF PCHIA FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchic.f0000644060175006010010000003224312562522365015041 0ustar chmNone*DECK PCHIC SUBROUTINE PCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, + IERR) C***BEGIN PROLOGUE PCHIC C***PURPOSE Set derivatives needed to determine a piecewise monotone C piecewise cubic Hermite interpolant to given data. C User control is available over boundary conditions and/or C treatment of points where monotonicity switches direction. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E1A C***TYPE SINGLE PRECISION (PCHIC-S, DPCHIC-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, C PCHIP, PIECEWISE CUBIC INTERPOLATION, C SHAPE-PRESERVING INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C PCHIC: Piecewise Cubic Hermite Interpolation Coefficients. C C Sets derivatives needed to determine a piecewise monotone piece- C wise cubic interpolant to the data given in X and F satisfying the C boundary conditions specified by IC and VC. C C The treatment of points where monotonicity switches direction is C controlled by argument SWITCH. C C To facilitate two-dimensional applications, includes an increment C between successive values of the F- and D-arrays. C C The resulting piecewise cubic Hermite function may be evaluated C by PCHFE or PCHFD. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER IC(2), N, NWK, IERR C REAL VC(2), SWITCH, X(N), F(INCFD,N), D(INCFD,N), WK(NWK) C C CALL PCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, IERR) C C Parameters: C C IC -- (input) integer array of length 2 specifying desired C boundary conditions: C IC(1) = IBEG, desired condition at beginning of data. C IC(2) = IEND, desired condition at end of data. C C IBEG = 0 for the default boundary condition (the same as C used by PCHIM). C If IBEG.NE.0, then its sign indicates whether the boundary C derivative is to be adjusted, if necessary, to be C compatible with monotonicity: C IBEG.GT.0 if no adjustment is to be performed. C IBEG.LT.0 if the derivative is to be adjusted for C monotonicity. C C Allowable values for the magnitude of IBEG are: C IBEG = 1 if first derivative at X(1) is given in VC(1). C IBEG = 2 if second derivative at X(1) is given in VC(1). C IBEG = 3 to use the 3-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.3 .) C IBEG = 4 to use the 4-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.4 .) C IBEG = 5 to set D(1) so that the second derivative is con- C tinuous at X(2). (Reverts to the default b.c. if N.LT.4.) C This option is somewhat analogous to the "not a knot" C boundary condition provided by PCHSP. C C NOTES (IBEG): C 1. An error return is taken if ABS(IBEG).GT.5 . C 2. Only in case IBEG.LE.0 is it guaranteed that the C interpolant will be monotonic in the first interval. C If the returned value of D(1) lies between zero and C 3*SLOPE(1), the interpolant will be monotonic. This C is **NOT** checked if IBEG.GT.0 . C 3. If IBEG.LT.0 and D(1) had to be changed to achieve mono- C tonicity, a warning error is returned. C C IEND may take on the same values as IBEG, but applied to C derivative at X(N). In case IEND = 1 or 2, the value is C given in VC(2). C C NOTES (IEND): C 1. An error return is taken if ABS(IEND).GT.5 . C 2. Only in case IEND.LE.0 is it guaranteed that the C interpolant will be monotonic in the last interval. C If the returned value of D(1+(N-1)*INCFD) lies between C zero and 3*SLOPE(N-1), the interpolant will be monotonic. C This is **NOT** checked if IEND.GT.0 . C 3. If IEND.LT.0 and D(1+(N-1)*INCFD) had to be changed to C achieve monotonicity, a warning error is returned. C C VC -- (input) real array of length 2 specifying desired boundary C values, as indicated above. C VC(1) need be set only if IC(1) = 1 or 2 . C VC(2) need be set only if IC(2) = 1 or 2 . C C SWITCH -- (input) indicates desired treatment of points where C direction of monotonicity switches: C Set SWITCH to zero if interpolant is required to be mono- C tonic in each interval, regardless of monotonicity of data. C NOTES: C 1. This will cause D to be set to zero at all switch C points, thus forcing extrema there. C 2. The result of using this option with the default boun- C dary conditions will be identical to using PCHIM, but C will generally cost more compute time. C This option is provided only to facilitate comparison C of different switch and/or boundary conditions. C Set SWITCH nonzero to use a formula based on the 3-point C difference formula in the vicinity of switch points. C If SWITCH is positive, the interpolant on each interval C containing an extremum is controlled to not deviate from C the data by more than SWITCH*DFLOC, where DFLOC is the C maximum of the change of F on this interval and its two C immediate neighbors. C If SWITCH is negative, no such control is to be imposed. C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real array of dependent variable values to be inter- C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). C C D -- (output) real array of derivative values at the data points. C These values will determine a monotone cubic Hermite func- C tion on each subinterval on which the data are monotonic, C except possibly adjacent to switches in monotonicity. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C (Error return if INCFD.LT.1 .) C C WK -- (scratch) real array of working storage. The user may wish C to know that the returned values are: C WK(I) = H(I) = X(I+1) - X(I) ; C WK(N-1+I) = SLOPE(I) = (F(1,I+1) - F(1,I)) / H(I) C for I = 1(1)N-1. C C NWK -- (input) length of work array. C (Error return if NWK.LT.2*(N-1) .) C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning errors: C IERR = 1 if IBEG.LT.0 and D(1) had to be adjusted for C monotonicity. C IERR = 2 if IEND.LT.0 and D(1+(N-1)*INCFD) had to be C adjusted for monotonicity. C IERR = 3 if both of the above are true. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if ABS(IBEG).GT.5 . C IERR = -5 if ABS(IEND).GT.5 . C IERR = -6 if both of the above are true. C IERR = -7 if NWK.LT.2*(N-1) . C (The D-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES 1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation C Package, Report UCRL-87285, Lawrence Livermore Nation- C al Laboratory, July 1982. [Poster presented at the C SIAM 30th Anniversary Meeting, 19-23 July 1982.] C 2. F. N. Fritsch and J. Butland, A method for construc- C ting local monotone piecewise cubic interpolants, SIAM C Journal on Scientific and Statistical Computing 5, 2 C (June 1984), pp. 300-304. C 3. F. N. Fritsch and R. E. Carlson, Monotone piecewise C cubic interpolation, SIAM Journal on Numerical Ana- C lysis 17, 2 (April 1980), pp. 238-246. C***ROUTINES CALLED PCHCE, PCHCI, PCHCS, XERMSG C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870813 Updated Reference 2. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE PCHIC C Programming notes: C C To produce a double precision version, simply: C a. Change PCHIC to DPCHIC wherever it occurs, C b. Change PCHCE to DPCHCE wherever it occurs, C c. Change PCHCI to DPCHCI wherever it occurs, C d. Change PCHCS to DPCHCS wherever it occurs, C e. Change the real declarations to double precision, and C f. Change the constant ZERO to double precision. C C DECLARE ARGUMENTS. C INTEGER IC(2), N, INCFD, NWK, IERR REAL VC(2), SWITCH, X(*), F(INCFD,*), D(INCFD,*), WK(NWK) C C DECLARE LOCAL VARIABLES. C INTEGER I, IBEG, IEND, NLESS1 REAL ZERO SAVE ZERO DATA ZERO /0./ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT PCHIC IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C IBEG = IC(1) IEND = IC(2) IERR = 0 IF (ABS(IBEG) .GT. 5) IERR = IERR - 1 IF (ABS(IEND) .GT. 5) IERR = IERR - 2 IF (IERR .LT. 0) GO TO 5004 C C FUNCTION DEFINITION IS OK -- GO ON. C NLESS1 = N - 1 IF ( NWK .LT. 2*NLESS1 ) GO TO 5007 C C SET UP H AND SLOPE ARRAYS. C DO 20 I = 1, NLESS1 WK(I) = X(I+1) - X(I) WK(NLESS1+I) = (F(1,I+1) - F(1,I)) / WK(I) 20 CONTINUE C C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. C IF (NLESS1 .GT. 1) GO TO 1000 D(1,1) = WK(2) D(1,N) = WK(2) GO TO 3000 C C NORMAL CASE (N .GE. 3) . C 1000 CONTINUE C C SET INTERIOR DERIVATIVES AND DEFAULT END CONDITIONS. C C -------------------------------------- CALL PCHCI (N, WK(1), WK(N), D, INCFD) C -------------------------------------- C C SET DERIVATIVES AT POINTS WHERE MONOTONICITY SWITCHES DIRECTION. C IF (SWITCH .EQ. ZERO) GO TO 3000 C ---------------------------------------------------- CALL PCHCS (SWITCH, N, WK(1), WK(N), D, INCFD, IERR) C ---------------------------------------------------- IF (IERR .NE. 0) GO TO 5008 C C SET END CONDITIONS. C 3000 CONTINUE IF ( (IBEG.EQ.0) .AND. (IEND.EQ.0) ) GO TO 5000 C ------------------------------------------------------- CALL PCHCE (IC, VC, N, X, WK(1), WK(N), D, INCFD, IERR) C ------------------------------------------------------- IF (IERR .LT. 0) GO TO 5009 C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHIC', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHIC', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHIC', 'X-ARRAY NOT STRICTLY INCREASING' + , IERR, 1) RETURN C 5004 CONTINUE C IC OUT OF RANGE RETURN. IERR = IERR - 3 CALL XERMSG ('SLATEC', 'PCHIC', 'IC OUT OF RANGE', IERR, 1) RETURN C 5007 CONTINUE C NWK .LT. 2*(N-1) RETURN. IERR = -7 CALL XERMSG ('SLATEC', 'PCHIC', 'WORK ARRAY TOO SMALL', IERR, 1) RETURN C 5008 CONTINUE C ERROR RETURN FROM PCHCS. IERR = -8 CALL XERMSG ('SLATEC', 'PCHIC', 'ERROR RETURN FROM PCHCS', IERR, + 1) RETURN C 5009 CONTINUE C ERROR RETURN FROM PCHCE. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 CALL XERMSG ('SLATEC', 'PCHIC', 'ERROR RETURN FROM PCHCE', IERR, + 1) RETURN C------------- LAST LINE OF PCHIC FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchid.f0000644060175006010010000001366412562522365015050 0ustar chmNone*DECK PCHID REAL FUNCTION PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) C***BEGIN PROLOGUE PCHID C***PURPOSE Evaluate the definite integral of a piecewise cubic C Hermite function over an interval whose endpoints are data C points. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3, H2A1B2 C***TYPE SINGLE PRECISION (PCHID-S, DPCHID-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP, C QUADRATURE C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C PCHID: Piecewise Cubic Hermite Integrator, Data limits C C Evaluates the definite integral of the cubic Hermite function C defined by N, X, F, D over the interval [X(IA), X(IB)]. C C To provide compatibility with PCHIM and PCHIC, includes an C increment between successive values of the F- and D-arrays. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IA, IB, IERR C REAL X(N), F(INCFD,N), D(INCFD,N) C LOGICAL SKIP C C VALUE = PCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR) C C Parameters: C C VALUE -- (output) value of the requested integral. C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real array of function values. F(1+(I-1)*INCFD) is C the value corresponding to X(I). C C D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is C the value corresponding to X(I). C C INCFD -- (input) increment between successive values in F and D. C (Error return if INCFD.LT.1 .) C C SKIP -- (input/output) logical variable which should be set to C .TRUE. if the user wishes to skip checks for validity of C preceding parameters, or to .FALSE. otherwise. C This will save time in case these checks have already C been performed (say, in PCHIM or PCHIC). C SKIP will be set to .TRUE. on return with IERR = 0 or -4. C C IA,IB -- (input) indices in X-array for the limits of integration. C both must be in the range [1,N]. (Error return if not.) C No restrictions on their relative values. C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if IA or IB is out of range. C (VALUE will be zero in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 820723 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 930504 Corrected to set VALUE=0 when IERR.ne.0. (FNF) C***END PROLOGUE PCHID C C Programming notes: C 1. This routine uses a special formula that is valid only for C integrals whose limits coincide with data values. This is C mathematically equivalent to, but much more efficient than, C calls to CHFIE. C**End C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IA, IB, IERR REAL X(*), F(INCFD,*), D(INCFD,*) LOGICAL SKIP C C DECLARE LOCAL VARIABLES. C INTEGER I, IUP, LOW REAL H, HALF, SIX, SUM, VALUE, ZERO SAVE ZERO, HALF, SIX C C INITIALIZE. C DATA ZERO /0./, HALF /0.5/, SIX /6./ C***FIRST EXECUTABLE STATEMENT PCHID VALUE = ZERO C C VALIDITY-CHECK ARGUMENTS. C IF (SKIP) GO TO 5 C IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C 5 CONTINUE SKIP = .TRUE. IF ((IA.LT.1) .OR. (IA.GT.N)) GO TO 5004 IF ((IB.LT.1) .OR. (IB.GT.N)) GO TO 5004 IERR = 0 C C COMPUTE INTEGRAL VALUE. C IF (IA .NE. IB) THEN LOW = MIN(IA, IB) IUP = MAX(IA, IB) - 1 SUM = ZERO DO 10 I = LOW, IUP H = X(I+1) - X(I) SUM = SUM + H*( (F(1,I) + F(1,I+1)) + * (D(1,I) - D(1,I+1))*(H/SIX) ) 10 CONTINUE VALUE = HALF * SUM IF (IA .GT. IB) VALUE = -VALUE ENDIF C C NORMAL RETURN. C 5000 CONTINUE PCHID = VALUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHID', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) GO TO 5000 C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHID', 'INCREMENT LESS THAN ONE', IERR, + 1) GO TO 5000 C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHID', + 'X-ARRAY NOT STRICTLY INCREASING', IERR, 1) GO TO 5000 C 5004 CONTINUE C IA OR IB OUT OF RANGE RETURN. IERR = -4 CALL XERMSG ('SLATEC', 'PCHID', 'IA OR IB OUT OF RANGE', IERR, 1) GO TO 5000 C------------- LAST LINE OF PCHID FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchim.f0000644060175006010010000002274412562522365015060 0ustar chmNone*DECK PCHIM SUBROUTINE PCHIM (N, X, F, D, INCFD, IERR) C***BEGIN PROLOGUE PCHIM C***PURPOSE Set derivatives needed to determine a monotone piecewise C cubic Hermite interpolant to given data. Boundary values C are provided which are compatible with monotonicity. The C interpolant will have an extremum at each point where mono- C tonicity switches direction. (See PCHIC if user control is C desired over boundary or switch conditions.) C***LIBRARY SLATEC (PCHIP) C***CATEGORY E1A C***TYPE SINGLE PRECISION (PCHIM-S, DPCHIM-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, C PCHIP, PIECEWISE CUBIC INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C PCHIM: Piecewise Cubic Hermite Interpolation to C Monotone data. C C Sets derivatives needed to determine a monotone piecewise cubic C Hermite interpolant to the data given in X and F. C C Default boundary conditions are provided which are compatible C with monotonicity. (See PCHIC if user control of boundary con- C ditions is desired.) C C If the data are only piecewise monotonic, the interpolant will C have an extremum at each point where monotonicity switches direc- C tion. (See PCHIC if user control is desired in such cases.) C C To facilitate two-dimensional applications, includes an increment C between successive values of the F- and D-arrays. C C The resulting piecewise cubic Hermite function may be evaluated C by PCHFE or PCHFD. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER N, IERR C REAL X(N), F(INCFD,N), D(INCFD,N) C C CALL PCHIM (N, X, F, D, INCFD, IERR) C C Parameters: C C N -- (input) number of data points. (Error return if N.LT.2 .) C If N=2, simply does linear interpolation. C C X -- (input) real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real array of dependent variable values to be inter- C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). C PCHIM is designed for monotonic data, but it will work for C any F-array. It will force extrema at points where mono- C tonicity switches direction. If some other treatment of C switch points is desired, PCHIC should be used instead. C ----- C D -- (output) real array of derivative values at the data points. C If the data are monotonic, these values will determine a C a monotone cubic Hermite function. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C (Error return if INCFD.LT.1 .) C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C Warning error: C IERR.GT.0 means that IERR switches in the direction C of monotonicity were detected. C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C (The D-array has not been changed in any of these cases.) C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C C***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- C ting local monotone piecewise cubic interpolants, SIAM C Journal on Scientific and Statistical Computing 5, 2 C (June 1984), pp. 300-304. C 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise C cubic interpolation, SIAM Journal on Numerical Ana- C lysis 17, 2 (April 1980), pp. 238-246. C***ROUTINES CALLED PCHST, XERMSG C***REVISION HISTORY (YYMMDD) C 811103 DATE WRITTEN C 820201 1. Introduced PCHST to reduce possible over/under- C flow problems. C 2. Rearranged derivative formula for same reason. C 820602 1. Modified end conditions to be continuous functions C of data when monotonicity switches in next interval. C 2. Modified formulas so end conditions are less prone C of over/underflow problems. C 820803 Minor cosmetic changes for release 1. C 870813 Updated Reference 1. C 890411 Added SAVE statements (Vers. 3.2). C 890531 Changed all specific intrinsics to generic. (WRB) C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE PCHIM C Programming notes: C C 1. The function PCHST(ARG1,ARG2) is assumed to return zero if C either argument is zero, +1 if they are of the same sign, and C -1 if they are of opposite sign. C 2. To produce a double precision version, simply: C a. Change PCHIM to DPCHIM wherever it occurs, C b. Change PCHST to DPCHST wherever it occurs, C c. Change all references to the Fortran intrinsics to their C double precision equivalents, C d. Change the real declarations to double precision, and C e. Change the constants ZERO and THREE to double precision. C C DECLARE ARGUMENTS. C INTEGER N, INCFD, IERR REAL X(*), F(INCFD,*), D(INCFD,*) C C DECLARE LOCAL VARIABLES. C INTEGER I, NLESS1 REAL DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE, * H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO SAVE ZERO, THREE REAL PCHST DATA ZERO /0./, THREE /3./ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT PCHIM IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 I = 2, N IF ( X(I).LE.X(I-1) ) GO TO 5003 1 CONTINUE C C FUNCTION DEFINITION IS OK, GO ON. C IERR = 0 NLESS1 = N - 1 H1 = X(2) - X(1) DEL1 = (F(1,2) - F(1,1))/H1 DSAVE = DEL1 C C SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. C IF (NLESS1 .GT. 1) GO TO 10 D(1,1) = DEL1 D(1,N) = DEL1 GO TO 5000 C C NORMAL CASE (N .GE. 3). C 10 CONTINUE H2 = X(3) - X(2) DEL2 = (F(1,3) - F(1,2))/H2 C C SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C HSUM = H1 + H2 W1 = (H1 + HSUM)/HSUM W2 = -H1/HSUM D(1,1) = W1*DEL1 + W2*DEL2 IF ( PCHST(D(1,1),DEL1) .LE. ZERO) THEN D(1,1) = ZERO ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL1 IF (ABS(D(1,1)) .GT. ABS(DMAX)) D(1,1) = DMAX ENDIF C C LOOP THROUGH INTERIOR POINTS. C DO 50 I = 2, NLESS1 IF (I .EQ. 2) GO TO 40 C H1 = H2 H2 = X(I+1) - X(I) HSUM = H1 + H2 DEL1 = DEL2 DEL2 = (F(1,I+1) - F(1,I))/H2 40 CONTINUE C C SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. C D(1,I) = ZERO IF ( PCHST(DEL1,DEL2) ) 42, 41, 45 C C COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. C 41 CONTINUE IF (DEL2 .EQ. ZERO) GO TO 50 IF ( PCHST(DSAVE,DEL2) .LT. ZERO) IERR = IERR + 1 DSAVE = DEL2 GO TO 50 C 42 CONTINUE IERR = IERR + 1 DSAVE = DEL2 GO TO 50 C C USE BRODLIE MODIFICATION OF BUTLAND FORMULA. C 45 CONTINUE HSUMT3 = HSUM+HSUM+HSUM W1 = (HSUM + H1)/HSUMT3 W2 = (HSUM + H2)/HSUMT3 DMAX = MAX( ABS(DEL1), ABS(DEL2) ) DMIN = MIN( ABS(DEL1), ABS(DEL2) ) DRAT1 = DEL1/DMAX DRAT2 = DEL2/DMAX D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2) C 50 CONTINUE C C SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE C SHAPE-PRESERVING. C W1 = -H2/HSUM W2 = (H2 + HSUM)/HSUM D(1,N) = W1*DEL1 + W2*DEL2 IF ( PCHST(D(1,N),DEL2) .LE. ZERO) THEN D(1,N) = ZERO ELSE IF ( PCHST(DEL1,DEL2) .LT. ZERO) THEN C NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. DMAX = THREE*DEL2 IF (ABS(D(1,N)) .GT. ABS(DMAX)) D(1,N) = DMAX ENDIF C C NORMAL RETURN. C 5000 CONTINUE RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHIM', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHIM', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHIM', 'X-ARRAY NOT STRICTLY INCREASING' + , IERR, 1) RETURN C------------- LAST LINE OF PCHIM FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchkt.f0000644060175006010010000000470012562522365015061 0ustar chmNone*DECK PCHKT SUBROUTINE PCHKT (N, X, KNOTYP, T) C***BEGIN PROLOGUE PCHKT C***SUBSIDIARY C***PURPOSE Compute B-spline knot sequence for PCHBS. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E3 C***TYPE SINGLE PRECISION (PCHKT-S, DPCHKT-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C Set a knot sequence for the B-spline representation of a PCH C function with breakpoints X. All knots will be at least double. C Endknots are set as: C (1) quadruple knots at endpoints if KNOTYP=0; C (2) extrapolate the length of end interval if KNOTYP=1; C (3) periodic if KNOTYP=2. C C Input arguments: N, X, KNOTYP. C Output arguments: T. C C Restrictions/assumptions: C 1. N.GE.2 . (not checked) C 2. X(i).LT.X(i+1), i=1,...,N . (not checked) C 3. 0.LE.KNOTYP.LE.2 . (Acts like KNOTYP=0 for any other value.) C C***SEE ALSO PCHBS C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 870701 DATE WRITTEN C 900405 Converted Fortran to upper case. C 900410 Converted prologue to SLATEC 4.0 format. C 900410 Minor cosmetic changes. C 930514 Changed NKNOTS from an output to an input variable. (FNF) C 930604 Removed unused variable NKNOTS from argument list. (FNF) C***END PROLOGUE PCHKT C C*Internal Notes: C C Since this is subsidiary to PCHBS, which validates its input before C calling, it is unnecessary for such validation to be done here. C C**End C C Declare arguments. C INTEGER N, KNOTYP REAL X(*), T(*) C C Declare local variables. C INTEGER J, K, NDIM REAL HBEG, HEND C***FIRST EXECUTABLE STATEMENT PCHKT C C Initialize. C NDIM = 2*N C C Set interior knots. C J = 1 DO 20 K = 1, N J = J + 2 T(J) = X(K) T(J+1) = T(J) 20 CONTINUE C Assertion: At this point T(3),...,T(NDIM+2) have been set and C J=NDIM+1. C C Set end knots according to KNOTYP. C HBEG = X(2) - X(1) HEND = X(N) - X(N-1) IF (KNOTYP.EQ.1 ) THEN C Extrapolate. T(2) = X(1) - HBEG T(NDIM+3) = X(N) + HEND ELSE IF ( KNOTYP.EQ.2 ) THEN C Periodic. T(2) = X(1) - HEND T(NDIM+3) = X(N) + HBEG ELSE C Quadruple end knots. T(2) = X(1) T(NDIM+3) = X(N) ENDIF T(1) = T(2) T(NDIM+4) = T(NDIM+3) C C Terminate. C RETURN C------------- LAST LINE OF PCHKT FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchsp.f0000644060175006010010000003315512562522365015073 0ustar chmNone*DECK PCHSP SUBROUTINE PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) C***BEGIN PROLOGUE PCHSP C***PURPOSE Set derivatives needed to determine the Hermite represen- C tation of the cubic spline interpolant to given data, with C specified boundary conditions. C***LIBRARY SLATEC (PCHIP) C***CATEGORY E1A C***TYPE SINGLE PRECISION (PCHSP-S, DPCHSP-D) C***KEYWORDS CUBIC HERMITE INTERPOLATION, PCHIP, C PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION C***AUTHOR Fritsch, F. N., (LLNL) C Lawrence Livermore National Laboratory C P.O. Box 808 (L-316) C Livermore, CA 94550 C FTS 532-4275, (510) 422-4275 C***DESCRIPTION C C PCHSP: Piecewise Cubic Hermite Spline C C Computes the Hermite representation of the cubic spline inter- C polant to the data given in X and F satisfying the boundary C conditions specified by IC and VC. C C To facilitate two-dimensional applications, includes an increment C between successive values of the F- and D-arrays. C C The resulting piecewise cubic Hermite function may be evaluated C by PCHFE or PCHFD. C C NOTE: This is a modified version of C. de Boor's cubic spline C routine CUBSPL. C C ---------------------------------------------------------------------- C C Calling sequence: C C PARAMETER (INCFD = ...) C INTEGER IC(2), N, NWK, IERR C REAL VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK) C C CALL PCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR) C C Parameters: C C IC -- (input) integer array of length 2 specifying desired C boundary conditions: C IC(1) = IBEG, desired condition at beginning of data. C IC(2) = IEND, desired condition at end of data. C C IBEG = 0 to set D(1) so that the third derivative is con- C tinuous at X(2). This is the "not a knot" condition C provided by de Boor's cubic spline routine CUBSPL. C < This is the default boundary condition. > C IBEG = 1 if first derivative at X(1) is given in VC(1). C IBEG = 2 if second derivative at X(1) is given in VC(1). C IBEG = 3 to use the 3-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.3 .) C IBEG = 4 to use the 4-point difference formula for D(1). C (Reverts to the default b.c. if N.LT.4 .) C NOTES: C 1. An error return is taken if IBEG is out of range. C 2. For the "natural" boundary condition, use IBEG=2 and C VC(1)=0. C C IEND may take on the same values as IBEG, but applied to C derivative at X(N). In case IEND = 1 or 2, the value is C given in VC(2). C C NOTES: C 1. An error return is taken if IEND is out of range. C 2. For the "natural" boundary condition, use IEND=2 and C VC(2)=0. C C VC -- (input) real array of length 2 specifying desired boundary C values, as indicated above. C VC(1) need be set only if IC(1) = 1 or 2 . C VC(2) need be set only if IC(2) = 1 or 2 . C C N -- (input) number of data points. (Error return if N.LT.2 .) C C X -- (input) real array of independent variable values. The C elements of X must be strictly increasing: C X(I-1) .LT. X(I), I = 2(1)N. C (Error return if not.) C C F -- (input) real array of dependent variable values to be inter- C polated. F(1+(I-1)*INCFD) is value corresponding to X(I). C C D -- (output) real array of derivative values at the data points. C These values will determine the cubic spline interpolant C with the requested boundary conditions. C The value corresponding to X(I) is stored in C D(1+(I-1)*INCFD), I=1(1)N. C No other entries in D are changed. C C INCFD -- (input) increment between successive values in F and D. C This argument is provided primarily for 2-D applications. C (Error return if INCFD.LT.1 .) C C WK -- (scratch) real array of working storage. C C NWK -- (input) length of work array. C (Error return if NWK.LT.2*N .) C C IERR -- (output) error flag. C Normal return: C IERR = 0 (no errors). C "Recoverable" errors: C IERR = -1 if N.LT.2 . C IERR = -2 if INCFD.LT.1 . C IERR = -3 if the X-array is not strictly increasing. C IERR = -4 if IBEG.LT.0 or IBEG.GT.4 . C IERR = -5 if IEND.LT.0 of IEND.GT.4 . C IERR = -6 if both of the above are true. C IERR = -7 if NWK is too small. C NOTE: The above errors are checked in the order listed, C and following arguments have **NOT** been validated. C (The D-array has not been changed in any of these cases.) C IERR = -8 in case of trouble solving the linear system C for the interior derivative values. C (The D-array may have been changed in this case.) C ( Do **NOT** use it! ) C C***REFERENCES Carl de Boor, A Practical Guide to Splines, Springer- C Verlag, New York, 1978, pp. 53-59. C***ROUTINES CALLED PCHDF, XERMSG C***REVISION HISTORY (YYMMDD) C 820503 DATE WRITTEN C 820804 Converted to SLATEC library version. C 870707 Minor cosmetic changes to prologue. C 890411 Added SAVE statements (Vers. 3.2). C 890703 Corrected category record. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920429 Revised format and order of references. (WRB,FNF) C***END PROLOGUE PCHSP C Programming notes: C C To produce a double precision version, simply: C a. Change PCHSP to DPCHSP wherever it occurs, C b. Change the real declarations to double precision, and C c. Change the constants ZERO, HALF, ... to double precision. C C DECLARE ARGUMENTS. C INTEGER IC(2), N, INCFD, NWK, IERR REAL VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*) C C DECLARE LOCAL VARIABLES. C INTEGER IBEG, IEND, INDEX, J, NM1 REAL G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4), ZERO SAVE ZERO, HALF, ONE, TWO, THREE REAL PCHDF C DATA ZERO /0./, HALF /0.5/, ONE /1./, TWO /2./, THREE /3./ C C VALIDITY-CHECK ARGUMENTS. C C***FIRST EXECUTABLE STATEMENT PCHSP IF ( N.LT.2 ) GO TO 5001 IF ( INCFD.LT.1 ) GO TO 5002 DO 1 J = 2, N IF ( X(J).LE.X(J-1) ) GO TO 5003 1 CONTINUE C IBEG = IC(1) IEND = IC(2) IERR = 0 IF ( (IBEG.LT.0).OR.(IBEG.GT.4) ) IERR = IERR - 1 IF ( (IEND.LT.0).OR.(IEND.GT.4) ) IERR = IERR - 2 IF ( IERR.LT.0 ) GO TO 5004 C C FUNCTION DEFINITION IS OK -- GO ON. C IF ( NWK .LT. 2*N ) GO TO 5007 C C COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO, C COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.). DO 5 J=2,N WK(1,J) = X(J) - X(J-1) WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J) 5 CONTINUE C C SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL. C IF ( IBEG.GT.N ) IBEG = 0 IF ( IEND.GT.N ) IEND = 0 C C SET UP FOR BOUNDARY CONDITIONS. C IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) ) THEN D(1,1) = VC(1) ELSE IF (IBEG .GT. 2) THEN C PICK UP FIRST IBEG POINTS, IN REVERSE ORDER. DO 10 J = 1, IBEG INDEX = IBEG-J+1 C INDEX RUNS FROM IBEG DOWN TO 1. XTEMP(J) = X(INDEX) IF (J .LT. IBEG) STEMP(J) = WK(2,INDEX) 10 CONTINUE C -------------------------------- D(1,1) = PCHDF (IBEG, XTEMP, STEMP, IERR) C -------------------------------- IF (IERR .NE. 0) GO TO 5009 IBEG = 1 ENDIF C IF ( (IEND.EQ.1).OR.(IEND.EQ.2) ) THEN D(1,N) = VC(2) ELSE IF (IEND .GT. 2) THEN C PICK UP LAST IEND POINTS. DO 15 J = 1, IEND INDEX = N-IEND+J C INDEX RUNS FROM N+1-IEND UP TO N. XTEMP(J) = X(INDEX) IF (J .LT. IEND) STEMP(J) = WK(2,INDEX+1) 15 CONTINUE C -------------------------------- D(1,N) = PCHDF (IEND, XTEMP, STEMP, IERR) C -------------------------------- IF (IERR .NE. 0) GO TO 5009 IEND = 1 ENDIF C C --------------------( BEGIN CODING FROM CUBSPL )-------------------- C C **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF C F AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM- C INATION, WITH S(J) ENDING UP IN D(1,J), ALL J. C WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE. C C CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM C WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1) C IF (IBEG .EQ. 0) THEN IF (N .EQ. 2) THEN C NO CONDITION AT LEFT END AND N = 2. WK(2,1) = ONE WK(1,1) = ONE D(1,1) = TWO*WK(2,2) ELSE C NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2. WK(2,1) = WK(1,3) WK(1,1) = WK(1,2) + WK(1,3) D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3) * + WK(1,2)**2*WK(2,3)) / WK(1,1) ENDIF ELSE IF (IBEG .EQ. 1) THEN C SLOPE PRESCRIBED AT LEFT END. WK(2,1) = ONE WK(1,1) = ZERO ELSE C SECOND DERIVATIVE PRESCRIBED AT LEFT END. WK(2,1) = TWO WK(1,1) = ONE D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1) ENDIF C C IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND C CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH C EQUATION READS WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J). C NM1 = N-1 IF (NM1 .GT. 1) THEN DO 20 J=2,NM1 IF (WK(2,J-1) .EQ. ZERO) GO TO 5008 G = -WK(1,J+1)/WK(2,J-1) D(1,J) = G*D(1,J-1) * + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J)) WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1)) 20 CONTINUE ENDIF C C CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM C (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N) C C IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK- C SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT C AT THIS POINT. IF (IEND .EQ. 1) GO TO 30 C IF (IEND .EQ. 0) THEN IF (N.EQ.2 .AND. IBEG.EQ.0) THEN C NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2. D(1,2) = WK(2,2) GO TO 30 ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0)) THEN C EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT* C NOT-A-KNOT AT LEFT END POINT). D(1,N) = TWO*WK(2,N) WK(2,N) = ONE IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 G = -ONE/WK(2,N-1) ELSE C NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR ALSO NOT-A- C KNOT AT LEFT END POINT. G = WK(1,N-1) + WK(1,N) C DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES). D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1) * + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 G = -G/WK(2,N-1) WK(2,N) = WK(1,N-1) ENDIF ELSE C SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT. D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N) WK(2,N) = TWO IF (WK(2,N-1) .EQ. ZERO) GO TO 5008 G = -ONE/WK(2,N-1) ENDIF C C COMPLETE FORWARD PASS OF GAUSS ELIMINATION. C WK(2,N) = G*WK(1,N-1) + WK(2,N) IF (WK(2,N) .EQ. ZERO) GO TO 5008 D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N) C C CARRY OUT BACK SUBSTITUTION C 30 CONTINUE DO 40 J=NM1,1,-1 IF (WK(2,J) .EQ. ZERO) GO TO 5008 D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J) 40 CONTINUE C --------------------( END CODING FROM CUBSPL )-------------------- C C NORMAL RETURN. C RETURN C C ERROR RETURNS. C 5001 CONTINUE C N.LT.2 RETURN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHSP', + 'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1) RETURN C 5002 CONTINUE C INCFD.LT.1 RETURN. IERR = -2 CALL XERMSG ('SLATEC', 'PCHSP', 'INCREMENT LESS THAN ONE', IERR, + 1) RETURN C 5003 CONTINUE C X-ARRAY NOT STRICTLY INCREASING. IERR = -3 CALL XERMSG ('SLATEC', 'PCHSP', 'X-ARRAY NOT STRICTLY INCREASING' + , IERR, 1) RETURN C 5004 CONTINUE C IC OUT OF RANGE RETURN. IERR = IERR - 3 CALL XERMSG ('SLATEC', 'PCHSP', 'IC OUT OF RANGE', IERR, 1) RETURN C 5007 CONTINUE C NWK TOO SMALL RETURN. IERR = -7 CALL XERMSG ('SLATEC', 'PCHSP', 'WORK ARRAY TOO SMALL', IERR, 1) RETURN C 5008 CONTINUE C SINGULAR SYSTEM. C *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES *** C *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). *** IERR = -8 CALL XERMSG ('SLATEC', 'PCHSP', 'SINGULAR LINEAR SYSTEM', IERR, + 1) RETURN C 5009 CONTINUE C ERROR RETURN FROM PCHDF. C *** THIS CASE SHOULD NEVER OCCUR *** IERR = -9 CALL XERMSG ('SLATEC', 'PCHSP', 'ERROR RETURN FROM PCHDF', IERR, + 1) RETURN C------------- LAST LINE OF PCHSP FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchst.f0000644060175006010010000000307012562522365015070 0ustar chmNone*DECK PCHST REAL FUNCTION PCHST (ARG1, ARG2) C***BEGIN PROLOGUE PCHST C***SUBSIDIARY C***PURPOSE PCHIP Sign-Testing Routine C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHST-S, DPCHST-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHST: PCHIP Sign-Testing Routine. C C Returns: C -1. if ARG1 and ARG2 are of opposite sign. C 0. if either argument is zero. C +1. if ARG1 and ARG2 are of the same sign. C C The object is to do this without multiplying ARG1*ARG2, to avoid C possible over/underflow problems. C C Fortran intrinsics used: SIGN. C C***SEE ALSO PCHCE, PCHCI, PCHCS, PCHIM C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 811103 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870813 Minor cosmetic changes. C 890411 Added SAVE statements (Vers. 3.2). C 890411 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) C 930503 Improved purpose. (FNF) C***END PROLOGUE PCHST C C**End C C DECLARE ARGUMENTS. C REAL ARG1, ARG2 C C DECLARE LOCAL VARIABLES. C REAL ONE, ZERO SAVE ZERO, ONE DATA ZERO /0./, ONE /1./ C C PERFORM THE TEST. C C***FIRST EXECUTABLE STATEMENT PCHST PCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2) IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO)) PCHST = ZERO C RETURN C------------- LAST LINE OF PCHST FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pchsw.f0000644060175006010010000001410012562522365015067 0ustar chmNone*DECK PCHSW SUBROUTINE PCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) C***BEGIN PROLOGUE PCHSW C***SUBSIDIARY C***PURPOSE Limits excursion from data for PCHCS C***LIBRARY SLATEC (PCHIP) C***TYPE SINGLE PRECISION (PCHSW-S, DPCHSW-D) C***AUTHOR Fritsch, F. N., (LLNL) C***DESCRIPTION C C PCHSW: PCHCS Switch Excursion Limiter. C C Called by PCHCS to adjust D1 and D2 if necessary to insure that C the extremum on this interval is not further than DFMAX from the C extreme data value. C C ---------------------------------------------------------------------- C C Calling sequence: C C INTEGER IEXTRM, IERR C REAL DFMAX, D1, D2, H, SLOPE C C CALL PCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR) C C Parameters: C C DFMAX -- (input) maximum allowed difference between F(IEXTRM) and C the cubic determined by derivative values D1,D2. (assumes C DFMAX.GT.0.) C C IEXTRM -- (input) index of the extreme data value. (assumes C IEXTRM = 1 or 2 . Any value .NE.1 is treated as 2.) C C D1,D2 -- (input) derivative values at the ends of the interval. C (Assumes D1*D2 .LE. 0.) C (output) may be modified if necessary to meet the restriction C imposed by DFMAX. C C H -- (input) interval length. (Assumes H.GT.0.) C C SLOPE -- (input) data slope on the interval. C C IERR -- (output) error flag. should be zero. C If IERR=-1, assumption on D1 and D2 is not satisfied. C If IERR=-2, quadratic equation locating extremum has C negative discriminant (should never occur). C C ------- C WARNING: This routine does no validity-checking of arguments. C ------- C C Fortran intrinsics used: ABS, SIGN, SQRT. C C***SEE ALSO PCHCS C***ROUTINES CALLED R1MACH, XERMSG C***REVISION HISTORY (YYMMDD) C 820218 DATE WRITTEN C 820805 Converted to SLATEC library version. C 870707 Replaced DATA statement for SMALL with a use of R1MACH. C 890411 1. Added SAVE statements (Vers. 3.2). C 2. Added REAL R1MACH for consistency with D.P. version. C 890411 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900328 Added TYPE section. (WRB) C 910408 Updated AUTHOR and DATE WRITTEN sections in prologue. (WRB) C 920526 Eliminated possible divide by zero problem. (FNF) C 930503 Improved purpose. (FNF) C***END PROLOGUE PCHSW C C**End C C DECLARE ARGUMENTS. C INTEGER IEXTRM, IERR REAL DFMAX, D1, D2, H, SLOPE C C DECLARE LOCAL VARIABLES. C REAL CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL, RHO, SIGMA, * SMALL, THAT, THIRD, THREE, TWO, ZERO SAVE ZERO, ONE, TWO, THREE, FACT SAVE THIRD REAL R1MACH C DATA ZERO /0./, ONE /1./, TWO /2./, THREE /3./, FACT /100./ C THIRD SHOULD BE SLIGHTLY LESS THAN 1/3. DATA THIRD /0.33333/ C C NOTATION AND GENERAL REMARKS. C C RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED. C LAMBDA IS THE RATIO OF D2 TO D1. C THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM. C PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO), C WHERE THAT = (XHAT - X1)/H . C THAT IS, P(XHAT)-F1 = D*H*PHI, WHERE D=D1 OR D2. C SIMILARLY, P(XHAT)-F2 = D*H*(PHI-RHO) . C C SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS. C***FIRST EXECUTABLE STATEMENT PCHSW SMALL = FACT*R1MACH(4) C C DO MAIN CALCULATION. C IF (D1 .EQ. ZERO) THEN C C SPECIAL CASE -- D1.EQ.ZERO . C C IF D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED. IF (D2 .EQ. ZERO) GO TO 5001 C RHO = SLOPE/D2 C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . IF (RHO .GE. THIRD) GO TO 5000 THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE)) PHI = THAT**2 * ((THREE*RHO-ONE)/THREE) C C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . IF (IEXTRM .NE. 1) PHI = PHI - RHO C C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) IF (HPHI*ABS(D2) .GT. DFMAX) THEN C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. D2 = SIGN (DFMAX/HPHI, D2) ENDIF ELSE C RHO = SLOPE/D1 LAMBDA = -D2/D1 IF (D2 .EQ. ZERO) THEN C C SPECIAL CASE -- D2.EQ.ZERO . C C EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 . IF (RHO .GE. THIRD) GO TO 5000 CP = TWO - THREE*RHO NU = ONE - TWO*RHO THAT = ONE / (THREE*NU) ELSE IF (LAMBDA .LE. ZERO) GO TO 5001 C C NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS. C NU = ONE - LAMBDA - TWO*RHO SIGMA = ONE - RHO CP = NU + SIGMA IF (ABS(NU) .GT. SMALL) THEN RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2 IF (RADCAL .LT. ZERO) GO TO 5002 THAT = (CP - SQRT(RADCAL)) / (THREE*NU) ELSE THAT = ONE/(TWO*SIGMA) ENDIF ENDIF PHI = THAT*((NU*THAT - CP)*THAT + ONE) C C CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 . IF (IEXTRM .NE. 1) PHI = PHI - RHO C C TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY. HPHI = H * ABS(PHI) IF (HPHI*ABS(D1) .GT. DFMAX) THEN C AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK. D1 = SIGN (DFMAX/HPHI, D1) D2 = -LAMBDA*D1 ENDIF ENDIF C C NORMAL RETURN. C 5000 CONTINUE IERR = 0 RETURN C C ERROR RETURNS. C 5001 CONTINUE C D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN. IERR = -1 CALL XERMSG ('SLATEC', 'PCHSW', 'D1 AND/OR D2 INVALID', IERR, 1) RETURN C 5002 CONTINUE C NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR). IERR = -2 CALL XERMSG ('SLATEC', 'PCHSW', 'NEGATIVE RADICAL', IERR, 1) RETURN C------------- LAST LINE OF PCHSW FOLLOWS ------------------------------ END PDL-2.018/Lib/Slatec/slatec/pcoef.f0000644060175006010010000000571112562522365015047 0ustar chmNone*DECK PCOEF SUBROUTINE PCOEF (L, C, TC, A) C***BEGIN PROLOGUE PCOEF C***PURPOSE Convert the POLFIT coefficients to Taylor series form. C***LIBRARY SLATEC C***CATEGORY K1A1A2 C***TYPE SINGLE PRECISION (PCOEF-S, DPCOEF-D) C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT C***AUTHOR Shampine, L. F., (SNLA) C Davenport, S. M., (SNLA) C***DESCRIPTION C C Written BY L. F. Shampine and S. M. Davenport. C C Abstract C C POLFIT computes the least squares polynomial fit of degree L as C a sum of orthogonal polynomials. PCOEF changes this fit to its C Taylor expansion about any point C , i.e. writes the polynomial C as a sum of powers of (X-C). Taking C=0. gives the polynomial C in powers of X, but a suitable non-zero C often leads to C polynomials which are better scaled and more accurately evaluated. C C The parameters for PCOEF are C C INPUT -- C L - Indicates the degree of polynomial to be changed to C its Taylor expansion. To obtain the Taylor C coefficients in reverse order, input L as the C negative of the degree desired. The absolute value C of L must be less than or equal to NDEG, the highest C degree polynomial fitted by POLFIT . C C - The point about which the Taylor expansion is to be C made. C A - Work and output array containing values from last C call to POLFIT . C C OUTPUT -- C TC - Vector containing the first LL+1 Taylor coefficients C where LL=ABS(L). If L.GT.0 , the coefficients are C in the usual Taylor series order, i.e. C P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N C If L .LT. 0, the coefficients are in reverse order, C i.e. C P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) C C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, C Curve fitting by polynomials in one variable, Report C SLA-74-0270, Sandia Laboratories, June 1974. C***ROUTINES CALLED PVALUE C***REVISION HISTORY (YYMMDD) C 740601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE PCOEF C DIMENSION A(*), TC(*) C***FIRST EXECUTABLE STATEMENT PCOEF LL = ABS(L) LLP1 = LL + 1 CALL PVALUE (LL,LL,C,TC(1),TC(2),A) IF (LL .LT. 2) GO TO 2 FAC = 1.0 DO 1 I = 3,LLP1 FAC = FAC*(I-1) 1 TC(I) = TC(I)/FAC 2 IF (L .GE. 0) GO TO 4 NR = LLP1/2 LLP2 = LL + 2 DO 3 I = 1,NR SAVE = TC(I) NEW = LLP2 - I TC(I) = TC(NEW) 3 TC(NEW) = SAVE 4 RETURN END PDL-2.018/Lib/Slatec/slatec/polfit.f0000644060175006010010000003043212562522365015246 0ustar chmNone*DECK POLFIT SUBROUTINE POLFIT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) C***BEGIN PROLOGUE POLFIT C***PURPOSE Fit discrete data in a least squares sense by polynomials C in one variable. C***LIBRARY SLATEC C***CATEGORY K1A1A2 C***TYPE SINGLE PRECISION (POLFIT-S, DPOLFT-D) C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT C***AUTHOR Shampine, L. F., (SNLA) C Davenport, S. M., (SNLA) C Huddleston, R. E., (SNLL) C***DESCRIPTION C C Abstract C C Given a collection of points X(I) and a set of values Y(I) which C correspond to some function or measurement at each of the X(I), C subroutine POLFIT computes the weighted least-squares polynomial C fits of all degrees up to some degree either specified by the user C or determined by the routine. The fits thus obtained are in C orthogonal polynomial form. Subroutine PVALUE may then be C called to evaluate the fitted polynomials and any of their C derivatives at any point. The subroutine PCOEF may be used to C express the polynomial fits as powers of (X-C) for any specified C point C. C C The parameters for POLFIT are C C Input -- C N - the number of data points. The arrays X, Y and W C must be dimensioned at least N (N .GE. 1). C X - array of values of the independent variable. These C values may appear in any order and need not all be C distinct. C Y - array of corresponding function values. C W - array of positive values to be used as weights. If C W(1) is negative, POLFIT will set all the weights C to 1.0, which means unweighted least squares error C will be minimized. To minimize relative error, the C user should set the weights to: W(I) = 1.0/Y(I)**2, C I = 1,...,N . C MAXDEG - maximum degree to be allowed for polynomial fit. C MAXDEG may be any non-negative integer less than N. C Note -- MAXDEG cannot be equal to N-1 when a C statistical test is to be used for degree selection, C i.e., when input value of EPS is negative. C EPS - specifies the criterion to be used in determining C the degree of fit to be computed. C (1) If EPS is input negative, POLFIT chooses the C degree based on a statistical F test of C significance. One of three possible C significance levels will be used: .01, .05 or C .10. If EPS=-1.0 , the routine will C automatically select one of these levels based C on the number of data points and the maximum C degree to be considered. If EPS is input as C -.01, -.05, or -.10, a significance level of C .01, .05, or .10, respectively, will be used. C (2) If EPS is set to 0., POLFIT computes the C polynomials of degrees 0 through MAXDEG . C (3) If EPS is input positive, EPS is the RMS C error tolerance which must be satisfied by the C fitted polynomial. POLFIT will increase the C degree of fit until this criterion is met or C until the maximum degree is reached. C C Output -- C NDEG - degree of the highest degree fit computed. C EPS - RMS error of the polynomial of degree NDEG . C R - vector of dimension at least NDEG containing values C of the fit of degree NDEG at each of the X(I) . C Except when the statistical test is used, these C values are more accurate than results from subroutine C PVALUE normally are. C IERR - error flag with the following possible values. C 1 -- indicates normal execution, i.e., either C (1) the input value of EPS was negative, and the C computed polynomial fit of degree NDEG C satisfies the specified F test, or C (2) the input value of EPS was 0., and the fits of C all degrees up to MAXDEG are complete, or C (3) the input value of EPS was positive, and the C polynomial of degree NDEG satisfies the RMS C error requirement. C 2 -- invalid input parameter. At least one of the input C parameters has an illegal value and must be corrected C before POLFIT can proceed. Valid input results C when the following restrictions are observed C N .GE. 1 C 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. C 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. C W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . C 3 -- cannot satisfy the RMS error requirement with a C polynomial of degree no greater than MAXDEG . Best C fit found is of degree MAXDEG . C 4 -- cannot satisfy the test for significance using C current value of MAXDEG . Statistically, the C best fit found is of order NORD . (In this case, C NDEG will have one of the values: MAXDEG-2, C MAXDEG-1, or MAXDEG). Using a higher value of C MAXDEG may result in passing the test. C A - work and output array having at least 3N+3MAXDEG+3 C locations C C Note - POLFIT calculates all fits of degrees up to and including C NDEG . Any or all of these fits can be evaluated or C expressed as powers of (X-C) using PVALUE and PCOEF C after just one call to POLFIT . C C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, C Curve fitting by polynomials in one variable, Report C SLA-74-0270, Sandia Laboratories, June 1974. C***ROUTINES CALLED PVALUE, XERMSG C***REVISION HISTORY (YYMMDD) C 740601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 920501 Reformatted the REFERENCES section. (WRB) C 920527 Corrected erroneous statements in DESCRIPTION. (WRB) C***END PROLOGUE POLFIT DOUBLE PRECISION TEMD1,TEMD2 DIMENSION X(*), Y(*), W(*), R(*), A(*) DIMENSION CO(4,3) SAVE CO DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), 2 CO(4,3)/-13.086850,-2.4648165,-3.3846535,-1.2973162, 3 -3.3381146,-1.7812271,-3.2578406,-1.6589279, 4 -1.6282703,-1.3152745,-3.2640179,-1.9829776/ C***FIRST EXECUTABLE STATEMENT POLFIT M = ABS(N) IF (M .EQ. 0) GO TO 30 IF (MAXDEG .LT. 0) GO TO 30 A(1) = MAXDEG MOP1 = MAXDEG + 1 IF (M .LT. MOP1) GO TO 30 IF (EPS .LT. 0.0 .AND. M .EQ. MOP1) GO TO 30 XM = M ETST = EPS*EPS*XM IF (W(1) .LT. 0.0) GO TO 2 DO 1 I = 1,M IF (W(I) .LE. 0.0) GO TO 30 1 CONTINUE GO TO 4 2 DO 3 I = 1,M 3 W(I) = 1.0 4 IF (EPS .GE. 0.0) GO TO 8 C C DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR C CHOOSING DEGREE OF POLYNOMIAL FIT C IF (EPS .GT. (-.55)) GO TO 5 IDEGF = M - MAXDEG - 1 KSIG = 1 IF (IDEGF .LT. 10) KSIG = 2 IF (IDEGF .LT. 5) KSIG = 3 GO TO 8 5 KSIG = 1 IF (EPS .LT. (-.03)) KSIG = 2 IF (EPS .LT. (-.07)) KSIG = 3 C C INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING C 8 K1 = MAXDEG + 1 K2 = K1 + MAXDEG K3 = K2 + MAXDEG + 2 K4 = K3 + M K5 = K4 + M DO 9 I = 2,K4 9 A(I) = 0.0 W11 = 0.0 IF (N .LT. 0) GO TO 11 C C UNCONSTRAINED CASE C DO 10 I = 1,M K4PI = K4 + I A(K4PI) = 1.0 10 W11 = W11 + W(I) GO TO 13 C C CONSTRAINED CASE C 11 DO 12 I = 1,M K4PI = K4 + I 12 W11 = W11 + W(I)*A(K4PI)**2 C C COMPUTE FIT OF DEGREE ZERO C 13 TEMD1 = 0.0D0 DO 14 I = 1,M K4PI = K4 + I TEMD1 = TEMD1 + DBLE(W(I))*DBLE(Y(I))*DBLE(A(K4PI)) 14 CONTINUE TEMD1 = TEMD1/DBLE(W11) A(K2+1) = TEMD1 SIGJ = 0.0 DO 15 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = TEMD1*DBLE(A(K4PI)) R(I) = TEMD2 A(K5PI) = TEMD2 - DBLE(R(I)) 15 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 J = 0 C C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION C IF (EPS) 24,26,27 C C INCREMENT DEGREE C 16 J = J + 1 JP1 = J + 1 K1PJ = K1 + J K2PJ = K2 + J SIGJM1 = SIGJ C C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 C IF (J .GT. 1) A(K1PJ) = W11/W1 C C COMPUTE NEW A COEFFICIENT C TEMD1 = 0.0D0 DO 18 I = 1,M K4PI = K4 + I TEMD2 = A(K4PI) TEMD1 = TEMD1 + DBLE(X(I))*DBLE(W(I))*TEMD2*TEMD2 18 CONTINUE A(JP1) = TEMD1/DBLE(W11) C C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS C W1 = W11 W11 = 0.0 DO 19 I = 1,M K3PI = K3 + I K4PI = K4 + I TEMP = A(K3PI) A(K3PI) = A(K4PI) A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP 19 W11 = W11 + W(I)*A(K4PI)**2 C C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE C PRECISION C TEMD1 = 0.0D0 DO 20 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = DBLE(W(I))*DBLE((Y(I)-R(I))-A(K5PI))*DBLE(A(K4PI)) 20 TEMD1 = TEMD1 + TEMD2 TEMD1 = TEMD1/DBLE(W11) A(K2PJ+1) = TEMD1 C C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND C ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE C COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, C THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST C SIGNIFICANT BITS ARE IN A(K5PI) . C SIGJ = 0.0 DO 21 I = 1,M K4PI = K4 + I K5PI = K5 + I TEMD2 = DBLE(R(I)) + DBLE(A(K5PI)) + TEMD1*DBLE(A(K4PI)) R(I) = TEMD2 A(K5PI) = TEMD2 - DBLE(R(I)) 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 C C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE C MAXDEG HAS BEEN REACHED C IF (EPS) 23,26,27 C C COMPUTE F STATISTICS (INPUT EPS .LT. 0.) C 23 IF (SIGJ .EQ. 0.0) GO TO 29 DEGF = M - J - 1 DEN = (CO(4,KSIG)*DEGF + 1.0)*DEGF FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN FCRIT = FCRIT*FCRIT F = (SIGJM1 - SIGJ)*DEGF/SIGJ IF (F .LT. FCRIT) GO TO 25 C C POLYNOMIAL OF DEGREE J SATISFIES F TEST C 24 SIGPAS = SIGJ JPAS = J NFAIL = 0 IF (MAXDEG .EQ. J) GO TO 32 GO TO 16 C C POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. C 25 NFAIL = NFAIL + 1 IF (NFAIL .GE. 3) GO TO 29 IF (MAXDEG .EQ. J) GO TO 32 GO TO 16 C C RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT C EPS = 0.) C 26 IF (MAXDEG .EQ. J) GO TO 28 GO TO 16 C C SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) C 27 IF (SIGJ .LE. ETST) GO TO 28 IF (MAXDEG .EQ. J) GO TO 31 GO TO 16 C C RETURNS C 28 IERR = 1 NDEG = J SIG = SIGJ GO TO 33 29 IERR = 1 NDEG = JPAS SIG = SIGPAS GO TO 33 30 IERR = 2 CALL XERMSG ('SLATEC', 'POLFIT', 'INVALID INPUT PARAMETER.', 2, + 1) GO TO 37 31 IERR = 3 NDEG = MAXDEG SIG = SIGJ GO TO 33 32 IERR = 4 NDEG = JPAS SIG = SIGPAS C 33 A(K3) = NDEG C C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT C ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES C IF(EPS .GE. 0.0 .OR. NDEG .EQ. MAXDEG) GO TO 36 NDER = 0 DO 35 I = 1,M CALL PVALUE (NDEG,NDER,X(I),R(I),YP,A) 35 CONTINUE 36 EPS = SQRT(SIG/XM) 37 RETURN END PDL-2.018/Lib/Slatec/slatec/pvalue.f0000644060175006010010000001126412562522365015247 0ustar chmNone*DECK PVALUE SUBROUTINE PVALUE (L, NDER, X, YFIT, YP, A) C***BEGIN PROLOGUE PVALUE C***PURPOSE Use the coefficients generated by POLFIT to evaluate the C polynomial fit of degree L, along with the first NDER of C its derivatives, at a specified point. C***LIBRARY SLATEC C***CATEGORY K6 C***TYPE SINGLE PRECISION (PVALUE-S, DP1VLU-D) C***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION C***AUTHOR Shampine, L. F., (SNLA) C Davenport, S. M., (SNLA) C***DESCRIPTION C C Written by L. F. Shampine and S. M. Davenport. C C Abstract C C The subroutine PVALUE uses the coefficients generated by POLFIT C to evaluate the polynomial fit of degree L , along with the first C NDER of its derivatives, at a specified point. Computationally C stable recurrence relations are used to perform this task. C C The parameters for PVALUE are C C Input -- C L - the degree of polynomial to be evaluated. L may be C any non-negative integer which is less than or equal C to NDEG , the highest degree polynomial provided C by POLFIT . C NDER - the number of derivatives to be evaluated. NDER C may be 0 or any positive value. If NDER is less C than 0, it will be treated as 0. C X - the argument at which the polynomial and its C derivatives are to be evaluated. C A - work and output array containing values from last C call to POLFIT . C C Output -- C YFIT - value of the fitting polynomial of degree L at X C YP - array containing the first through NDER derivatives C of the polynomial of degree L . YP must be C dimensioned at least NDER in the calling program. C C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, C Curve fitting by polynomials in one variable, Report C SLA-74-0270, Sandia Laboratories, June 1974. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 740601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900510 Convert XERRWV calls to XERMSG calls. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE PVALUE DIMENSION YP(*),A(*) CHARACTER*8 XERN1, XERN2 C***FIRST EXECUTABLE STATEMENT PVALUE IF (L .LT. 0) GO TO 12 NDO = MAX(NDER,0) NDO = MIN(NDO,L) MAXORD = A(1) + 0.5 K1 = MAXORD + 1 K2 = K1 + MAXORD K3 = K2 + MAXORD + 2 NORD = A(K3) + 0.5 IF (L .GT. NORD) GO TO 11 K4 = K3 + L + 1 IF (NDER .LT. 1) GO TO 2 DO 1 I = 1,NDER 1 YP(I) = 0.0 2 IF (L .GE. 2) GO TO 4 IF (L .EQ. 1) GO TO 3 C C L IS 0 C VAL = A(K2+1) GO TO 10 C C L IS 1 C 3 CC = A(K2+2) VAL = A(K2+1) + (X-A(2))*CC IF (NDER .GE. 1) YP(1) = CC GO TO 10 C C L IS GREATER THAN 1 C 4 NDP1 = NDO + 1 K3P1 = K3 + 1 K4P1 = K4 + 1 LP1 = L + 1 LM1 = L - 1 ILO = K3 + 3 IUP = K4 + NDP1 DO 5 I = ILO,IUP 5 A(I) = 0.0 DIF = X - A(LP1) KC = K2 + LP1 A(K4P1) = A(KC) A(K3P1) = A(KC-1) + DIF*A(K4P1) A(K3+2) = A(K4P1) C C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES C DO 9 I = 1,LM1 IN = L - I INP1 = IN + 1 K1I = K1 + INP1 IC = K2 + IN DIF = X - A(INP1) VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1) IF (NDO .LE. 0) GO TO 8 DO 6 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) C C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS C DO 7 N = 1,NDO K3PN = K3P1 + N K4PN = K4P1 + N A(K4PN) = A(K3PN) 7 A(K3PN) = YP(N) 8 A(K4P1) = A(K3P1) 9 A(K3P1) = VAL C C NORMAL RETURN OR ABORT DUE TO ERROR C 10 YFIT = VAL RETURN C 11 WRITE (XERN1, '(I8)') L WRITE (XERN2, '(I8)') NORD CALL XERMSG ('SLATEC', 'PVALUE', * 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // * ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // * ', COMPUTED BY POLFIT -- EXECUTION TERMINATED.', 8, 2) RETURN C 12 CALL XERMSG ('SLATEC', 'PVALUE', + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // + 'REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.', 2, 2) RETURN END PDL-2.018/Lib/Slatec/slatec/pythag.f0000644060175006010010000000204212562522365015241 0ustar chmNone*DECK PYTHAG REAL FUNCTION PYTHAG (A, B) C***BEGIN PROLOGUE PYTHAG C***SUBSIDIARY C***PURPOSE Compute the complex square root of a complex number without C destructive overflow or underflow. C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (PYTHAG-S) C***AUTHOR (UNKNOWN) C***DESCRIPTION C C Finds sqrt(A**2+B**2) without overflow or destructive underflow C C***SEE ALSO EISDOC C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 811101 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE PYTHAG REAL A,B C REAL P,Q,R,S,T C***FIRST EXECUTABLE STATEMENT PYTHAG P = MAX(ABS(A),ABS(B)) Q = MIN(ABS(A),ABS(B)) IF (Q .EQ. 0.0E0) GO TO 20 10 CONTINUE R = (Q/P)**2 T = 4.0E0 + R IF (T .EQ. 4.0E0) GO TO 20 S = R/T P = P + 2.0E0*P*S Q = Q*S GO TO 10 20 PYTHAG = P RETURN END PDL-2.018/Lib/Slatec/slatec/r1mach.f0000644060175006010010000003265012562522365015130 0ustar chmNone*DECK R1MACH REAL FUNCTION R1MACH (I) C***BEGIN PROLOGUE R1MACH C***PURPOSE Return floating point machine dependent constants. C***LIBRARY SLATEC C***CATEGORY R1 C***TYPE SINGLE PRECISION (R1MACH-S, D1MACH-D) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Fox, P. A., (Bell Labs) C Hall, A. D., (Bell Labs) C Schryer, N. L., (Bell Labs) C***DESCRIPTION C C R1MACH can be used to obtain machine-dependent parameters for the C local machine environment. It is a function subprogram with one C (input) argument, and can be referenced as follows: C C A = R1MACH(I) C C where I=1,...,5. The (output) value of A above is determined by C the (input) value of I. The results for various values of I are C discussed below. C C R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. C R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. C R1MACH(3) = B**(-T), the smallest relative spacing. C R1MACH(4) = B**(1-T), the largest relative spacing. C R1MACH(5) = LOG10(B) C C Assume single precision numbers are represented in the T-digit, C base-B form C C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and C EMIN .LE. E .LE. EMAX. C C The values of B, T, EMIN and EMAX are provided in I1MACH as C follows: C I1MACH(10) = B, the base. C I1MACH(11) = T, the number of base-B digits. C I1MACH(12) = EMIN, the smallest exponent E. C I1MACH(13) = EMAX, the largest exponent E. C C To alter this function for a particular environment, the desired C set of DATA statements should be activated by removing the C from C column 1. Also, the values of R1MACH(1) - R1MACH(4) should be C checked for consistency with the local operating system. C C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for C a portable library, ACM Transactions on Mathematical C Software 4, 2 (June 1978), pp. 177-188. C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 790101 DATE WRITTEN C 890213 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) C 900618 Added DEC RISC constants. (WRB) C 900723 Added IBM RS 6000 constants. (WRB) C 910710 Added HP 730 constants. (SMR) C 911114 Added Convex IEEE constants. (WRB) C 920121 Added SUN -r8 compiler option constants. (WRB) C 920229 Added Touchstone Delta i860 constants. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C 920625 Added CONVEX -p8 and -pd8 compiler option constants. C (BKS, WRB) C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) C***END PROLOGUE R1MACH C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) C REAL RMACH(5) SAVE RMACH C EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE AMIGA C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7EFFFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE APOLLO C C DATA SMALL(1) / 16#00800000 / C DATA LARGE(1) / 16#7FFFFFFF / C DATA RIGHT(1) / 16#33800000 / C DATA DIVER(1) / 16#34000000 / C DATA LOG10(1) / 16#3E9A209B / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM C C DATA RMACH(1) / Z400800000 / C DATA RMACH(2) / Z5FFFFFFFF / C DATA RMACH(3) / Z4E9800000 / C DATA RMACH(4) / Z4EA800000 / C DATA RMACH(5) / Z500E730E8 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS C C DATA RMACH(1) / O1771000000000000 / C DATA RMACH(2) / O0777777777777777 / C DATA RMACH(3) / O1311000000000000 / C DATA RMACH(4) / O1301000000000000 / C DATA RMACH(5) / O1157163034761675 / C C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE C C DATA RMACH(1) / Z"3001800000000000" / C DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" / C DATA RMACH(3) / Z"3FD2800000000000" / C DATA RMACH(4) / Z"3FD3800000000000" / C DATA RMACH(5) / Z"3FFF9A209A84FBCF" / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C C DATA RMACH(1) / 00564000000000000000B / C DATA RMACH(2) / 37767777777777777776B / C DATA RMACH(3) / 16414000000000000000B / C DATA RMACH(4) / 16424000000000000000B / C DATA RMACH(5) / 17164642023241175720B / C C MACHINE CONSTANTS FOR THE CELERITY C1260 C C DATA SMALL(1) / Z'00800000' / C DATA LARGE(1) / Z'7F7FFFFF' / C DATA RIGHT(1) / Z'33800000' / C DATA DIVER(1) / Z'34000000' / C DATA LOG10(1) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fn COMPILER OPTION C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7FFFFFFF' / C DATA RMACH(3) / Z'34800000' / C DATA RMACH(4) / Z'35000000' / C DATA RMACH(5) / Z'3F9A209B' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -fi COMPILER OPTION C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE CONVEX C USING THE -p8 OR -pd8 COMPILER OPTION C C DATA RMACH(1) / Z'0010000000000000' / C DATA RMACH(2) / Z'7FFFFFFFFFFFFFFF' / C DATA RMACH(3) / Z'3CC0000000000000' / C DATA RMACH(4) / Z'3CD0000000000000' / C DATA RMACH(5) / Z'3FF34413509F79FF' / C C MACHINE CONSTANTS FOR THE CRAY C C DATA RMACH(1) / 200034000000000000000B / C DATA RMACH(2) / 577767777777777777776B / C DATA RMACH(3) / 377224000000000000000B / C DATA RMACH(4) / 377234000000000000000B / C DATA RMACH(5) / 377774642023241175720B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC RMACH(5) C C DATA SMALL / 20K, 0 / C DATA LARGE / 77777K, 177777K / C DATA RIGHT / 35420K, 0 / C DATA DIVER / 36020K, 0 / C DATA LOG10 / 40423K, 42023K / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING G_FLOAT C C DATA RMACH(1) / '00000080'X / C DATA RMACH(2) / 'FFFF7FFF'X / C DATA RMACH(3) / '00003480'X / C DATA RMACH(4) / '00003500'X / C DATA RMACH(5) / '209B3F9A'X / C C MACHINE CONSTANTS FOR THE DEC ALPHA C USING IEEE_FLOAT C C DATA RMACH(1) / '00800000'X / C DATA RMACH(2) / '7F7FFFFF'X / C DATA RMACH(3) / '33800000'X / C DATA RMACH(4) / '34000000'X / C DATA RMACH(5) / '3E9A209B'X / C C MACHINE CONSTANTS FOR THE DEC RISC C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE DEC VAX C (EXPRESSED IN INTEGER AND HEXADECIMAL) C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS C C DATA SMALL(1) / 128 / C DATA LARGE(1) / -32769 / C DATA RIGHT(1) / 13440 / C DATA DIVER(1) / 13568 / C DATA LOG10(1) / 547045274 / C C DATA SMALL(1) / Z00000080 / C DATA LARGE(1) / ZFFFF7FFF / C DATA RIGHT(1) / Z00003480 / C DATA DIVER(1) / Z00003500 / C DATA LOG10(1) / Z209B3F9A / C C MACHINE CONSTANTS FOR THE ELXSI 6400 C (ASSUMING REAL*4 IS THE DEFAULT REAL) C C DATA SMALL(1) / '00800000'X / C DATA LARGE(1) / '7F7FFFFF'X / C DATA RIGHT(1) / '33800000'X / C DATA DIVER(1) / '34000000'X / C DATA LOG10(1) / '3E9A209B'X / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / C DATA LARGE(1), LARGE(2) / '37777777, '00000177 / C DATA RIGHT(1), RIGHT(2) / '20000000, '00000352 / C DATA DIVER(1), DIVER(2) / '20000000, '00000353 / C DATA LOG10(1), LOG10(2) / '23210115, '00000377 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES C C DATA RMACH(1) / O402400000000 / C DATA RMACH(2) / O376777777777 / C DATA RMACH(3) / O714400000000 / C DATA RMACH(4) / O716400000000 / C DATA RMACH(5) / O776464202324 / C C MACHINE CONSTANTS FOR THE HP 730 C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE HP 2100 C 3 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE HP 9000 C C DATA SMALL(1) / 00004000000B / C DATA LARGE(1) / 17677777777B / C DATA RIGHT(1) / 06340000000B / C DATA DIVER(1) / 06400000000B / C DATA LOG10(1) / 07646420233B / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND C THE PERKIN ELMER (INTERDATA) 7/32. C C DATA RMACH(1) / Z00100000 / C DATA RMACH(2) / Z7FFFFFFF / C DATA RMACH(3) / Z3B100000 / C DATA RMACH(4) / Z3C100000 / C DATA RMACH(5) / Z41134413 / C C MACHINE CONSTANTS FOR THE IBM PC C C DATA SMALL(1) / 1.18E-38 / C DATA LARGE(1) / 3.40E+38 / C DATA RIGHT(1) / 0.595E-07 / C DATA DIVER(1) / 1.19E-07 / C DATA LOG10(1) / 0.30102999566 / C C MACHINE CONSTANTS FOR THE IBM RS 6000 C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE INTEL i860 C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR) C C DATA RMACH(1) / "000400000000 / C DATA RMACH(2) / "377777777777 / C DATA RMACH(3) / "146400000000 / C DATA RMACH(4) / "147400000000 / C DATA RMACH(5) / "177464202324 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1) / 8388608 / C DATA LARGE(1) / 2147483647 / C DATA RIGHT(1) / 880803840 / C DATA DIVER(1) / 889192448 / C DATA LOG10(1) / 1067065499 / C C DATA RMACH(1) / O00040000000 / C DATA RMACH(2) / O17777777777 / C DATA RMACH(3) / O06440000000 / C DATA RMACH(4) / O06500000000 / C DATA RMACH(5) / O07746420233 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1), SMALL(2) / 128, 0 / C DATA LARGE(1), LARGE(2) / 32767, -1 / C DATA RIGHT(1), RIGHT(2) / 13440, 0 / C DATA DIVER(1), DIVER(2) / 13568, 0 / C DATA LOG10(1), LOG10(2) / 16282, 8347 / C C DATA SMALL(1), SMALL(2) / O000200, O000000 / C DATA LARGE(1), LARGE(2) / O077777, O177777 / C DATA RIGHT(1), RIGHT(2) / O032200, O000000 / C DATA DIVER(1), DIVER(2) / O032400, O000000 / C DATA LOG10(1), LOG10(2) / O037632, O020233 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE SUN C C DATA RMACH(1) / Z'00800000' / C DATA RMACH(2) / Z'7F7FFFFF' / C DATA RMACH(3) / Z'33800000' / C DATA RMACH(4) / Z'34000000' / C DATA RMACH(5) / Z'3E9A209B' / C C MACHINE CONSTANTS FOR THE SUN C USING THE -r8 COMPILER OPTION C C DATA RMACH(1) / Z'0010000000000000' / C DATA RMACH(2) / Z'7FEFFFFFFFFFFFFF' / C DATA RMACH(3) / Z'3CA0000000000000' / C DATA RMACH(4) / Z'3CB0000000000000' / C DATA RMACH(5) / Z'3FD34413509F79FF' / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES C C DATA RMACH(1) / O000400000000 / C DATA RMACH(2) / O377777777777 / C DATA RMACH(3) / O146400000000 / C DATA RMACH(4) / O147400000000 / C DATA RMACH(5) / O177464202324 / C C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR C C DATA SMALL(1), SMALL(2) / 0, 256/ C DATA LARGE(1), LARGE(2) / -1, -129/ C DATA RIGHT(1), RIGHT(2) / 0, 26880/ C DATA DIVER(1), DIVER(2) / 0, 27136/ C DATA LOG10(1), LOG10(2) / 8347, 32538/ C C***FIRST EXECUTABLE STATEMENT R1MACH IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'R1MACH', + 'I OUT OF BOUNDS', 1, 2) C R1MACH = RMACH(I) RETURN C END PDL-2.018/Lib/Slatec/slatec/radb2.f0000644060175006010010000000406012562522365014741 0ustar chmNone*DECK RADB2 SUBROUTINE RADB2 (IDO, L1, CC, CH, WA1) C***BEGIN PROLOGUE RADB2 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length two. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADB2-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*). C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADB2 DIMENSION CC(IDO,2,*), CH(IDO,L1,2), WA1(*) C***FIRST EXECUTABLE STATEMENT RADB2 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) TR2 = CC(I-1,1,K)-CC(IC-1,2,K) CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) TI2 = CC(I,1,K)+CC(IC,2,K) CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 109 K=1,L1 CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) TR2 = CC(I-1,1,K)-CC(IC-1,2,K) CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) TI2 = CC(I,1,K)+CC(IC,2,K) CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) 106 CONTINUE 107 RETURN END PDL-2.018/Lib/Slatec/slatec/radb3.f0000644060175006010010000000565712562522365014757 0ustar chmNone*DECK RADB3 SUBROUTINE RADB3 (IDO, L1, CC, CH, WA1, WA2) C***BEGIN PROLOGUE RADB3 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length three. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADB3-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing definition of variable TAUI by using C FORTRAN intrinsic function SQRT instead of a DATA C statement. C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADB3 DIMENSION CC(IDO,3,*), CH(IDO,L1,3), WA1(*), WA2(*) C***FIRST EXECUTABLE STATEMENT RADB3 TAUR = -.5 TAUI = .5*SQRT(3.) DO 101 K=1,L1 TR2 = CC(IDO,2,K)+CC(IDO,2,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I TR2 = CC(I-1,3,K)+CC(IC-1,2,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,3,K)-CC(IC,2,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 TR2 = CC(I-1,3,K)+CC(IC-1,2,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,3,K)-CC(IC,2,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 105 CONTINUE 106 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/radb4.f0000644060175006010010000000737012562522365014752 0ustar chmNone*DECK RADB4 SUBROUTINE RADB4 (IDO, L1, CC, CH, WA1, WA2, WA3) C***BEGIN PROLOGUE RADB4 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length four. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADB4-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing definition of variable SQRT2 by using C FORTRAN intrinsic function SQRT instead of a DATA C statement. C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADB4 DIMENSION CC(IDO,4,*), CH(IDO,L1,4), WA1(*), WA2(*), WA3(*) C***FIRST EXECUTABLE STATEMENT RADB4 SQRT2 = SQRT(2.) DO 101 K=1,L1 TR1 = CC(1,1,K)-CC(IDO,4,K) TR2 = CC(1,1,K)+CC(IDO,4,K) TR3 = CC(IDO,2,K)+CC(IDO,2,K) TR4 = CC(1,3,K)+CC(1,3,K) CH(1,K,1) = TR2+TR3 CH(1,K,2) = TR1-TR4 CH(1,K,3) = TR2-TR3 CH(1,K,4) = TR1+TR4 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I TI1 = CC(I,1,K)+CC(IC,4,K) TI2 = CC(I,1,K)-CC(IC,4,K) TI3 = CC(I,3,K)-CC(IC,2,K) TR4 = CC(I,3,K)+CC(IC,2,K) TR1 = CC(I-1,1,K)-CC(IC-1,4,K) TR2 = CC(I-1,1,K)+CC(IC-1,4,K) TI4 = CC(I-1,3,K)-CC(IC-1,2,K) TR3 = CC(I-1,3,K)+CC(IC-1,2,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1-TR4 CR4 = TR1+TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 109 K=1,L1 TI1 = CC(I,1,K)+CC(IC,4,K) TI2 = CC(I,1,K)-CC(IC,4,K) TI3 = CC(I,3,K)-CC(IC,2,K) TR4 = CC(I,3,K)+CC(IC,2,K) TR1 = CC(I-1,1,K)-CC(IC-1,4,K) TR2 = CC(I-1,1,K)+CC(IC-1,4,K) TI4 = CC(I-1,3,K)-CC(IC-1,2,K) TR3 = CC(I-1,3,K)+CC(IC-1,2,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1-TR4 CR4 = TR1+TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 TI1 = CC(1,2,K)+CC(1,4,K) TI2 = CC(1,4,K)-CC(1,2,K) TR1 = CC(IDO,1,K)-CC(IDO,3,K) TR2 = CC(IDO,1,K)+CC(IDO,3,K) CH(IDO,K,1) = TR2+TR2 CH(IDO,K,2) = SQRT2*(TR1-TI1) CH(IDO,K,3) = TI2+TI2 CH(IDO,K,4) = -SQRT2*(TR1+TI1) 106 CONTINUE 107 RETURN END PDL-2.018/Lib/Slatec/slatec/radb5.f0000644060175006010010000001134012562522365014743 0ustar chmNone*DECK RADB5 SUBROUTINE RADB5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) C***BEGIN PROLOGUE RADB5 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length five. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADB5-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing definition of variables PI, TI11, TI12, C TR11, TR12 by using FORTRAN intrinsic functions ATAN C and SIN instead of DATA statements. C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADB5 DIMENSION CC(IDO,5,*), CH(IDO,L1,5), WA1(*), WA2(*), WA3(*), + WA4(*) C***FIRST EXECUTABLE STATEMENT RADB5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) DO 101 K=1,L1 TI5 = CC(1,3,K)+CC(1,3,K) TI4 = CC(1,5,K)+CC(1,5,K) TR2 = CC(IDO,2,K)+CC(IDO,2,K) TR3 = CC(IDO,4,K)+CC(IDO,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI5 = TI11*TI5+TI12*TI4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(1,K,5) = CR2+CI5 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I TI5 = CC(I,3,K)+CC(IC,2,K) TI2 = CC(I,3,K)-CC(IC,2,K) TI4 = CC(I,5,K)+CC(IC,4,K) TI3 = CC(I,5,K)-CC(IC,4,K) TR5 = CC(I-1,3,K)-CC(IC-1,2,K) TR2 = CC(I-1,3,K)+CC(IC-1,2,K) TR4 = CC(I-1,5,K)-CC(IC-1,4,K) TR3 = CC(I-1,5,K)+CC(IC-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 TI5 = CC(I,3,K)+CC(IC,2,K) TI2 = CC(I,3,K)-CC(IC,2,K) TI4 = CC(I,5,K)+CC(IC,4,K) TI3 = CC(I,5,K)-CC(IC,4,K) TR5 = CC(I-1,3,K)-CC(IC-1,2,K) TR2 = CC(I-1,3,K)+CC(IC-1,2,K) TR4 = CC(I-1,5,K)-CC(IC-1,4,K) TR3 = CC(I-1,5,K)+CC(IC-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 105 CONTINUE 106 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/radbg.f0000644060175006010010000001310412562522365015025 0ustar chmNone*DECK RADBG SUBROUTINE RADBG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) C***BEGIN PROLOGUE RADBG C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C arbitrary length. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADBG-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing references to intrinsic function FLOAT C to REAL, and C (c) changing definition of variable TPI by using C FORTRAN intrinsic function ATAN instead of a DATA C statement. C 881128 Modified by Dick Valent to meet prologue standards. C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADBG DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), + C2(IDL1,*), CH2(IDL1,*), WA(*) C***FIRST EXECUTABLE STATEMENT RADBG TPI = 8.*ATAN(1.) ARG = TPI/IP DCP = COS(ARG) DSP = SIN(ARG) IDP2 = IDO+2 NBD = (IDO-1)/2 IPP2 = IP+2 IPPH = (IP+1)/2 IF (IDO .LT. L1) GO TO 103 DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,1) = CC(I,1,K) 101 CONTINUE 102 CONTINUE GO TO 106 103 DO 105 I=1,IDO DO 104 K=1,L1 CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE 106 DO 108 J=2,IPPH JC = IPP2-J J2 = J+J DO 107 K=1,L1 CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) 107 CONTINUE 108 CONTINUE IF (IDO .EQ. 1) GO TO 116 IF (NBD .LT. L1) GO TO 112 DO 111 J=2,IPPH JC = IPP2-J DO 110 K=1,L1 CDIR$ IVDEP DO 109 I=3,IDO,2 IC = IDP2-I CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) 109 CONTINUE 110 CONTINUE 111 CONTINUE GO TO 116 112 DO 115 J=2,IPPH JC = IPP2-J CDIR$ IVDEP DO 114 I=3,IDO,2 IC = IDP2-I DO 113 K=1,L1 CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) 113 CONTINUE 114 CONTINUE 115 CONTINUE 116 AR1 = 1. AI1 = 0. DO 120 L=2,IPPH LC = IPP2-L AR1H = DCP*AR1-DSP*AI1 AI1 = DCP*AI1+DSP*AR1 AR1 = AR1H DO 117 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) C2(IK,LC) = AI1*CH2(IK,IP) 117 CONTINUE DC2 = AR1 DS2 = AI1 AR2 = AR1 AI2 = AI1 DO 119 J=3,IPPH JC = IPP2-J AR2H = DC2*AR2-DS2*AI2 AI2 = DC2*AI2+DS2*AR2 AR2 = AR2H DO 118 IK=1,IDL1 C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) 118 CONTINUE 119 CONTINUE 120 CONTINUE DO 122 J=2,IPPH DO 121 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 121 CONTINUE 122 CONTINUE DO 124 J=2,IPPH JC = IPP2-J DO 123 K=1,L1 CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) 123 CONTINUE 124 CONTINUE IF (IDO .EQ. 1) GO TO 132 IF (NBD .LT. L1) GO TO 128 DO 127 J=2,IPPH JC = IPP2-J DO 126 K=1,L1 CDIR$ IVDEP DO 125 I=3,IDO,2 CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) 125 CONTINUE 126 CONTINUE 127 CONTINUE GO TO 132 128 DO 131 J=2,IPPH JC = IPP2-J DO 130 I=3,IDO,2 DO 129 K=1,L1 CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) 129 CONTINUE 130 CONTINUE 131 CONTINUE 132 CONTINUE IF (IDO .EQ. 1) RETURN DO 133 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 133 CONTINUE DO 135 J=2,IP DO 134 K=1,L1 C1(1,K,J) = CH(1,K,J) 134 CONTINUE 135 CONTINUE IF (NBD .GT. L1) GO TO 139 IS = -IDO DO 138 J=2,IP IS = IS+IDO IDIJ = IS DO 137 I=3,IDO,2 IDIJ = IDIJ+2 DO 136 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 136 CONTINUE 137 CONTINUE 138 CONTINUE GO TO 143 139 IS = -IDO DO 142 J=2,IP IS = IS+IDO DO 141 K=1,L1 IDIJ = IS CDIR$ IVDEP DO 140 I=3,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 140 CONTINUE 141 CONTINUE 142 CONTINUE 143 RETURN END PDL-2.018/Lib/Slatec/slatec/radf2.f0000644060175006010010000000402212562522365014743 0ustar chmNone*DECK RADF2 SUBROUTINE RADF2 (IDO, L1, CC, CH, WA1) C***BEGIN PROLOGUE RADF2 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length two. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADF2-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*). C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADF2 DIMENSION CH(IDO,2,*), CC(IDO,L1,2), WA1(*) C***FIRST EXECUTABLE STATEMENT RADF2 DO 101 K=1,L1 CH(1,1,K) = CC(1,K,1)+CC(1,K,2) CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CH(I,1,K) = CC(I,K,1)+TI2 CH(IC,2,K) = TI2-CC(I,K,1) CH(I-1,1,K) = CC(I-1,K,1)+TR2 CH(IC-1,2,K) = CC(I-1,K,1)-TR2 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 109 K=1,L1 TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CH(I,1,K) = CC(I,K,1)+TI2 CH(IC,2,K) = TI2-CC(I,K,1) CH(I-1,1,K) = CC(I-1,K,1)+TR2 CH(IC-1,2,K) = CC(I-1,K,1)-TR2 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(1,2,K) = -CC(IDO,K,2) CH(IDO,1,K) = CC(IDO,K,1) 106 CONTINUE 107 RETURN END PDL-2.018/Lib/Slatec/slatec/radf3.f0000644060175006010010000000557312562522365014760 0ustar chmNone*DECK RADF3 SUBROUTINE RADF3 (IDO, L1, CC, CH, WA1, WA2) C***BEGIN PROLOGUE RADF3 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length three. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADF3-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing definition of variable TAUI by using C FORTRAN intrinsic function SQRT instead of a DATA C statement. C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADF3 DIMENSION CH(IDO,3,*), CC(IDO,L1,3), WA1(*), WA2(*) C***FIRST EXECUTABLE STATEMENT RADF3 TAUR = -.5 TAUI = .5*SQRT(3.) DO 101 K=1,L1 CR2 = CC(1,K,2)+CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2 CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR2 = DR2+DR3 CI2 = DI2+DI3 CH(I-1,1,K) = CC(I-1,K,1)+CR2 CH(I,1,K) = CC(I,K,1)+CI2 TR2 = CC(I-1,K,1)+TAUR*CR2 TI2 = CC(I,K,1)+TAUR*CI2 TR3 = TAUI*(DI2-DI3) TI3 = TAUI*(DR3-DR2) CH(I-1,3,K) = TR2+TR3 CH(IC-1,2,K) = TR2-TR3 CH(I,3,K) = TI2+TI3 CH(IC,2,K) = TI3-TI2 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR2 = DR2+DR3 CI2 = DI2+DI3 CH(I-1,1,K) = CC(I-1,K,1)+CR2 CH(I,1,K) = CC(I,K,1)+CI2 TR2 = CC(I-1,K,1)+TAUR*CR2 TI2 = CC(I,K,1)+TAUR*CI2 TR3 = TAUI*(DI2-DI3) TI3 = TAUI*(DR3-DR2) CH(I-1,3,K) = TR2+TR3 CH(IC-1,2,K) = TR2-TR3 CH(I,3,K) = TI2+TI3 CH(IC,2,K) = TI3-TI2 105 CONTINUE 106 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/radf4.f0000644060175006010010000000722712562522365014757 0ustar chmNone*DECK RADF4 SUBROUTINE RADF4 (IDO, L1, CC, CH, WA1, WA2, WA3) C***BEGIN PROLOGUE RADF4 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length four. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADF4-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*). C (b) changing definition of variable HSQT2 by using C FORTRAN intrinsic function SQRT instead of a DATA C statement. C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADF4 DIMENSION CC(IDO,L1,4), CH(IDO,4,*), WA1(*), WA2(*), WA3(*) C***FIRST EXECUTABLE STATEMENT RADF4 HSQT2 = .5*SQRT(2.) DO 101 K=1,L1 TR1 = CC(1,K,2)+CC(1,K,4) TR2 = CC(1,K,1)+CC(1,K,3) CH(1,1,K) = TR1+TR2 CH(IDO,4,K) = TR2-TR1 CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) CH(1,3,K) = CC(1,K,4)-CC(1,K,2) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 111 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) TR1 = CR2+CR4 TR4 = CR4-CR2 TI1 = CI2+CI4 TI4 = CI2-CI4 TI2 = CC(I,K,1)+CI3 TI3 = CC(I,K,1)-CI3 TR2 = CC(I-1,K,1)+CR3 TR3 = CC(I-1,K,1)-CR3 CH(I-1,1,K) = TR1+TR2 CH(IC-1,4,K) = TR2-TR1 CH(I,1,K) = TI1+TI2 CH(IC,4,K) = TI1-TI2 CH(I-1,3,K) = TI4+TR3 CH(IC-1,2,K) = TR3-TI4 CH(I,3,K) = TR4+TI3 CH(IC,2,K) = TR4-TI3 103 CONTINUE 104 CONTINUE GO TO 110 111 DO 109 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 108 K=1,L1 CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) TR1 = CR2+CR4 TR4 = CR4-CR2 TI1 = CI2+CI4 TI4 = CI2-CI4 TI2 = CC(I,K,1)+CI3 TI3 = CC(I,K,1)-CI3 TR2 = CC(I-1,K,1)+CR3 TR3 = CC(I-1,K,1)-CR3 CH(I-1,1,K) = TR1+TR2 CH(IC-1,4,K) = TR2-TR1 CH(I,1,K) = TI1+TI2 CH(IC,4,K) = TI1-TI2 CH(I-1,3,K) = TI4+TR3 CH(IC-1,2,K) = TR3-TI4 CH(I,3,K) = TR4+TI3 CH(IC,2,K) = TR4-TI3 108 CONTINUE 109 CONTINUE 110 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) CH(IDO,1,K) = TR1+CC(IDO,K,1) CH(IDO,3,K) = CC(IDO,K,1)-TR1 CH(1,2,K) = TI1-CC(IDO,K,3) CH(1,4,K) = TI1+CC(IDO,K,3) 106 CONTINUE 107 RETURN END PDL-2.018/Lib/Slatec/slatec/radf5.f0000644060175006010010000001117012562522365014750 0ustar chmNone*DECK RADF5 SUBROUTINE RADF5 (IDO, L1, CC, CH, WA1, WA2, WA3, WA4) C***BEGIN PROLOGUE RADF5 C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C length five. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADF5-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing definition of variables PI, TI11, TI12, C TR11, TR12 by using FORTRAN intrinsic functions ATAN C and SIN instead of DATA statements. C 881128 Modified by Dick Valent to meet prologue standards. C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADF5 DIMENSION CC(IDO,L1,5), CH(IDO,5,*), WA1(*), WA2(*), WA3(*), + WA4(*) C***FIRST EXECUTABLE STATEMENT RADF5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) DO 101 K=1,L1 CR2 = CC(1,K,5)+CC(1,K,2) CI5 = CC(1,K,5)-CC(1,K,2) CR3 = CC(1,K,4)+CC(1,K,3) CI4 = CC(1,K,4)-CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2+CR3 CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 CH(1,3,K) = TI11*CI5+TI12*CI4 CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 CH(1,5,K) = TI12*CI5-TI11*CI4 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) CR2 = DR2+DR5 CI5 = DR5-DR2 CR5 = DI2-DI5 CI2 = DI2+DI5 CR3 = DR3+DR4 CI4 = DR4-DR3 CR4 = DI3-DI4 CI3 = DI3+DI4 CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 CH(I,1,K) = CC(I,K,1)+CI2+CI3 TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 TR5 = TI11*CR5+TI12*CR4 TI5 = TI11*CI5+TI12*CI4 TR4 = TI12*CR5-TI11*CR4 TI4 = TI12*CI5-TI11*CI4 CH(I-1,3,K) = TR2+TR5 CH(IC-1,2,K) = TR2-TR5 CH(I,3,K) = TI2+TI5 CH(IC,2,K) = TI5-TI2 CH(I-1,5,K) = TR3+TR4 CH(IC-1,4,K) = TR3-TR4 CH(I,5,K) = TI3+TI4 CH(IC,4,K) = TI4-TI3 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) CR2 = DR2+DR5 CI5 = DR5-DR2 CR5 = DI2-DI5 CI2 = DI2+DI5 CR3 = DR3+DR4 CI4 = DR4-DR3 CR4 = DI3-DI4 CI3 = DI3+DI4 CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 CH(I,1,K) = CC(I,K,1)+CI2+CI3 TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 TR5 = TI11*CR5+TI12*CR4 TI5 = TI11*CI5+TI12*CI4 TR4 = TI12*CR5-TI11*CR4 TI4 = TI12*CI5-TI11*CI4 CH(I-1,3,K) = TR2+TR5 CH(IC-1,2,K) = TR2-TR5 CH(I,3,K) = TI2+TI5 CH(IC,2,K) = TI5-TI2 CH(I-1,5,K) = TR3+TR4 CH(IC-1,4,K) = TR3-TR4 CH(I,5,K) = TI3+TI4 CH(IC,4,K) = TI4-TI3 105 CONTINUE 106 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/radfg.f0000644060175006010010000001307612562522365015041 0ustar chmNone*DECK RADFG SUBROUTINE RADFG (IDO, IP, L1, IDL1, CC, C1, C2, CH, CH2, WA) C***BEGIN PROLOGUE RADFG C***SUBSIDIARY C***PURPOSE Calculate the fast Fourier transform of subvectors of C arbitrary length. C***LIBRARY SLATEC (FFTPACK) C***TYPE SINGLE PRECISION (RADFG-S) C***AUTHOR Swarztrauber, P. N., (NCAR) C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C (a) changing dummy array size declarations (1) to (*), C (b) changing references to intrinsic function FLOAT C to REAL, and C (c) changing definition of variable TPI by using C FORTRAN intrinsic function ATAN instead of a DATA C statement. C 881128 Modified by Dick Valent to meet prologue standards. C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900402 Added TYPE section. (WRB) C***END PROLOGUE RADFG DIMENSION CH(IDO,L1,*), CC(IDO,IP,*), C1(IDO,L1,*), + C2(IDL1,*), CH2(IDL1,*), WA(*) C***FIRST EXECUTABLE STATEMENT RADFG TPI = 8.*ATAN(1.) ARG = TPI/IP DCP = COS(ARG) DSP = SIN(ARG) IPPH = (IP+1)/2 IPP2 = IP+2 IDP2 = IDO+2 NBD = (IDO-1)/2 IF (IDO .EQ. 1) GO TO 119 DO 101 IK=1,IDL1 CH2(IK,1) = C2(IK,1) 101 CONTINUE DO 103 J=2,IP DO 102 K=1,L1 CH(1,K,J) = C1(1,K,J) 102 CONTINUE 103 CONTINUE IF (NBD .GT. L1) GO TO 107 IS = -IDO DO 106 J=2,IP IS = IS+IDO IDIJ = IS DO 105 I=3,IDO,2 IDIJ = IDIJ+2 DO 104 K=1,L1 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) 104 CONTINUE 105 CONTINUE 106 CONTINUE GO TO 111 107 IS = -IDO DO 110 J=2,IP IS = IS+IDO DO 109 K=1,L1 IDIJ = IS CDIR$ IVDEP DO 108 I=3,IDO,2 IDIJ = IDIJ+2 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) 108 CONTINUE 109 CONTINUE 110 CONTINUE 111 IF (NBD .LT. L1) GO TO 115 DO 114 J=2,IPPH JC = IPP2-J DO 113 K=1,L1 CDIR$ IVDEP DO 112 I=3,IDO,2 C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) 112 CONTINUE 113 CONTINUE 114 CONTINUE GO TO 121 115 DO 118 J=2,IPPH JC = IPP2-J DO 117 I=3,IDO,2 DO 116 K=1,L1 C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) 116 CONTINUE 117 CONTINUE 118 CONTINUE GO TO 121 119 DO 120 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 120 CONTINUE 121 DO 123 J=2,IPPH JC = IPP2-J DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) 122 CONTINUE 123 CONTINUE C AR1 = 1. AI1 = 0. DO 127 L=2,IPPH LC = IPP2-L AR1H = DCP*AR1-DSP*AI1 AI1 = DCP*AI1+DSP*AR1 AR1 = AR1H DO 124 IK=1,IDL1 CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) CH2(IK,LC) = AI1*C2(IK,IP) 124 CONTINUE DC2 = AR1 DS2 = AI1 AR2 = AR1 AI2 = AI1 DO 126 J=3,IPPH JC = IPP2-J AR2H = DC2*AR2-DS2*AI2 AI2 = DC2*AI2+DS2*AR2 AR2 = AR2H DO 125 IK=1,IDL1 CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) 125 CONTINUE 126 CONTINUE 127 CONTINUE DO 129 J=2,IPPH DO 128 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+C2(IK,J) 128 CONTINUE 129 CONTINUE C IF (IDO .LT. L1) GO TO 132 DO 131 K=1,L1 DO 130 I=1,IDO CC(I,1,K) = CH(I,K,1) 130 CONTINUE 131 CONTINUE GO TO 135 132 DO 134 I=1,IDO DO 133 K=1,L1 CC(I,1,K) = CH(I,K,1) 133 CONTINUE 134 CONTINUE 135 DO 137 J=2,IPPH JC = IPP2-J J2 = J+J DO 136 K=1,L1 CC(IDO,J2-2,K) = CH(1,K,J) CC(1,J2-1,K) = CH(1,K,JC) 136 CONTINUE 137 CONTINUE IF (IDO .EQ. 1) RETURN IF (NBD .LT. L1) GO TO 141 DO 140 J=2,IPPH JC = IPP2-J J2 = J+J DO 139 K=1,L1 CDIR$ IVDEP DO 138 I=3,IDO,2 IC = IDP2-I CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) 138 CONTINUE 139 CONTINUE 140 CONTINUE RETURN 141 DO 144 J=2,IPPH JC = IPP2-J J2 = J+J DO 143 I=3,IDO,2 IC = IDP2-I DO 142 K=1,L1 CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) 142 CONTINUE 143 CONTINUE 144 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/rfftb.f0000644060175006010010000000754212562522365015062 0ustar chmNone*DECK RFFTB SUBROUTINE RFFTB (N, R, WSAVE) C***BEGIN PROLOGUE RFFTB C***SUBSIDIARY C***PURPOSE Compute the backward fast Fourier transform of a real C coefficient array. C***LIBRARY SLATEC (FFTPACK) C***CATEGORY J1A1 C***TYPE SINGLE PRECISION (RFFTB-S, CFFTB-C) C***KEYWORDS FFTPACK, FOURIER TRANSFORM C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C ******************************************************************** C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * C ******************************************************************** C * * C * This routine uses non-standard Fortran 77 constructs and will * C * be removed from the library at a future date. You are * C * requested to use RFFTB1. * C * * C ******************************************************************** C C Subroutine RFFTB computes the real periodic sequence from its C Fourier coefficients (Fourier synthesis). The transform is defined C below at output parameter R. C C Input Arguments C C N the length of the array R to be transformed. The method C is most efficient when N is a product of small primes. C N may change so long as different work arrays are provided. C C R a real array of length N which contains the sequence C to be transformed. C C WSAVE a work array which must be dimensioned at least 2*N+15 C in the program that calls RFFTB. The WSAVE array must be C initialized by calling subroutine RFFTI, and a different C WSAVE array must be used for each different value of N. C This initialization does not have to be repeated so long as C remains unchanged. Thus subsequent transforms can be C obtained faster than the first. Moreover, the same WSAVE C array can be used by RFFTF and RFFTB as long as N remains C unchanged. C C Output Argument C C R For N even and for I = 1,...,N C C R(I) = R(1)+(-1)**(I-1)*R(N) C C plus the sum from K=2 to K=N/2 of C C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C For N odd and for I = 1,...,N C C R(I) = R(1) plus the sum from K=2 to K=(N+1)/2 of C C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C Note: This transform is unnormalized since a call of RFFTF C followed by a call of RFFTB will multiply the input C sequence by N. C C WSAVE contains results which must not be destroyed between C calls of RFFTB or RFFTF. C C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel C Computations (G. Rodrigue, ed.), Academic Press, C 1982, pp. 51-83. C***ROUTINES CALLED RFFTB1 C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*). C 861211 REVISION DATE from Version 3.2 C 881128 Modified by Dick Valent to meet prologue standards. C 891214 Prologue converted to Version 4.0 format. (BAB) C 900131 Routine changed from user-callable to subsidiary C because of non-standard Fortran 77 arguments in the C call to CFFTB1. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RFFTB DIMENSION R(*), WSAVE(*) C***FIRST EXECUTABLE STATEMENT RFFTB IF (N .EQ. 1) RETURN CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END PDL-2.018/Lib/Slatec/slatec/rfftb1.f0000644060175006010010000001147612562522365015144 0ustar chmNone*DECK RFFTB1 SUBROUTINE RFFTB1 (N, C, CH, WA, IFAC) C***BEGIN PROLOGUE RFFTB1 C***PURPOSE Compute the backward fast Fourier transform of a real C coefficient array. C***LIBRARY SLATEC (FFTPACK) C***CATEGORY J1A1 C***TYPE SINGLE PRECISION (RFFTB1-S, CFFTB1-C) C***KEYWORDS FFTPACK, FOURIER TRANSFORM C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C Subroutine RFFTB1 computes the real periodic sequence from its C Fourier coefficients (Fourier synthesis). The transform is defined C below at output parameter C. C C The arrays WA and IFAC which are used by subroutine RFFTB1 must be C initialized by calling subroutine RFFTI1. C C Input Arguments C C N the length of the array R to be transformed. The method C is most efficient when N is a product of small primes. C N may change so long as different work arrays are provided. C C C a real array of length N which contains the sequence C to be transformed. C C CH a real work array of length at least N. C C WA a real work array which must be dimensioned at least N. C C IFAC an integer work array which must be dimensioned at least 15. C C The WA and IFAC arrays must be initialized by calling C subroutine RFFTI1, and different WA and IFAC arrays must be C used for each different value of N. This initialization C does not have to be repeated so long as N remains unchanged. C Thus subsequent transforms can be obtained faster than the C first. The same WA and IFAC arrays can be used by RFFTF1 C and RFFTB1. C C Output Argument C C C For N even and for I = 1,...,N C C C(I) = C(1)+(-1)**(I-1)*C(N) C C plus the sum from K=2 to K=N/2 of C C 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C For N odd and for I = 1,...,N C C C(I) = C(1) plus the sum from K=2 to K=(N+1)/2 of C C 2.*C(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*C(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C Notes: This transform is unnormalized since a call of RFFTF1 C followed by a call of RFFTB1 will multiply the input C sequence by N. C C WA and IFAC contain initialization calculations which must C not be destroyed between calls of subroutine RFFTF1 or C RFFTB1. C C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel C Computations (G. Rodrigue, ed.), Academic Press, C 1982, pp. 51-83. C***ROUTINES CALLED RADB2, RADB3, RADB4, RADB5, RADBG C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*). C 881128 Modified by Dick Valent to meet prologue standards. C 891214 Prologue converted to Version 4.0 format. (BAB) C 900131 Routine changed from subsidiary to user-callable. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RFFTB1 DIMENSION CH(*), C(*), WA(*), IFAC(*) C***FIRST EXECUTABLE STATEMENT RFFTB1 NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDL1 = IDO*L1 IF (IP .NE. 4) GO TO 103 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 102 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA GO TO 115 103 IF (IP .NE. 2) GO TO 106 IF (NA .NE. 0) GO TO 104 CALL RADB2 (IDO,L1,C,CH,WA(IW)) GO TO 105 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) 105 NA = 1-NA GO TO 115 106 IF (IP .NE. 3) GO TO 109 IX2 = IW+IDO IF (NA .NE. 0) GO TO 107 CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 108 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA GO TO 115 109 IF (IP .NE. 5) GO TO 112 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 110 CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 111 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA GO TO 115 112 IF (NA .NE. 0) GO TO 113 CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) GO TO 114 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 IF (IDO .EQ. 1) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDO 116 CONTINUE IF (NA .EQ. 0) RETURN DO 117 I=1,N C(I) = CH(I) 117 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/rfftf.f0000644060175006010010000000751012562522365015061 0ustar chmNone*DECK RFFTF SUBROUTINE RFFTF (N, R, WSAVE) C***BEGIN PROLOGUE RFFTF C***SUBSIDIARY C***PURPOSE Compute the forward transform of a real, periodic sequence. C***LIBRARY SLATEC (FFTPACK) C***CATEGORY J1A1 C***TYPE SINGLE PRECISION (RFFTF-S, CFFTF-C) C***KEYWORDS FFTPACK, FOURIER TRANSFORM C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C ******************************************************************** C * NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE * C ******************************************************************** C * * C * This routine uses non-standard Fortran 77 constructs and will * C * be removed from the library at a future date. You are * C * requested to use RFFTF1. * C * * C ******************************************************************** C C Subroutine RFFTF computes the Fourier coefficients of a real C periodic sequence (Fourier analysis). The transform is defined C below at output parameter R. C C Input Arguments C C N the length of the array R to be transformed. The method C is most efficient when N is a product of small primes. C N may change so long as different work arrays are provided. C C R a real array of length N which contains the sequence C to be transformed. C C WSAVE a work array which must be dimensioned at least 2*N+15 C in the program that calls RFFTF. The WSAVE array must be C initialized by calling subroutine RFFTI, and a different C WSAVE array must be used for each different value of N. C This initialization does not have to be repeated so long as C remains unchanged. Thus subsequent transforms can be C obtained faster than the first. Moreover, the same WSAVE C array can be used by RFFTF and RFFTB as long as N remains C unchanged. C C Output Argument C C R R(1) = the sum from I=1 to I=N of R(I) C C If N is even set L = N/2; if N is odd set L = (N+1)/2 C C then for K = 2,...,L C C R(2*K-2) = the sum from I = 1 to I = N of C C R(I)*COS((K-1)*(I-1)*2*PI/N) C C R(2*K-1) = the sum from I = 1 to I = N of C C -R(I)*SIN((K-1)*(I-1)*2*PI/N) C C If N is even C C R(N) = the sum from I = 1 to I = N of C C (-1)**(I-1)*R(I) C C Note: This transform is unnormalized since a call of RFFTF C followed by a call of RFFTB will multiply the input C sequence by N. C C WSAVE contains results which must not be destroyed between C calls of RFFTF or RFFTB. C C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel C Computations (G. Rodrigue, ed.), Academic Press, C 1982, pp. 51-83. C***ROUTINES CALLED RFFTF1 C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*). C 861211 REVISION DATE from Version 3.2 C 881128 Modified by Dick Valent to meet prologue standards. C 891214 Prologue converted to Version 4.0 format. (BAB) C 900131 Routine changed from user-callable to subsidiary C because of non-standard Fortran 77 arguments in the C call to CFFTB1. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RFFTF DIMENSION R(*), WSAVE(*) C***FIRST EXECUTABLE STATEMENT RFFTF IF (N .EQ. 1) RETURN CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END PDL-2.018/Lib/Slatec/slatec/rfftf1.f0000644060175006010010000001143712562522365015145 0ustar chmNone*DECK RFFTF1 SUBROUTINE RFFTF1 (N, C, CH, WA, IFAC) C***BEGIN PROLOGUE RFFTF1 C***PURPOSE Compute the forward transform of a real, periodic sequence. C***LIBRARY SLATEC (FFTPACK) C***CATEGORY J1A1 C***TYPE SINGLE PRECISION (RFFTF1-S, CFFTF1-C) C***KEYWORDS FFTPACK, FOURIER TRANSFORM C***AUTHOR Swarztrauber, P. N., (NCAR) C***DESCRIPTION C C Subroutine RFFTF1 computes the Fourier coefficients of a real C periodic sequence (Fourier analysis). The transform is defined C below at output parameter C. C C The arrays WA and IFAC which are used by subroutine RFFTB1 must be C initialized by calling subroutine RFFTI1. C C Input Arguments C C N the length of the array R to be transformed. The method C is most efficient when N is a product of small primes. C N may change so long as different work arrays are provided. C C C a real array of length N which contains the sequence C to be transformed. C C CH a real work array of length at least N. C C WA a real work array which must be dimensioned at least N. C C IFAC an integer work array which must be dimensioned at least 15. C C The WA and IFAC arrays must be initialized by calling C subroutine RFFTI1, and different WA and IFAC arrays must be C used for each different value of N. This initialization C does not have to be repeated so long as N remains unchanged. C Thus subsequent transforms can be obtained faster than the C first. The same WA and IFAC arrays can be used by RFFTF1 C and RFFTB1. C C Output Argument C C C C(1) = the sum from I=1 to I=N of R(I) C C If N is even set L = N/2; if N is odd set L = (N+1)/2 C C then for K = 2,...,L C C C(2*K-2) = the sum from I = 1 to I = N of C C C(I)*COS((K-1)*(I-1)*2*PI/N) C C C(2*K-1) = the sum from I = 1 to I = N of C C -C(I)*SIN((K-1)*(I-1)*2*PI/N) C C If N is even C C C(N) = the sum from I = 1 to I = N of C C (-1)**(I-1)*C(I) C C Notes: This transform is unnormalized since a call of RFFTF1 C followed by a call of RFFTB1 will multiply the input C sequence by N. C C WA and IFAC contain initialization calculations which must C not be destroyed between calls of subroutine RFFTF1 or C RFFTB1. C C***REFERENCES P. N. Swarztrauber, Vectorizing the FFTs, in Parallel C Computations (G. Rodrigue, ed.), Academic Press, C 1982, pp. 51-83. C***ROUTINES CALLED RADF2, RADF3, RADF4, RADF5, RADFG C***REVISION HISTORY (YYMMDD) C 790601 DATE WRITTEN C 830401 Modified to use SLATEC library source file format. C 860115 Modified by Ron Boisvert to adhere to Fortran 77 by C changing dummy array size declarations (1) to (*). C 881128 Modified by Dick Valent to meet prologue standards. C 891214 Prologue converted to Version 4.0 format. (BAB) C 900131 Routine changed from subsidiary to user-callable. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RFFTF1 DIMENSION CH(*), C(*), WA(*), IFAC(*) C***FIRST EXECUTABLE STATEMENT RFFTF1 NF = IFAC(2) NA = 1 L2 = N IW = N DO 111 K1=1,NF KH = NF-K1 IP = IFAC(KH+3) L1 = L2/IP IDO = N/L2 IDL1 = IDO*L1 IW = IW-(IP-1)*IDO NA = 1-NA IF (IP .NE. 4) GO TO 102 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 110 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) GO TO 110 102 IF (IP .NE. 2) GO TO 104 IF (NA .NE. 0) GO TO 103 CALL RADF2 (IDO,L1,C,CH,WA(IW)) GO TO 110 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) GO TO 110 104 IF (IP .NE. 3) GO TO 106 IX2 = IW+IDO IF (NA .NE. 0) GO TO 105 CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 110 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) GO TO 110 106 IF (IP .NE. 5) GO TO 108 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 107 CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 108 IF (IDO .EQ. 1) NA = 1-NA IF (NA .NE. 0) GO TO 109 CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) NA = 1 GO TO 110 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) NA = 0 110 L2 = L1 111 CONTINUE IF (NA .EQ. 1) RETURN DO 112 I=1,N C(I) = CH(I) 112 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/rs.f0000644060175006010010000000651312562522365014400 0ustar chmNone*DECK RSFOO SUBROUTINE RSFOO (NM, N, A, W, MATZ, Z, FV1, FV2, IERR) C***BEGIN PROLOGUE RS C***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors C of a real symmetric matrix. C***LIBRARY SLATEC (EISPACK) C***CATEGORY D4A1 C***TYPE SINGLE PRECISION (RS-S, CH-C) C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK C***AUTHOR Smith, B. T., et al. C***DESCRIPTION C C This subroutine calls the recommended sequence of C subroutines from the eigensystem subroutine package (EISPACK) C to find the eigenvalues and eigenvectors (if desired) C of a REAL SYMMETRIC matrix. C C On Input C C NM must be set to the row dimension of the two-dimensional C array parameters, A and Z, as declared in the calling C program dimension statement. NM is an INTEGER variable. C C N is the order of the matrix A. N is an INTEGER variable. C N must be less than or equal to NM. C C A contains the real symmetric matrix. A is a two-dimensional C REAL array, dimensioned A(NM,N). C C MATZ is an INTEGER variable set equal to zero if only C eigenvalues are desired. Otherwise, it is set to any C non-zero integer for both eigenvalues and eigenvectors. C C On Output C C A is unaltered. C C W contains the eigenvalues in ascending order. W is a one- C dimensional REAL array, dimensioned W(N). C C Z contains the eigenvectors if MATZ is not zero. The C eigenvectors are orthonormal. Z is a two-dimensional C REAL array, dimensioned Z(NM,N). C C IERR is an INTEGER flag set to C Zero for normal return, C 10*N if N is greater than NM, C J if the J-th eigenvalue has not been C determined after 30 iterations. C The eigenvalues, and eigenvectors if requested, C should be correct for indices 1, 2, ..., IERR-1. C C FV1 and FV2 are one-dimensional REAL arrays used for temporary C storage, dimensioned FV1(N) and FV2(N). C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- C system Routines - EISPACK Guide, Springer-Verlag, C 1976. C***ROUTINES CALLED TQL2, TQLRAT, TRED1, TRED2 C***REVISION HISTORY (YYMMDD) C 760101 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE RS C INTEGER N,NM,IERR,MATZ REAL A(NM,*),W(*),Z(NM,*),FV1(*),FV2(*) C C***FIRST EXECUTABLE STATEMENT RS IF (N .LE. NM) GO TO 10 IERR = 10 * N GO TO 50 C 10 IF (MATZ .NE. 0) GO TO 20 C .......... FIND EIGENVALUES ONLY .......... CALL TRED1(NM,N,A,W,FV1,FV2) CALL TQLRAT(N,W,FV2,IERR) GO TO 50 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 20 CALL TRED2(NM,N,A,W,FV1,Z) CALL TQL2(NM,N,W,FV1,Z,IERR) 50 RETURN END PDL-2.018/Lib/Slatec/slatec/sasum.f0000644060175006010010000000470612562522365015106 0ustar chmNone*DECK SASUM REAL FUNCTION SASUM (N, SX, INCX) C***BEGIN PROLOGUE SASUM C***PURPOSE Compute the sum of the magnitudes of the elements of a C vector. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A3A C***TYPE SINGLE PRECISION (SASUM-S, DASUM-D, SCASUM-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, SUM OF MAGNITUDES OF A VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(S) C SX single precision vector with N elements C INCX storage spacing between elements of SX C C --Output-- C SASUM single precision result (zero if N .LE. 0) C C Returns sum of magnitudes of single precision SX. C SASUM = sum from 0 to N-1 of ABS(SX(IX+I*INCX)), C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900821 Modified to correct problem with a negative increment. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SASUM REAL SX(*) INTEGER I, INCX, IX, M, MP1, N C***FIRST EXECUTABLE STATEMENT SASUM SASUM = 0.0E0 IF (N .LE. 0) RETURN C IF (INCX .EQ. 1) GOTO 20 C C Code for increment not equal to 1. C IX = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N SASUM = SASUM + ABS(SX(IX)) IX = IX + INCX 10 CONTINUE RETURN C C Code for increment equal to 1. C C Clean-up loop so remaining vector length is a multiple of 6. C 20 M = MOD(N,6) IF (M .EQ. 0) GOTO 40 DO 30 I = 1,M SASUM = SASUM + ABS(SX(I)) 30 CONTINUE IF (N .LT. 6) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 SASUM = SASUM + ABS(SX(I)) + ABS(SX(I+1)) + ABS(SX(I+2)) + 1 ABS(SX(I+3)) + ABS(SX(I+4)) + ABS(SX(I+5)) 50 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/saxpy.f0000644060175006010010000000562712562522365015125 0ustar chmNone*DECK SAXPY SUBROUTINE SAXPY (N, SA, SX, INCX, SY, INCY) C***BEGIN PROLOGUE SAXPY C***PURPOSE Compute a constant times a vector plus a vector. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A7 C***TYPE SINGLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, TRIAD, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SA single precision scalar multiplier C SX single precision vector with N elements C INCX storage spacing between elements of SX C SY single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SY single precision result (unchanged if N .LE. 0) C C Overwrite single precision SY with single precision SA*SX +SY. C For I = 0 to N-1, replace SY(LY+I*INCY) with SA*SX(LX+I*INCX) + C SY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is C defined in a similar way using INCY. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Corrected definition of LX in DESCRIPTION. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SAXPY REAL SX(*), SY(*), SA C***FIRST EXECUTABLE STATEMENT SAXPY IF (N.LE.0 .OR. SA.EQ.0.0E0) RETURN IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 C C Code for unequal or nonpositive increments. C 5 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C Code for both increments equal to 1. C C Clean-up loop so remaining vector length is a multiple of 4. C 20 M = MOD(N,4) IF (M .EQ. 0) GO TO 40 DO 30 I = 1,M SY(I) = SY(I) + SA*SX(I) 30 CONTINUE IF (N .LT. 4) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 SY(I) = SY(I) + SA*SX(I) SY(I+1) = SY(I+1) + SA*SX(I+1) SY(I+2) = SY(I+2) + SA*SX(I+2) SY(I+3) = SY(I+3) + SA*SX(I+3) 50 CONTINUE RETURN C C Code for equal, positive, non-unit increments. C 60 NS = N*INCX DO 70 I = 1,NS,INCX SY(I) = SA*SX(I) + SY(I) 70 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/sdot.f0000644060175006010010000000545012562522365014724 0ustar chmNone*DECK SDOT REAL FUNCTION SDOT (N, SX, INCX, SY, INCY) C***BEGIN PROLOGUE SDOT C***PURPOSE Compute the inner product of two vectors. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A4 C***TYPE SINGLE PRECISION (SDOT-S, DDOT-D, CDOTU-C) C***KEYWORDS BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SX single precision vector with N elements C INCX storage spacing between elements of SX C SY single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SDOT single precision dot product (zero if N .LE. 0) C C Returns the dot product of single precision SX and SY. C SDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is C defined in a similar way using INCY. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Corrected definition of LX in DESCRIPTION. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SDOT REAL SX(*), SY(*) C***FIRST EXECUTABLE STATEMENT SDOT SDOT = 0.0E0 IF (N .LE. 0) RETURN IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 C C Code for unequal or nonpositive increments. C 5 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N SDOT = SDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C Code for both increments equal to 1. C C Clean-up loop so remaining vector length is a multiple of 5. C 20 M = MOD(N,5) IF (M .EQ. 0) GO TO 40 DO 30 I = 1,M SDOT = SDOT + SX(I)*SY(I) 30 CONTINUE IF (N .LT. 5) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SDOT = SDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) + SX(I+2)*SY(I+2) + 1 SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4) 50 CONTINUE RETURN C C Code for equal, positive, non-unit increments. C 60 NS = N*INCX DO 70 I = 1,NS,INCX SDOT = SDOT + SX(I)*SY(I) 70 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/sgeco.f0000644060175006010010000001450712562522365015056 0ustar chmNone*DECK SGECO SUBROUTINE SGECO (A, LDA, N, IPVT, RCOND, Z) C***BEGIN PROLOGUE SGECO C***PURPOSE Factor a matrix using Gaussian elimination and estimate C the condition number of the matrix. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2A1 C***TYPE SINGLE PRECISION (SGECO-S, DGECO-D, CGECO-C) C***KEYWORDS CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, C MATRIX FACTORIZATION C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C SGECO factors a real matrix by Gaussian elimination C and estimates the condition of the matrix. C C If RCOND is not needed, SGEFA is slightly faster. C To solve A*X = B , follow SGECO by SGESL. C To compute INVERSE(A)*C , follow SGECO by SGESL. C To compute DETERMINANT(A) , follow SGECO by SGEDI. C To compute INVERSE(A) , follow SGECO by SGEDI. C C On Entry C C A REAL(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U , where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an integer vector of pivot indices. C C RCOND REAL C an estimate of the reciprocal condition of A . C For the system A*X = B , relative perturbations C in A and B of size EPSILON may cause C relative perturbations in X of size EPSILON/RCOND . C If RCOND is so small that the logical expression C 1.0 + RCOND .EQ. 1.0 C is true, then A may be singular to working C precision. In particular, RCOND is zero if C exact singularity is detected or the estimate C underflows. C C Z REAL(N) C a work vector whose contents are usually unimportant. C If A is close to a singular matrix, then Z is C an approximate null vector in the sense that C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED SASUM, SAXPY, SDOT, SGEFA, SSCAL C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SGECO INTEGER LDA,N,IPVT(*) REAL A(LDA,*),Z(*) REAL RCOND C REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L C C COMPUTE 1-NORM OF A C C***FIRST EXECUTABLE STATEMENT SGECO ANORM = 0.0E0 DO 10 J = 1, N ANORM = MAX(ANORM,SASUM(N,A(1,J),1)) 10 CONTINUE C C FACTOR C CALL SGEFA(A,LDA,N,IPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID C OVERFLOW. C C SOLVE TRANS(U)*W = E C EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE DO 100 K = 1, N IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 S = ABS(A(K,K))/ABS(EK-Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) IF (A(K,K) .EQ. 0.0E0) GO TO 40 WK = WK/A(K,K) WKM = WKM/A(K,K) GO TO 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE KP1 = K + 1 IF (KP1 .GT. N) GO TO 90 DO 60 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 T = WKM - WK WK = WKM DO 70 J = KP1, N Z(J) = Z(J) + T*A(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C C SOLVE TRANS(L)*Y = W C DO 120 KB = 1, N K = N + 1 - KB IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110 S = 1.0E0/ABS(Z(K)) CALL SSCAL(N,S,Z,1) 110 CONTINUE L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T 120 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C YNORM = 1.0E0 C C SOLVE L*V = Y C DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T IF (K .LT. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130 S = 1.0E0/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 130 CONTINUE 140 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE U*Z = V C DO 160 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 S = ABS(A(K,K))/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 T = -Z(K) CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 RETURN END PDL-2.018/Lib/Slatec/slatec/sgedi.f0000644060175006010010000001022612562522365015043 0ustar chmNone*DECK SGEDI SUBROUTINE SGEDI (A, LDA, N, IPVT, DET, WORK, JOB) C***BEGIN PROLOGUE SGEDI C***PURPOSE Compute the determinant and inverse of a matrix using the C factors computed by SGECO or SGEFA. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2A1, D3A1 C***TYPE SINGLE PRECISION (SGEDI-S, DGEDI-D, CGEDI-C) C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C SGEDI computes the determinant and inverse of a matrix C using the factors computed by SGECO or SGEFA. C C On Entry C C A REAL(LDA, N) C the output from SGECO or SGEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from SGECO or SGEFA. C C WORK REAL(N) C work vector. Contents destroyed. C C JOB INTEGER C = 11 both determinant and inverse. C = 01 inverse only. C = 10 determinant only. C C On Return C C A inverse of original matrix if requested. C Otherwise unchanged. C C DET REAL(2) C determinant of original matrix if requested. C Otherwise not referenced. C Determinant = DET(1) * 10.0**DET(2) C with 1.0 .LE. ABS(DET(1)) .LT. 10.0 C or DET(1) .EQ. 0.0 . C C Error Condition C C A division by zero will occur if the input factor contains C a zero on the diagonal and the inverse is requested. C It will not occur if the subroutines are called correctly C and if SGECO has set RCOND .GT. 0.0 or SGEFA has set C INFO .EQ. 0 . C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED SAXPY, SSCAL, SSWAP C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SGEDI INTEGER LDA,N,IPVT(*),JOB REAL A(LDA,*),DET(2),WORK(*) C REAL T REAL TEN INTEGER I,J,K,KB,KP1,L,NM1 C***FIRST EXECUTABLE STATEMENT SGEDI C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(U) C IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = 1.0E0/A(K,K) T = -A(K,K) CALL SSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0E0 CALL SAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(U)*INVERSE(L) C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = 0.0E0 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL SAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL SSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/sgefa.f0000644060175006010010000000670212562522365015041 0ustar chmNone*DECK SGEFA SUBROUTINE SGEFA (A, LDA, N, IPVT, INFO) C***BEGIN PROLOGUE SGEFA C***PURPOSE Factor a matrix using Gaussian elimination. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2A1 C***TYPE SINGLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, C MATRIX FACTORIZATION C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C SGEFA factors a real matrix by Gaussian elimination. C C SGEFA is usually called by SGECO, but it can be called C directly with a saving in time if RCOND is not needed. C (Time for SGECO) = (1 + 9/N)*(Time for SGEFA) . C C On Entry C C A REAL(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U , where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an integer vector of pivot indices. C C INFO INTEGER C = 0 normal value. C = K if U(K,K) .EQ. 0.0 . This is not an error C condition for this subroutine, but it does C indicate that SGESL or SGEDI will divide by zero C if called. Use RCOND in SGECO for a reliable C indication of singularity. C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED ISAMAX, SAXPY, SSCAL C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SGEFA INTEGER LDA,N,IPVT(*),INFO REAL A(LDA,*) C REAL T INTEGER ISAMAX,J,K,KP1,L,NM1 C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C C***FIRST EXECUTABLE STATEMENT SGEFA INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = ISAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0E0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0E0/A(K,K) CALL SSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0E0) INFO = N RETURN END PDL-2.018/Lib/Slatec/slatec/sgesl.f0000644060175006010010000001002512562522365015062 0ustar chmNone * ====================================================================== * NIST Guide to Available Math Software. * Source for module SGESL from package SLATEC. * Retrieved from CAMSUN on Sat Sep 25 04:54:59 1999. * ====================================================================== *DECK SGESL SUBROUTINE SGESL (A, LDA, N, IPVT, B, JOB) C***BEGIN PROLOGUE SGESL C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the C factors of SGECO or SGEFA. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2A1 C***TYPE SINGLE PRECISION (SGESL-S, DGESL-D, CGESL-C) C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C SGESL solves the real system C A * X = B or TRANS(A) * X = B C using the factors computed by SGECO or SGEFA. C C On Entry C C A REAL(LDA, N) C the output from SGECO or SGEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from SGECO or SGEFA. C C B REAL(N) C the right hand side vector. C C JOB INTEGER C = 0 to solve A*X = B , C = nonzero to solve TRANS(A)*X = B where C TRANS(A) is the transpose. C C On Return C C B the solution vector X . C C Error Condition C C A division by zero will occur if the input factor contains a C zero on the diagonal. Technically, this indicates singularity, C but it is often caused by improper arguments or improper C setting of LDA . It will not occur if the subroutines are C called correctly and if SGECO has set RCOND .GT. 0.0 C or SGEFA has set INFO .EQ. 0 . C C To compute INVERSE(A) * C where C is a matrix C with P columns C CALL SGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND is too small) GO TO ... C DO 10 J = 1, P C CALL SGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED SAXPY, SDOT C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SGESL INTEGER LDA,N,IPVT(*),JOB REAL A(LDA,*),B(*) C REAL SDOT,T INTEGER K,KB,L,NM1 C***FIRST EXECUTABLE STATEMENT SGESL NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL SAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N T = SDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + SDOT(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/snrm2.f0000644060175006010010000001210512562522365015007 0ustar chmNone*DECK SNRM2 REAL FUNCTION SNRM2 (N, SX, INCX) C***BEGIN PROLOGUE SNRM2 C***PURPOSE Compute the Euclidean length (L2 norm) of a vector. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A3B C***TYPE SINGLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C) C***KEYWORDS BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2, C LINEAR ALGEBRA, UNITARY, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SX single precision vector with N elements C INCX storage spacing between elements of SX C C --Output-- C SNRM2 single precision result (zero if N .LE. 0) C C Euclidean norm of the N-vector stored in SX with storage C increment INCX . C If N .LE. 0, return with result = 0. C If N .GE. 1, then INCX must be .GE. 1 C C Four Phase Method using two built-in constants that are C hopefully applicable to all machines. C CUTLO = maximum of SQRT(U/EPS) over all known machines. C CUTHI = minimum of SQRT(V) over all known machines. C where C EPS = smallest no. such that EPS + 1. .GT. 1. C U = smallest positive no. (underflow limit) C V = largest no. (overflow limit) C C Brief Outline of Algorithm. C C Phase 1 scans zero components. C Move to phase 2 when a component is nonzero and .LE. CUTLO C Move to phase 3 when a component is .GT. CUTLO C Move to phase 4 when a component is .GE. CUTHI/M C where M = N for X() real and M = 2*N for complex. C C Values for CUTLO and CUTHI. C From the environmental parameters listed in the IMSL converter C document the limiting values are as follows: C CUTLO, S.P. U/EPS = 2**(-102) for Honeywell. Close seconds are C Univac and DEC at 2**(-103) C Thus CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 for Univac, Honeywell, and DEC. C Thus CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) for Honeywell and DEC. C Thus CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. same as S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI /8.232D-11, 1.304D19/ C DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SNRM2 INTEGER NEXT REAL SX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE SAVE CUTLO, CUTHI, ZERO, ONE DATA ZERO, ONE /0.0E0, 1.0E0/ C DATA CUTLO, CUTHI /4.441E-16, 1.304E19/ C***FIRST EXECUTABLE STATEMENT SNRM2 IF (N .GT. 0) GO TO 10 SNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C C BEGIN MAIN LOOP C I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF (ABS(SX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF (SX(I) .EQ. ZERO) GO TO 200 IF (ABS(SX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. C ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / SX(I)) / SX(I) 105 XMAX = ABS(SX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF (ABS(SX(I)) .GT. CUTLO) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF (ABS(SX(I)) .LE. XMAX) GO TO 115 SUM = ONE + SUM * (XMAX / SX(I))**2 XMAX = ABS(SX(I)) GO TO 200 C 115 SUM = SUM + (SX(I)/XMAX)**2 GO TO 200 C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI / N C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J = I,NN,INCX IF (ABS(SX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + SX(J)**2 SNRM2 = SQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF (I .LE. NN) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C SNRM2 = XMAX * SQRT(SUM) 300 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/spoco.f0000644060175006010010000001527112562522365015100 0ustar chmNone*DECK SPOCO SUBROUTINE SPOCO (A, LDA, N, RCOND, Z, INFO) C***BEGIN PROLOGUE SPOCO C***PURPOSE Factor a real symmetric positive definite matrix C and estimate the condition number of the matrix. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2B1B C***TYPE SINGLE PRECISION (SPOCO-S, DPOCO-D, CPOCO-C) C***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, C MATRIX FACTORIZATION, POSITIVE DEFINITE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C SPOCO factors a real symmetric positive definite matrix C and estimates the condition of the matrix. C C If RCOND is not needed, SPOFA is slightly faster. C To solve A*X = B , follow SPOCO by SPOSL. C To compute INVERSE(A)*C , follow SPOCO by SPOSL. C To compute DETERMINANT(A) , follow SPOCO by SPODI. C To compute INVERSE(A) , follow SPOCO by SPODI. C C On Entry C C A REAL(LDA, N) C the symmetric matrix to be factored. Only the C diagonal and upper triangle are used. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix R so that A = TRANS(R)*R C where TRANS(R) is the transpose. C The strict lower triangle is unaltered. C If INFO .NE. 0 , the factorization is not complete. C C RCOND REAL C an estimate of the reciprocal condition of A . C For the system A*X = B , relative perturbations C in A and B of size EPSILON may cause C relative perturbations in X of size EPSILON/RCOND . C If RCOND is so small that the logical expression C 1.0 + RCOND .EQ. 1.0 C is true, then A may be singular to working C precision. In particular, RCOND is zero if C exact singularity is detected or the estimate C underflows. If INFO .NE. 0 , RCOND is unchanged. C C Z REAL(N) C a work vector whose contents are usually unimportant. C If A is close to a singular matrix, then Z is C an approximate null vector in the sense that C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C If INFO .NE. 0 , Z is unchanged. C C INFO INTEGER C = 0 for normal return. C = K signals an error condition. The leading minor C of order K is not positive definite. C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED SASUM, SAXPY, SDOT, SPOFA, SSCAL C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SPOCO INTEGER LDA,N,INFO REAL A(LDA,*),Z(*) REAL RCOND C REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER I,J,JM1,K,KB,KP1 C C FIND NORM OF A USING ONLY UPPER HALF C C***FIRST EXECUTABLE STATEMENT SPOCO DO 30 J = 1, N Z(J) = SASUM(J,A(1,J),1) JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 I = 1, JM1 Z(I) = Z(I) + ABS(A(I,J)) 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = MAX(ANORM,Z(J)) 40 CONTINUE C C FACTOR C CALL SPOFA(A,LDA,N,INFO) IF (INFO .NE. 0) GO TO 180 C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF W WHERE TRANS(R)*W = E . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C C SOLVE TRANS(R)*W = E C EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE DO 110 K = 1, N IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. A(K,K)) GO TO 60 S = A(K,K)/ABS(EK-Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 60 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) WK = WK/A(K,K) WKM = WKM/A(K,K) KP1 = K + 1 IF (KP1 .GT. N) GO TO 100 DO 70 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 70 CONTINUE IF (S .GE. SM) GO TO 90 T = WKM - WK WK = WKM DO 80 J = KP1, N Z(J) = Z(J) + T*A(K,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE Z(K) = WK 110 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C C SOLVE R*Y = W C DO 130 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. A(K,K)) GO TO 120 S = A(K,K)/ABS(Z(K)) CALL SSCAL(N,S,Z,1) 120 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) 130 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C YNORM = 1.0E0 C C SOLVE TRANS(R)*V = Y C DO 150 K = 1, N Z(K) = Z(K) - SDOT(K-1,A(1,K),1,Z(1),1) IF (ABS(Z(K)) .LE. A(K,K)) GO TO 140 S = A(K,K)/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 140 CONTINUE Z(K) = Z(K)/A(K,K) 150 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE R*Z = V C DO 170 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. A(K,K)) GO TO 160 S = A(K,K)/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 160 CONTINUE Z(K) = Z(K)/A(K,K) T = -Z(K) CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) 170 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 180 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/spodi.f0000644060175006010010000001037612562522365015074 0ustar chmNone*DECK SPODI SUBROUTINE SPODI (A, LDA, N, DET, JOB) C***BEGIN PROLOGUE SPODI C***PURPOSE Compute the determinant and inverse of a certain real C symmetric positive definite matrix using the factors C computed by SPOCO, SPOFA or SQRDC. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2B1B, D3B1B C***TYPE SINGLE PRECISION (SPODI-S, DPODI-D, CPODI-C) C***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, C POSITIVE DEFINITE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C SPODI computes the determinant and inverse of a certain C real symmetric positive definite matrix (see below) C using the factors computed by SPOCO, SPOFA or SQRDC. C C On Entry C C A REAL(LDA, N) C the output A from SPOCO or SPOFA C or the output X from SQRDC. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C JOB INTEGER C = 11 both determinant and inverse. C = 01 inverse only. C = 10 determinant only. C C On Return C C A If SPOCO or SPOFA was used to factor A , then C SPODI produces the upper half of INVERSE(A) . C If SQRDC was used to decompose X , then C SPODI produces the upper half of INVERSE(TRANS(X)*X), C where TRANS(X) is the transpose. C Elements of A below the diagonal are unchanged. C If the units digit of JOB is zero, A is unchanged. C C DET REAL(2) C determinant of A or of TRANS(X)*X if requested. C Otherwise not referenced. C Determinant = DET(1) * 10.0**DET(2) C with 1.0 .LE. DET(1) .LT. 10.0 C or DET(1) .EQ. 0.0 . C C Error Condition C C A division by zero will occur if the input factor contains C a zero on the diagonal and the inverse is requested. C It will not occur if the subroutines are called correctly C and if SPOCO or SPOFA has set INFO .EQ. 0 . C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED SAXPY, SSCAL C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SPODI INTEGER LDA,N,JOB REAL A(LDA,*) REAL DET(2) C REAL T REAL S INTEGER I,J,JM1,K,KP1 C***FIRST EXECUTABLE STATEMENT SPODI C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 S = 10.0E0 DO 50 I = 1, N DET(1) = A(I,I)**2*DET(1) IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (DET(1) .GE. 1.0E0) GO TO 20 DET(1) = S*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (DET(1) .LT. S) GO TO 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(R) C IF (MOD(JOB,10) .EQ. 0) GO TO 140 DO 100 K = 1, N A(K,K) = 1.0E0/A(K,K) T = -A(K,K) CALL SSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0E0 CALL SAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(R) * TRANS(INVERSE(R)) C DO 130 J = 1, N JM1 = J - 1 IF (JM1 .LT. 1) GO TO 120 DO 110 K = 1, JM1 T = A(K,J) CALL SAXPY(K,T,A(1,J),1,A(1,K),1) 110 CONTINUE 120 CONTINUE T = A(J,J) CALL SSCAL(J,T,A(1,J),1) 130 CONTINUE 140 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/spofa.f0000644060175006010010000000507312562522365015064 0ustar chmNone*DECK SPOFA SUBROUTINE SPOFA (A, LDA, N, INFO) C***BEGIN PROLOGUE SPOFA C***PURPOSE Factor a real symmetric positive definite matrix. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D2B1B C***TYPE SINGLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C) C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, C POSITIVE DEFINITE C***AUTHOR Moler, C. B., (U. of New Mexico) C***DESCRIPTION C C SPOFA factors a real symmetric positive definite matrix. C C SPOFA is usually called by SPOCO, but it can be called C directly with a saving in time if RCOND is not needed. C (Time for SPOCO) = (1 + 18/N)*(Time for SPOFA) . C C On Entry C C A REAL(LDA, N) C the symmetric matrix to be factored. Only the C diagonal and upper triangle are used. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C On Return C C A an upper triangular matrix R so that A = TRANS(R)*R C where TRANS(R) is the transpose. C The strict lower triangle is unaltered. C If INFO .NE. 0 , the factorization is not complete. C C INFO INTEGER C = 0 for normal return. C = K signals an error condition. The leading minor C of order K is not positive definite. C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED SDOT C***REVISION HISTORY (YYMMDD) C 780814 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SPOFA INTEGER LDA,N,INFO REAL A(LDA,*) C REAL SDOT,T REAL S INTEGER J,JM1,K C***FIRST EXECUTABLE STATEMENT SPOFA DO 30 J = 1, N INFO = J S = 0.0E0 JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 K = 1, JM1 T = A(K,J) - SDOT(K-1,A(1,K),1,A(1,J),1) T = T/A(K,K) A(K,J) = T S = S + T*T 10 CONTINUE 20 CONTINUE S = A(J,J) - S IF (S .LE. 0.0E0) GO TO 40 A(J,J) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/srot.f0000644060175006010010000000573012562522365014743 0ustar chmNone*DECK SROT SUBROUTINE SROT (N, SX, INCX, SY, INCY, SC, SS) C***BEGIN PROLOGUE SROT C***PURPOSE Apply a plane Givens rotation. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A8 C***TYPE SINGLE PRECISION (SROT-S, DROT-D, CSROT-C) C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, C LINEAR ALGEBRA, PLANE ROTATION, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SX single precision vector with N elements C INCX storage spacing between elements of SX C SY single precision vector with N elements C INCY storage spacing between elements of SY C SC element of rotation matrix C SS element of rotation matrix C C --Output-- C SX rotated vector SX (unchanged if N .LE. 0) C SY rotated vector SY (unchanged if N .LE. 0) C C Multiply the 2 x 2 matrix ( SC SS) times the 2 x N matrix (SX**T) C (-SS SC) (SY**T) C where **T indicates transpose. The elements of SX are in C SX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else C LX = 1+(1-N)*INCX, and similarly for SY using LY and INCY. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Corrected definition of LX in DESCRIPTION. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SROT REAL SX, SY, SC, SS, ZERO, ONE, W, Z DIMENSION SX(*), SY(*) SAVE ZERO, ONE DATA ZERO, ONE /0.0E0, 1.0E0/ C***FIRST EXECUTABLE STATEMENT SROT IF (N .LE. 0 .OR. (SS .EQ. ZERO .AND. SC .EQ. ONE)) GO TO 40 IF (.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 C C Code for equal and positive increments. C NSTEPS=INCX*N DO 10 I = 1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=SC*W+SS*Z SY(I)=-SS*W+SC*Z 10 CONTINUE GO TO 40 C C Code for unequal or nonpositive increments. C 20 CONTINUE KX=1 KY=1 C IF (INCX .LT. 0) KX = 1-(N-1)*INCX IF (INCY .LT. 0) KY = 1-(N-1)*INCY C DO 30 I = 1,N W=SX(KX) Z=SY(KY) SX(KX)=SC*W+SS*Z SY(KY)=-SS*W+SC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE C RETURN END PDL-2.018/Lib/Slatec/slatec/srotg.f0000644060175006010010000000555212562522365015114 0ustar chmNone*DECK SROTG SUBROUTINE SROTG (SA, SB, SC, SS) C***BEGIN PROLOGUE SROTG C***PURPOSE Construct a plane Givens rotation. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1B10 C***TYPE SINGLE PRECISION (SROTG-S, DROTG-D, CROTG-C) C***KEYWORDS BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION, C LINEAR ALGEBRA, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C SA single precision scalar C SB single precision scalar C C --Output-- C SA single precision result R C SB single precision result Z C SC single precision result C SS single precision result C C Construct the Givens transformation C C ( SC SS ) C G = ( ) , SC**2 + SS**2 = 1 , C (-SS SC ) C C which zeros the second entry of the 2-vector (SA,SB)**T. C C The quantity R = (+/-)SQRT(SA**2 + SB**2) overwrites SA in C storage. The value of SB is overwritten by a value Z which C allows SC and SS to be recovered by the following algorithm: C C If Z=1 set SC=0.0 and SS=1.0 C If ABS(Z) .LT. 1 set SC=SQRT(1-Z**2) and SS=Z C If ABS(Z) .GT. 1 set SC=1/Z and SS=SQRT(1-SC**2) C C Normally, the subprogram SROT(N,SX,INCX,SY,INCY,SC,SS) will C next be called to apply the transformation to a 2 by N matrix. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SROTG C***FIRST EXECUTABLE STATEMENT SROTG IF (ABS(SA) .LE. ABS(SB)) GO TO 10 C C *** HERE ABS(SA) .GT. ABS(SB) *** C U = SA + SA V = SB / U C C NOTE THAT U AND R HAVE THE SIGN OF SA C R = SQRT(0.25E0 + V**2) * U C C NOTE THAT SC IS POSITIVE C SC = SA / R SS = V * (SC + SC) SB = SS SA = R RETURN C C *** HERE ABS(SA) .LE. ABS(SB) *** C 10 IF (SB .EQ. 0.0E0) GO TO 20 U = SB + SB V = SA / U C C NOTE THAT U AND R HAVE THE SIGN OF SB C (R IS IMMEDIATELY STORED IN SA) C SA = SQRT(0.25E0 + V**2) * U C C NOTE THAT SS IS POSITIVE C SS = SB / SA SC = V * (SS + SS) IF (SC .EQ. 0.0E0) GO TO 15 SB = 1.0E0 / SC RETURN 15 SB = 1.0E0 RETURN C C *** HERE SA = SB = 0.0 *** C 20 SC = 1.0E0 SS = 0.0E0 RETURN C END PDL-2.018/Lib/Slatec/slatec/sscal.f0000644060175006010010000000467112562522365015064 0ustar chmNone*DECK SSCAL SUBROUTINE SSCAL (N, SA, SX, INCX) C***BEGIN PROLOGUE SSCAL C***PURPOSE Multiply a vector by a constant. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A6 C***TYPE SINGLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C) C***KEYWORDS BLAS, LINEAR ALGEBRA, SCALE, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SA single precision scale factor C SX single precision vector with N elements C INCX storage spacing between elements of SX C C --Output-- C SX single precision result (unchanged if N .LE. 0) C C Replace single precision SX by single precision SA*SX. C For I = 0 to N-1, replace SX(IX+I*INCX) with SA * SX(IX+I*INCX), C where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900821 Modified to correct problem with a negative increment. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SSCAL REAL SA, SX(*) INTEGER I, INCX, IX, M, MP1, N C***FIRST EXECUTABLE STATEMENT SSCAL IF (N .LE. 0) RETURN IF (INCX .EQ. 1) GOTO 20 C C Code for increment not equal to 1. C IX = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 DO 10 I = 1,N SX(IX) = SA*SX(IX) IX = IX + INCX 10 CONTINUE RETURN C C Code for increment equal to 1. C C Clean-up loop so remaining vector length is a multiple of 5. C 20 M = MOD(N,5) IF (M .EQ. 0) GOTO 40 DO 30 I = 1,M SX(I) = SA*SX(I) 30 CONTINUE IF (N .LT. 5) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SX(I) = SA*SX(I) SX(I+1) = SA*SX(I+1) SX(I+2) = SA*SX(I+2) SX(I+3) = SA*SX(I+3) SX(I+4) = SA*SX(I+4) 50 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/ssvdc.f0000644060175006010010000003631212562522365015076 0ustar chmNone*DECK SSVDC SUBROUTINE SSVDC (X, LDX, N, P, S, E, U, LDU, V, LDV, WORK, JOB, + INFO) C***BEGIN PROLOGUE SSVDC C***PURPOSE Perform the singular value decomposition of a rectangular C matrix. C***LIBRARY SLATEC (LINPACK) C***CATEGORY D6 C***TYPE SINGLE PRECISION (SSVDC-S, DSVDC-D, CSVDC-C) C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, C SINGULAR VALUE DECOMPOSITION C***AUTHOR Stewart, G. W., (U. of Maryland) C***DESCRIPTION C C SSVDC is a subroutine to reduce a real NxP matrix X by orthogonal C transformations U and V to diagonal form. The elements S(I) are C the singular values of X. The columns of U are the corresponding C left singular vectors, and the columns of V the right singular C vectors. C C On Entry C C X REAL(LDX,P), where LDX .GE. N. C X contains the matrix whose singular value C decomposition is to be computed. X is C destroyed by SSVDC. C C LDX INTEGER C LDX is the leading dimension of the array X. C C N INTEGER C N is the number of rows of the matrix X. C C P INTEGER C P is the number of columns of the matrix X. C C LDU INTEGER C LDU is the leading dimension of the array U. C (See below). C C LDV INTEGER C LDV is the leading dimension of the array V. C (See below). C C WORK REAL(N) C work is a scratch array. C C JOB INTEGER C JOB controls the computation of the singular C vectors. It has the decimal expansion AB C with the following meaning C C A .EQ. 0 Do not compute the left singular C vectors. C A .EQ. 1 Return the N left singular vectors C in U. C A .GE. 2 Return the first MIN(N,P) singular C vectors in U. C B .EQ. 0 Do not compute the right singular C vectors. C B .EQ. 1 Return the right singular vectors C in V. C C On Return C C S REAL(MM), where MM=MIN(N+1,P). C The first MIN(N,P) entries of S contain the C singular values of X arranged in descending C order of magnitude. C C E REAL(P). C E ordinarily contains zeros. However, see the C discussion of INFO for exceptions. C C U REAL(LDU,K), where LDU .GE. N. If JOBA .EQ. 1, then C K .EQ. N. If JOBA .GE. 2 , then C K .EQ. MIN(N,P). C U contains the matrix of right singular vectors. C U is not referenced if JOBA .EQ. 0. If N .LE. P C or if JOBA .EQ. 2, then U may be identified with X C in the subroutine call. C C V REAL(LDV,P), where LDV .GE. P. C V contains the matrix of right singular vectors. C V is not referenced if JOB .EQ. 0. If P .LE. N, C then V may be identified with X in the C subroutine call. C C INFO INTEGER. C the singular values (and their corresponding C singular vectors) S(INFO+1),S(INFO+2),...,S(M) C are correct (here M=MIN(N,P)). Thus if C INFO .EQ. 0, all the singular values and their C vectors are correct. In any event, the matrix C B = TRANS(U)*X*V is the bidiagonal matrix C with the elements of S on its diagonal and the C elements of E on its super-diagonal (TRANS(U) C is the transpose of U). Thus the singular C values of X and B are the same. C C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. C Stewart, LINPACK Users' Guide, SIAM, 1979. C***ROUTINES CALLED SAXPY, SDOT, SNRM2, SROT, SROTG, SSCAL, SSWAP C***REVISION HISTORY (YYMMDD) C 790319 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890531 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900326 Removed duplicate information from DESCRIPTION section. C (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SSVDC INTEGER LDX,N,P,LDU,LDV,JOB,INFO REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) C C INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, 1 MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 REAL SDOT,T REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST, 1 ZTEST LOGICAL WANTU,WANTV C***FIRST EXECUTABLE STATEMENT SSVDC C C SET THE MAXIMUM NUMBER OF ITERATIONS. C MAXIT = 30 C C DETERMINE WHAT IS TO BE COMPUTED. C WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N IF (JOBU .GT. 1) NCU = MIN(N,P) IF (JOBU .NE. 0) WANTU = .TRUE. IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. C C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. C INFO = 0 NCT = MIN(N-1,P) NRT = MAX(0,MIN(P-2,N)) LU = MAX(NCT,NRT) IF (LU .LT. 1) GO TO 170 DO 160 L = 1, LU LP1 = L + 1 IF (L .GT. NCT) GO TO 20 C C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND C PLACE THE L-TH DIAGONAL IN S(L). C S(L) = SNRM2(N-L+1,X(L,L),1) IF (S(L) .EQ. 0.0E0) GO TO 10 IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L)) CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1) X(L,L) = 1.0E0 + X(L,L) 10 CONTINUE S(L) = -S(L) 20 CONTINUE IF (P .LT. LP1) GO TO 50 DO 40 J = LP1, P IF (L .GT. NCT) GO TO 30 IF (S(L) .EQ. 0.0E0) GO TO 30 C C APPLY THE TRANSFORMATION. C T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1) 30 CONTINUE C C PLACE THE L-TH ROW OF X INTO E FOR THE C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. C E(J) = X(L,J) 40 CONTINUE 50 CONTINUE IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 C C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK C MULTIPLICATION. C DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE IF (L .GT. NRT) GO TO 150 C C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE C L-TH SUPER-DIAGONAL IN E(L). C E(L) = SNRM2(P-L,E(LP1),1) IF (E(L) .EQ. 0.0E0) GO TO 80 IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1)) CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1) E(LP1) = 1.0E0 + E(LP1) 80 CONTINUE E(L) = -E(L) IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120 C C APPLY THE TRANSFORMATION. C DO 90 I = LP1, N WORK(I) = 0.0E0 90 CONTINUE DO 100 J = LP1, P CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) 100 CONTINUE DO 110 J = LP1, P CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1) 110 CONTINUE 120 CONTINUE IF (.NOT.WANTV) GO TO 140 C C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT C BACK MULTIPLICATION. C DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE C C SET UP THE FINAL BIDIAGONAL MATRIX OR ORDER M. C M = MIN(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) IF (N .LT. M) S(M) = 0.0E0 IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) E(M) = 0.0E0 C C IF REQUIRED, GENERATE U. C IF (.NOT.WANTU) GO TO 300 IF (NCU .LT. NCTP1) GO TO 200 DO 190 J = NCTP1, NCU DO 180 I = 1, N U(I,J) = 0.0E0 180 CONTINUE U(J,J) = 1.0E0 190 CONTINUE 200 CONTINUE IF (NCT .LT. 1) GO TO 290 DO 280 LL = 1, NCT L = NCT - LL + 1 IF (S(L) .EQ. 0.0E0) GO TO 250 LP1 = L + 1 IF (NCU .LT. LP1) GO TO 220 DO 210 J = LP1, NCU T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1) 210 CONTINUE 220 CONTINUE CALL SSCAL(N-L+1,-1.0E0,U(L,L),1) U(L,L) = 1.0E0 + U(L,L) LM1 = L - 1 IF (LM1 .LT. 1) GO TO 240 DO 230 I = 1, LM1 U(I,L) = 0.0E0 230 CONTINUE 240 CONTINUE GO TO 270 250 CONTINUE DO 260 I = 1, N U(I,L) = 0.0E0 260 CONTINUE U(L,L) = 1.0E0 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE C C IF IT IS REQUIRED, GENERATE V. C IF (.NOT.WANTV) GO TO 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 IF (L .GT. NRT) GO TO 320 IF (E(L) .EQ. 0.0E0) GO TO 320 DO 310 J = LP1, P T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) 310 CONTINUE 320 CONTINUE DO 330 I = 1, P V(I,L) = 0.0E0 330 CONTINUE V(L,L) = 1.0E0 340 CONTINUE 350 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C MM = M ITER = 0 360 CONTINUE C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C IF (M .EQ. 0) GO TO 620 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET C FLAG AND RETURN. C IF (ITER .LT. MAXIT) GO TO 370 INFO = M GO TO 620 370 CONTINUE C C THIS SECTION OF THE PROGRAM INSPECTS FOR C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). C DO 390 LL = 1, M L = M - LL IF (L .EQ. 0) GO TO 400 TEST = ABS(S(L)) + ABS(S(L+1)) ZTEST = TEST + ABS(E(L)) IF (ZTEST .NE. TEST) GO TO 380 E(L) = 0.0E0 GO TO 400 380 CONTINUE 390 CONTINUE 400 CONTINUE IF (L .NE. M - 1) GO TO 410 KASE = 4 GO TO 480 410 CONTINUE LP1 = L + 1 MP1 = M + 1 DO 430 LLS = LP1, MP1 LS = M - LLS + LP1 IF (LS .EQ. L) GO TO 440 TEST = 0.0E0 IF (LS .NE. M) TEST = TEST + ABS(E(LS)) IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1)) ZTEST = TEST + ABS(S(LS)) IF (ZTEST .NE. TEST) GO TO 420 S(LS) = 0.0E0 GO TO 440 420 CONTINUE 430 CONTINUE 440 CONTINUE IF (LS .NE. L) GO TO 450 KASE = 3 GO TO 470 450 CONTINUE IF (LS .NE. M) GO TO 460 KASE = 1 GO TO 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 C C PERFORM THE TASK INDICATED BY KASE. C GO TO (490,520,540,570), KASE C C DEFLATE NEGLIGIBLE S(M). C 490 CONTINUE MM1 = M - 1 F = E(M-1) E(M-1) = 0.0E0 DO 510 KK = L, MM1 K = MM1 - KK + L T1 = S(K) CALL SROTG(T1,F,CS,SN) S(K) = T1 IF (K .EQ. L) GO TO 500 F = -SN*E(K-1) E(K-1) = CS*E(K-1) 500 CONTINUE IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN) 510 CONTINUE GO TO 610 C C SPLIT AT NEGLIGIBLE S(L). C 520 CONTINUE F = E(L-1) E(L-1) = 0.0E0 DO 530 K = L, M T1 = S(K) CALL SROTG(T1,F,CS,SN) S(K) = T1 F = -SN*E(K) E(K) = CS*E(K) IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN) 530 CONTINUE GO TO 610 C C PERFORM ONE QR STEP. C 540 CONTINUE C C CALCULATE THE SHIFT. C SCALE = MAX(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)), 1 ABS(E(L))) SM = S(M)/SCALE SMM1 = S(M-1)/SCALE EMM1 = E(M-1)/SCALE SL = S(L)/SCALE EL = E(L)/SCALE B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0 C = (SM*EMM1)**2 SHIFT = 0.0E0 IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550 SHIFT = SQRT(B**2+C) IF (B .LT. 0.0E0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL C C CHASE ZEROS. C MM1 = M - 1 DO 560 K = L, MM1 CALL SROTG(F,G,CS,SN) IF (K .NE. L) E(K-1) = F F = CS*S(K) + SN*E(K) E(K) = CS*E(K) - SN*S(K) G = SN*S(K+1) S(K+1) = CS*S(K+1) IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN) CALL SROTG(F,G,CS,SN) S(K) = F F = CS*E(K) + SN*S(K+1) S(K+1) = -SN*E(K) + CS*S(K+1) G = SN*E(K+1) E(K+1) = CS*E(K+1) IF (WANTU .AND. K .LT. N) 1 CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN) 560 CONTINUE E(M-1) = F ITER = ITER + 1 GO TO 610 C C CONVERGENCE. C 570 CONTINUE C C MAKE THE SINGULAR VALUE POSITIVE. C IF (S(L) .GE. 0.0E0) GO TO 580 S(L) = -S(L) IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1) 580 CONTINUE C C ORDER THE SINGULAR VALUE. C 590 IF (L .EQ. MM) GO TO 600 IF (S(L) .GE. S(L+1)) GO TO 600 T = S(L) S(L) = S(L+1) S(L+1) = T IF (WANTV .AND. L .LT. P) 1 CALL SSWAP(P,V(1,L),1,V(1,L+1),1) IF (WANTU .AND. L .LT. N) 1 CALL SSWAP(N,U(1,L),1,U(1,L+1),1) L = L + 1 GO TO 590 600 CONTINUE ITER = 0 M = M - 1 610 CONTINUE GO TO 360 620 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/sswap.f0000644060175006010010000000603612562522365015111 0ustar chmNone*DECK SSWAP SUBROUTINE SSWAP (N, SX, INCX, SY, INCY) C***BEGIN PROLOGUE SSWAP C***PURPOSE Interchange two vectors. C***LIBRARY SLATEC (BLAS) C***CATEGORY D1A5 C***TYPE SINGLE PRECISION (SSWAP-S, DSWAP-D, CSWAP-C, ISWAP-I) C***KEYWORDS BLAS, INTERCHANGE, LINEAR ALGEBRA, VECTOR C***AUTHOR Lawson, C. L., (JPL) C Hanson, R. J., (SNLA) C Kincaid, D. R., (U. of Texas) C Krogh, F. T., (JPL) C***DESCRIPTION C C B L A S Subprogram C Description of Parameters C C --Input-- C N number of elements in input vector(s) C SX single precision vector with N elements C INCX storage spacing between elements of SX C SY single precision vector with N elements C INCY storage spacing between elements of SY C C --Output-- C SX input vector SY (unchanged if N .LE. 0) C SY input vector SX (unchanged if N .LE. 0) C C Interchange single precision SX and single precision SY. C For I = 0 to N-1, interchange SX(LX+I*INCX) and SY(LY+I*INCY), C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is C defined in a similar way using INCY. C C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. C Krogh, Basic linear algebra subprograms for Fortran C usage, Algorithm No. 539, Transactions on Mathematical C Software 5, 3 (September 1979), pp. 308-323. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791001 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920310 Corrected definition of LX in DESCRIPTION. (WRB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE SSWAP REAL SX(*), SY(*), STEMP1, STEMP2, STEMP3 C***FIRST EXECUTABLE STATEMENT SSWAP IF (N .LE. 0) RETURN IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60 C C Code for unequal or nonpositive increments. C 5 IX = 1 IY = 1 IF (INCX .LT. 0) IX = (-N+1)*INCX + 1 IF (INCY .LT. 0) IY = (-N+1)*INCY + 1 DO 10 I = 1,N STEMP1 = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C Code for both increments equal to 1. C C Clean-up loop so remaining vector length is a multiple of 3. C 20 M = MOD(N,3) IF (M .EQ. 0) GO TO 40 DO 30 I = 1,M STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 30 CONTINUE IF (N .LT. 3) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 STEMP1 = SX(I) STEMP2 = SX(I+1) STEMP3 = SX(I+2) SX(I) = SY(I) SX(I+1) = SY(I+1) SX(I+2) = SY(I+2) SY(I) = STEMP1 SY(I+1) = STEMP2 SY(I+2) = STEMP3 50 CONTINUE RETURN C C Code for equal, positive, non-unit increments. C 60 NS = N*INCX DO 70 I = 1,NS,INCX STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 70 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec/tql2.f0000644060175006010010000001431012562522365014630 0ustar chmNone*DECK TQL2 SUBROUTINE TQL2 (NM, N, D, E, Z, IERR) C***BEGIN PROLOGUE TQL2 C***PURPOSE Compute the eigenvalues and eigenvectors of symmetric C tridiagonal matrix. C***LIBRARY SLATEC (EISPACK) C***CATEGORY D4A5, D4C2A C***TYPE SINGLE PRECISION (TQL2-S) C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK C***AUTHOR Smith, B. T., et al. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure TQL2, C NUM. MATH. 11, 293-306(1968) by Bowdler, Martin, Reinsch, and C Wilkinson. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). C C This subroutine finds the eigenvalues and eigenvectors C of a SYMMETRIC TRIDIAGONAL matrix by the QL method. C The eigenvectors of a FULL SYMMETRIC matrix can also C be found if TRED2 has been used to reduce this C full matrix to tridiagonal form. C C On Input C C NM must be set to the row dimension of the two-dimensional C array parameter, Z, as declared in the calling program C dimension statement. NM is an INTEGER variable. C C N is the order of the matrix. N is an INTEGER variable. C N must be less than or equal to NM. C C D contains the diagonal elements of the symmetric tridiagonal C matrix. D is a one-dimensional REAL array, dimensioned D(N). C C E contains the subdiagonal elements of the symmetric C tridiagonal matrix in its last N-1 positions. E(1) is C arbitrary. E is a one-dimensional REAL array, dimensioned C E(N). C C Z contains the transformation matrix produced in the C reduction by TRED2, if performed. If the eigenvectors C of the tridiagonal matrix are desired, Z must contain C the identity matrix. Z is a two-dimensional REAL array, C dimensioned Z(NM,N). C C On Output C C D contains the eigenvalues in ascending order. If an C error exit is made, the eigenvalues are correct but C unordered for indices 1, 2, ..., IERR-1. C C E has been destroyed. C C Z contains orthonormal eigenvectors of the symmetric C tridiagonal (or full) matrix. If an error exit is made, C Z contains the eigenvectors associated with the stored C eigenvalues. C C IERR is an INTEGER flag set to C Zero for normal return, C J if the J-th eigenvalue has not been C determined after 30 iterations. C C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- C system Routines - EISPACK Guide, Springer-Verlag, C 1976. C***ROUTINES CALLED PYTHAG C***REVISION HISTORY (YYMMDD) C 760101 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE TQL2 C INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR REAL D(*),E(*),Z(NM,*) REAL B,C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2 REAL PYTHAG C C***FIRST EXECUTABLE STATEMENT TQL2 IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C F = 0.0E0 B = 0.0E0 E(N) = 0.0E0 C DO 240 L = 1, N J = 0 H = ABS(D(L)) + ABS(E(L)) IF (B .LT. H) B = H C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... DO 110 M = L, N IF (B + ABS(E(M)) .EQ. B) GO TO 120 C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP .......... 110 CONTINUE C 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 C .......... FORM SHIFT .......... L1 = L + 1 L2 = L1 + 1 G = D(L) P = (D(L1) - G) / (2.0E0 * E(L)) R = PYTHAG(P,1.0E0) D(L) = E(L) / (P + SIGN(R,P)) D(L1) = E(L) * (P + SIGN(R,P)) DL1 = D(L1) H = G - D(L) IF (L2 .GT. N) GO TO 145 C DO 140 I = L2, N 140 D(I) = D(I) - H C 145 F = F + H C .......... QL TRANSFORMATION .......... P = D(M) C = 1.0E0 C2 = C EL1 = E(L1) S = 0.0E0 MML = M - L C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML C3 = C2 C2 = C S2 = S I = M - II G = C * E(I) H = C * P IF (ABS(P) .LT. ABS(E(I))) GO TO 150 C = E(I) / P R = SQRT(C*C+1.0E0) E(I+1) = S * P * R S = C / R C = 1.0E0 / R GO TO 160 150 C = P / E(I) R = SQRT(C*C+1.0E0) E(I+1) = S * E(I) * R S = 1.0E0 / R C = C * S 160 P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) C .......... FORM VECTOR .......... DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE C 200 CONTINUE C P = -S * S2 * C3 * EL1 * E(L) / DL1 E(L) = S * P D(L) = C * P IF (B + ABS(E(L)) .GT. B) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN END PDL-2.018/Lib/Slatec/slatec/tqlrat.f0000644060175006010010000001206712562522365015264 0ustar chmNone*DECK TQLRAT SUBROUTINE TQLRAT (N, D, E2, IERR) C***BEGIN PROLOGUE TQLRAT C***PURPOSE Compute the eigenvalues of symmetric tridiagonal matrix C using a rational variant of the QL method. C***LIBRARY SLATEC (EISPACK) C***CATEGORY D4A5, D4C2A C***TYPE SINGLE PRECISION (TQLRAT-S) C***KEYWORDS EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX, EISPACK, C QL METHOD C***AUTHOR Smith, B. T., et al. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure TQLRAT. C C This subroutine finds the eigenvalues of a SYMMETRIC C TRIDIAGONAL matrix by the rational QL method. C C On Input C C N is the order of the matrix. N is an INTEGER variable. C C D contains the diagonal elements of the symmetric tridiagonal C matrix. D is a one-dimensional REAL array, dimensioned D(N). C C E2 contains the squares of the subdiagonal elements of the C symmetric tridiagonal matrix in its last N-1 positions. C E2(1) is arbitrary. E2 is a one-dimensional REAL array, C dimensioned E2(N). C C On Output C C D contains the eigenvalues in ascending order. If an C error exit is made, the eigenvalues are correct and C ordered for indices 1, 2, ..., IERR-1, but may not be C the smallest eigenvalues. C C E2 has been destroyed. C C IERR is an INTEGER flag set to C Zero for normal return, C J if the J-th eigenvalue has not been C determined after 30 iterations. C C Calls PYTHAG(A,B) for sqrt(A**2 + B**2). C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- C system Routines - EISPACK Guide, Springer-Verlag, C 1976. C C. H. Reinsch, Eigenvalues of a real, symmetric, tri- C diagonal matrix, Algorithm 464, Communications of the C ACM 16, 11 (November 1973), pp. 689. C***ROUTINES CALLED PYTHAG, R1MACH C***REVISION HISTORY (YYMMDD) C 760101 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE TQLRAT C INTEGER I,J,L,M,N,II,L1,MML,IERR REAL D(*),E2(*) REAL B,C,F,G,H,P,R,S,MACHEP REAL PYTHAG LOGICAL FIRST C SAVE FIRST, MACHEP DATA FIRST /.TRUE./ C***FIRST EXECUTABLE STATEMENT TQLRAT IF (FIRST) THEN MACHEP = R1MACH(4) ENDIF FIRST = .FALSE. C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E2(I-1) = E2(I) C F = 0.0E0 B = 0.0E0 E2(N) = 0.0E0 C DO 290 L = 1, N J = 0 H = MACHEP * (ABS(D(L)) + SQRT(E2(L))) IF (B .GT. H) GO TO 105 B = H C = B * B C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... 105 DO 110 M = L, N IF (E2(M) .LE. C) GO TO 120 C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP .......... 110 CONTINUE C 120 IF (M .EQ. L) GO TO 210 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 C .......... FORM SHIFT .......... L1 = L + 1 S = SQRT(E2(L)) G = D(L) P = (D(L1) - G) / (2.0E0 * S) R = PYTHAG(P,1.0E0) D(L) = S / (P + SIGN(R,P)) H = G - D(L) C DO 140 I = L1, N 140 D(I) = D(I) - H C F = F + H C .......... RATIONAL QL TRANSFORMATION .......... G = D(M) IF (G .EQ. 0.0E0) G = B H = G S = 0.0E0 MML = M - L C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... DO 200 II = 1, MML I = M - II P = G * H R = P + E2(I) E2(I+1) = S * R S = E2(I) / R D(I+1) = H + S * (H + D(I)) G = D(I) - E2(I) / G IF (G .EQ. 0.0E0) G = B H = G * P / R 200 CONTINUE C E2(L) = S * G D(L) = H C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... IF (H .EQ. 0.0E0) GO TO 210 IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 E2(L) = H * E2(L) IF (E2(L) .NE. 0.0E0) GO TO 130 210 P = D(L) + F C .......... ORDER EIGENVALUES .......... IF (L .EQ. 1) GO TO 250 C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... DO 230 II = 2, L I = L + 2 - II IF (P .GE. D(I-1)) GO TO 270 D(I) = D(I-1) 230 CONTINUE C 250 I = 1 270 D(I) = P 290 CONTINUE C GO TO 1001 C .......... SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS .......... 1000 IERR = L 1001 RETURN END PDL-2.018/Lib/Slatec/slatec/tred1.f0000644060175006010010000001077612562522365015001 0ustar chmNone*DECK TRED1 SUBROUTINE TRED1 (NM, N, A, D, E, E2) C***BEGIN PROLOGUE TRED1 C***PURPOSE Reduce a real symmetric matrix to symmetric tridiagonal C matrix using orthogonal similarity transformations. C***LIBRARY SLATEC (EISPACK) C***CATEGORY D4C1B1 C***TYPE SINGLE PRECISION (TRED1-S) C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK C***AUTHOR Smith, B. T., et al. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure TRED1, C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C This subroutine reduces a REAL SYMMETRIC matrix C to a symmetric tridiagonal matrix using C orthogonal similarity transformations. C C On Input C C NM must be set to the row dimension of the two-dimensional C array parameter, A, as declared in the calling program C dimension statement. NM is an INTEGER variable. C C N is the order of the matrix A. N is an INTEGER variable. C N must be less than or equal to NM. C C A contains the real symmetric input matrix. Only the lower C triangle of the matrix need be supplied. A is a two- C dimensional REAL array, dimensioned A(NM,N). C C On Output C C A contains information about the orthogonal transformations C used in the reduction in its strict lower triangle. The C full upper triangle of A is unaltered. C C D contains the diagonal elements of the symmetric tridiagonal C matrix. D is a one-dimensional REAL array, dimensioned D(N). C C E contains the subdiagonal elements of the symmetric C tridiagonal matrix in its last N-1 positions. E(1) is set C to zero. E is a one-dimensional REAL array, dimensioned C E(N). C C E2 contains the squares of the corresponding elements of E. C E2 may coincide with E if the squares are not needed. C E2 is a one-dimensional REAL array, dimensioned E2(N). C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- C system Routines - EISPACK Guide, Springer-Verlag, C 1976. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 760101 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE TRED1 C INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,*),D(*),E(*),E2(*) REAL F,G,H,SCALE C C***FIRST EXECUTABLE STATEMENT TRED1 DO 100 I = 1, N 100 D(I) = A(I,I) C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 IF (L .LT. 1) GO TO 130 C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... DO 120 K = 1, L 120 SCALE = SCALE + ABS(A(I,K)) C IF (SCALE .NE. 0.0E0) GO TO 140 130 E(I) = 0.0E0 E2(I) = 0.0E0 GO TO 290 C 140 DO 150 K = 1, L A(I,K) = A(I,K) / SCALE H = H + A(I,K) * A(I,K) 150 CONTINUE C E2(I) = SCALE * SCALE * H F = A(I,L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G A(I,L) = F - G IF (L .EQ. 1) GO TO 270 F = 0.0E0 C DO 240 J = 1, L G = 0.0E0 C .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, J 180 G = G + A(J,K) * A(I,K) C JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L 200 G = G + A(K,J) * A(I,K) C .......... FORM ELEMENT OF P .......... 220 E(J) = G / H F = F + E(J) * A(I,J) 240 CONTINUE C H = F / (H + H) C .......... FORM REDUCED A .......... DO 260 J = 1, L F = A(I,J) G = E(J) - H * F E(J) = G C DO 260 K = 1, J A(J,K) = A(J,K) - F * E(K) - G * A(I,K) 260 CONTINUE C 270 DO 280 K = 1, L 280 A(I,K) = SCALE * A(I,K) C 290 H = D(I) D(I) = A(I,I) A(I,I) = H 300 CONTINUE C RETURN END PDL-2.018/Lib/Slatec/slatec/tred2.f0000644060175006010010000001160412562522365014771 0ustar chmNone*DECK TRED2 SUBROUTINE TRED2 (NM, N, A, D, E, Z) C***BEGIN PROLOGUE TRED2 C***PURPOSE Reduce a real symmetric matrix to a symmetric tridiagonal C matrix using and accumulating orthogonal transformations. C***LIBRARY SLATEC (EISPACK) C***CATEGORY D4C1B1 C***TYPE SINGLE PRECISION (TRED2-S) C***KEYWORDS EIGENVALUES, EIGENVECTORS, EISPACK C***AUTHOR Smith, B. T., et al. C***DESCRIPTION C C This subroutine is a translation of the ALGOL procedure TRED2, C NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C This subroutine reduces a REAL SYMMETRIC matrix to a C symmetric tridiagonal matrix using and accumulating C orthogonal similarity transformations. C C On Input C C NM must be set to the row dimension of the two-dimensional C array parameters, A and Z, as declared in the calling C program dimension statement. NM is an INTEGER variable. C C N is the order of the matrix A. N is an INTEGER variable. C N must be less than or equal to NM. C C A contains the real symmetric input matrix. Only the lower C triangle of the matrix need be supplied. A is a two- C dimensional REAL array, dimensioned A(NM,N). C C On Output C C D contains the diagonal elements of the symmetric tridiagonal C matrix. D is a one-dimensional REAL array, dimensioned D(N). C C E contains the subdiagonal elements of the symmetric C tridiagonal matrix in its last N-1 positions. E(1) is set C to zero. E is a one-dimensional REAL array, dimensioned C E(N). C C Z contains the orthogonal transformation matrix produced in C the reduction. Z is a two-dimensional REAL array, C dimensioned Z(NM,N). C C A and Z may coincide. If distinct, A is unaltered. C C Questions and comments should be directed to B. S. Garbow, C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY C ------------------------------------------------------------------ C C***REFERENCES B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow, C Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen- C system Routines - EISPACK Guide, Springer-Verlag, C 1976. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 760101 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890831 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE TRED2 C INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,*),D(*),E(*),Z(NM,*) REAL F,G,H,HH,SCALE C C***FIRST EXECUTABLE STATEMENT TRED2 DO 100 I = 1, N C DO 100 J = 1, I Z(I,J) = A(I,J) 100 CONTINUE C IF (N .EQ. 1) GO TO 320 C .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... DO 300 II = 2, N I = N + 2 - II L = I - 1 H = 0.0E0 SCALE = 0.0E0 IF (L .LT. 2) GO TO 130 C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... DO 120 K = 1, L 120 SCALE = SCALE + ABS(Z(I,K)) C IF (SCALE .NE. 0.0E0) GO TO 140 130 E(I) = Z(I,L) GO TO 290 C 140 DO 150 K = 1, L Z(I,K) = Z(I,K) / SCALE H = H + Z(I,K) * Z(I,K) 150 CONTINUE C F = Z(I,L) G = -SIGN(SQRT(H),F) E(I) = SCALE * G H = H - F * G Z(I,L) = F - G F = 0.0E0 C DO 240 J = 1, L Z(J,I) = Z(I,J) / H G = 0.0E0 C .......... FORM ELEMENT OF A*U .......... DO 180 K = 1, J 180 G = G + Z(J,K) * Z(I,K) C JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L 200 G = G + Z(K,J) * Z(I,K) C .......... FORM ELEMENT OF P .......... 220 E(J) = G / H F = F + E(J) * Z(I,J) 240 CONTINUE C HH = F / (H + H) C .......... FORM REDUCED A .......... DO 260 J = 1, L F = Z(I,J) G = E(J) - HH * F E(J) = G C DO 260 K = 1, J Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) 260 CONTINUE C 290 D(I) = H 300 CONTINUE C 320 D(1) = 0.0E0 E(1) = 0.0E0 C .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... DO 500 I = 1, N L = I - 1 IF (D(I) .EQ. 0.0E0) GO TO 380 C DO 360 J = 1, L G = 0.0E0 C DO 340 K = 1, L 340 G = G + Z(I,K) * Z(K,J) C DO 360 K = 1, L Z(K,J) = Z(K,J) - G * Z(K,I) 360 CONTINUE C 380 D(I) = Z(I,I) Z(I,I) = 1.0E0 IF (L .LT. 1) GO TO 500 C DO 400 J = 1, L Z(I,J) = 0.0E0 Z(J,I) = 0.0E0 400 CONTINUE C 500 CONTINUE C RETURN END PDL-2.018/Lib/Slatec/slatec/xerbla.f0000644060175006010010000000264712562522365015235 0ustar chmNone*DECK XERBLA SUBROUTINE XERBLA (SRNAME, INFO) C***BEGIN PROLOGUE XERBLA C***SUBSIDIARY C***PURPOSE Error handler for the Level 2 and Level 3 BLAS Routines. C***LIBRARY SLATEC C***CATEGORY R3 C***TYPE ALL (XERBLA-A) C***KEYWORDS ERROR MESSAGE C***AUTHOR Dongarra, J. J., (ANL) C***DESCRIPTION C C Purpose C ======= C C It is called by Level 2 and 3 BLAS routines if an input parameter C is invalid. C C Parameters C ========== C C SRNAME - CHARACTER*6. C On entry, SRNAME specifies the name of the routine which C called XERBLA. C C INFO - INTEGER. C On entry, INFO specifies the position of the invalid C parameter in the parameter-list of the calling routine. C C***REFERENCES (NONE) C***ROUTINES CALLED XERMSG C***REVISION HISTORY (YYMMDD) C 860720 DATE WRITTEN C 910610 Routine rewritten to serve as an interface between the C Level 2 and Level 3 BLAS routines and the SLATEC error C handler XERMSG. (BKS) C***END PROLOGUE XERBLA C C .. Scalar Arguments .. INTEGER INFO CHARACTER*6 SRNAME CHARACTER*2 XERN1 C C***FIRST EXECUTABLE STATEMENT XERBLA C WRITE (XERN1, '(I2)') INFO CALL XERMSG ('SLATEC', SRNAME, 'On entry to '//SRNAME// $ ' parameter number '//XERN1//' had an illegal value', $ INFO,1) C RETURN C C End of XERBLA. C END PDL-2.018/Lib/Slatec/slatec/xercnt.f0000644060175006010010000000476112562522365015262 0ustar chmNone*DECK XERCNT SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) C***BEGIN PROLOGUE XERCNT C***SUBSIDIARY C***PURPOSE Allow user control over handling of errors. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERCNT-A) C***KEYWORDS ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C Allows user control over handling of individual errors. C Just after each message is recorded, but before it is C processed any further (i.e., before it is printed or C a decision to abort is made), a call is made to XERCNT. C If the user has provided his own version of XERCNT, he C can then override the value of KONTROL used in processing C this message by redefining its value. C KONTRL may be set to any value from -2 to 2. C The meanings for KONTRL are the same as in XSETF, except C that the value of KONTRL changes only for this message. C If KONTRL is set to a value outside the range from -2 to 2, C it will be moved back into that range. C C Description of Parameters C C --Input-- C LIBRAR - the library that the routine is in. C SUBROU - the subroutine that XERMSG is being called from C MESSG - the first 20 characters of the error message. C NERR - same as in the call to XERMSG. C LEVEL - same as in the call to XERMSG. C KONTRL - the current value of the control flag as set C by a call to XSETF. C C --Output-- C KONTRL - the new value of KONTRL. If KONTRL is not C defined, it will remain at its original value. C This changed value of control affects only C the current occurrence of the current message. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900206 Routine changed from user-callable to subsidiary. (WRB) C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE C names, changed routine name from XERCTL to XERCNT. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERCNT CHARACTER*(*) LIBRAR, SUBROU, MESSG C***FIRST EXECUTABLE STATEMENT XERCNT RETURN END PDL-2.018/Lib/Slatec/slatec/xerhlt.f0000644060175006010010000000257412562522365015265 0ustar chmNone*DECK XERHLT SUBROUTINE XERHLT (MESSG) C***BEGIN PROLOGUE XERHLT C***SUBSIDIARY C***PURPOSE Abort program execution and print error message. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERHLT-A) C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C ***Note*** machine dependent routine C XERHLT aborts the execution of the program. C The error message causing the abort is given in the calling C sequence, in case one needs it for printing on a dayfile, C for example. C C Description of Parameters C MESSG is as in XERMSG. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900206 Routine changed from user-callable to subsidiary. (WRB) C 900510 Changed calling sequence to delete length of character C and changed routine name from XERABT to XERHLT. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERHLT CHARACTER*(*) MESSG C***FIRST EXECUTABLE STATEMENT XERHLT CALL SLATECBARF END PDL-2.018/Lib/Slatec/slatec/xermsg.f0000644060175006010010000004035312562522365015261 0ustar chmNone*DECK XERMSG SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) C***BEGIN PROLOGUE XERMSG C***PURPOSE Process error messages for SLATEC and other libraries. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERMSG-A) C***KEYWORDS ERROR MESSAGE, XERROR C***AUTHOR Fong, Kirby, (NMFECC at LLNL) C***DESCRIPTION C C XERMSG processes a diagnostic message in a manner determined by the C value of LEVEL and the current value of the library error control C flag, KONTRL. See subroutine XSETF for details. C C LIBRAR A character constant (or character variable) with the name C of the library. This will be 'SLATEC' for the SLATEC C Common Math Library. The error handling package is C general enough to be used by many libraries C simultaneously, so it is desirable for the routine that C detects and reports an error to identify the library name C as well as the routine name. C C SUBROU A character constant (or character variable) with the name C of the routine that detected the error. Usually it is the C name of the routine that is calling XERMSG. There are C some instances where a user callable library routine calls C lower level subsidiary routines where the error is C detected. In such cases it may be more informative to C supply the name of the routine the user called rather than C the name of the subsidiary routine that detected the C error. C C MESSG A character constant (or character variable) with the text C of the error or warning message. In the example below, C the message is a character constant that contains a C generic message. C C CALL XERMSG ('SLATEC', 'MMPY', C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', C *3, 1) C C It is possible (and is sometimes desirable) to generate a C specific message--e.g., one that contains actual numeric C values. Specific numeric values can be converted into C character strings using formatted WRITE statements into C character variables. This is called standard Fortran C internal file I/O and is exemplified in the first three C lines of the following example. You can also catenate C substrings of characters to construct the error message. C Here is an example showing the use of both writing to C an internal file and catenating character strings. C C CHARACTER*5 CHARN, CHARL C WRITE (CHARN,10) N C WRITE (CHARL,10) LDA C 10 FORMAT(I5) C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// C * CHARL, 3, 1) C C There are two subtleties worth mentioning. One is that C the // for character catenation is used to construct the C error message so that no single character constant is C continued to the next line. This avoids confusion as to C whether there are trailing blanks at the end of the line. C The second is that by catenating the parts of the message C as an actual argument rather than encoding the entire C message into one large character variable, we avoid C having to know how long the message will be in order to C declare an adequate length for that large character C variable. XERMSG calls XERPRN to print the message using C multiple lines if necessary. If the message is very long, C XERPRN will break it into pieces of 72 characters (as C requested by XERMSG) for printing on multiple lines. C Also, XERMSG asks XERPRN to prefix each line with ' * ' C so that the total line length could be 76 characters. C Note also that XERPRN scans the error message backwards C to ignore trailing blanks. Another feature is that C the substring '$$' is treated as a new line sentinel C by XERPRN. If you want to construct a multiline C message without having to count out multiples of 72 C characters, just use '$$' as a separator. '$$' C obviously must occur within 72 characters of the C start of each line to have its intended effect since C XERPRN is asked to wrap around at 72 characters in C addition to looking for '$$'. C C NERR An integer value that is chosen by the library routine's C author. It must be in the range -99 to 999 (three C printable digits). Each distinct error should have its C own error number. These error numbers should be described C in the machine readable documentation for the routine. C The error numbers need be unique only within each routine, C so it is reasonable for each routine to start enumerating C errors from 1 and proceeding to the next integer. C C LEVEL An integer value in the range 0 to 2 that indicates the C level (severity) of the error. Their meanings are C C -1 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. An attempt is made to only print this C message once. C C 0 A warning message. This is used if it is not clear C that there really is an error, but the user's attention C may be needed. C C 1 A recoverable error. This is used even if the error is C so serious that the routine cannot return any useful C answer. If the user has told the error package to C return after recoverable errors, then XERMSG will C return to the Library routine which can then return to C the user's routine. The user may also permit the error C package to terminate the program upon encountering a C recoverable error. C C 2 A fatal error. XERMSG will not return to its caller C after it receives a fatal error. This level should C hardly ever be used; it is much better to allow the C user a chance to recover. An example of one of the few C cases in which it is permissible to declare a level 2 C error is a reverse communication Library routine that C is likely to be called repeatedly until it integrates C across some interval. If there is a serious error in C the input such that another step cannot be taken and C the Library routine is called again without the input C error having been corrected by the caller, the Library C routine will probably be called forever with improper C input. In this case, it is reasonable to declare the C error to be fatal. C C Each of the arguments to XERMSG is input; none will be modified by C XERMSG. A routine may make multiple calls to XERMSG with warning C level messages; however, after a call to XERMSG with a recoverable C error, the routine should return to the user. Do not try to call C XERMSG with a second recoverable error after the first recoverable C error because the error package saves the error number. The user C can retrieve this error number by calling another entry point in C the error handling package and then clear the error number when C recovering from the error. Calling XERMSG in succession causes the C old error number to be overwritten by the latest error number. C This is considered harmless for error numbers associated with C warning messages but must not be done for error numbers of serious C errors. After a call to XERMSG with a recoverable error, the user C must be given a chance to call NUMXER or XERCLR to retrieve or C clear the error number. C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE C***REVISION HISTORY (YYMMDD) C 880101 DATE WRITTEN C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. C THERE ARE TWO BASIC CHANGES. C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE C OF LOWER CASE. C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. C THE PRINCIPAL CHANGES ARE C 1. CLARIFY COMMENTS IN THE PROLOGUES C 2. RENAME XRPRNT TO XERPRN C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / C CHARACTER FOR NEW RECORDS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO C CLEAN UP THE CODING. C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN C PREFIX. C 891013 REVISED TO CORRECT COMMENTS. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and C XERCTL to XERCNT. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERMSG CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*8 XLIBR, XSUBR CHARACTER*72 TEMP CHARACTER*20 LFIRST C***FIRST EXECUTABLE STATEMENT XERMSG LKNTRL = J4SAVE (2, 0, .FALSE.) MAXMES = J4SAVE (4, 0, .FALSE.) C C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE C SHOULD BE PRINTED. C C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. C IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// * 'JOB ABORT DUE TO FATAL ERROR.', 72) CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) CALL XERHLT (' ***XERMSG -- INVALID INPUT') RETURN ENDIF C C RECORD THE MESSAGE. C I = J4SAVE (1, NERR, .TRUE.) CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) C C HANDLE PRINT-ONCE WARNING MESSAGES. C IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN C C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. C XLIBR = LIBRAR XSUBR = SUBROU LFIRST = MESSG LERR = NERR LLEVEL = LEVEL CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) C LKNTRL = MAX(-2, MIN(2,LKNTRL)) MKNTRL = ABS(LKNTRL) C C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS C ZERO AND THE ERROR IS NOT FATAL. C IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 C C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG C IS NOT ZERO. C IF (LKNTRL .NE. 0) THEN TEMP(1:21) = 'MESSAGE FROM ROUTINE ' I = MIN(LEN(SUBROU), 16) TEMP(22:21+I) = SUBROU(1:I) TEMP(22+I:33+I) = ' IN LIBRARY ' LTEMP = 33 + I I = MIN(LEN(LIBRAR), 16) TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) TEMP(LTEMP+I+1:LTEMP+I+1) = '.' LTEMP = LTEMP + I + 1 CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE C FROM EACH OF THE FOLLOWING THREE OPTIONS. C 1. LEVEL OF THE MESSAGE C 'INFORMATIVE MESSAGE' C 'POTENTIALLY RECOVERABLE ERROR' C 'FATAL ERROR' C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE C 'PROG CONTINUES' C 'PROG ABORTED' C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) C 'TRACEBACK REQUESTED' C 'TRACEBACK NOT REQUESTED' C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT C EXCEED 74 CHARACTERS. C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. C IF (LKNTRL .GT. 0) THEN C C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. C IF (LEVEL .LE. 0) THEN TEMP(1:20) = 'INFORMATIVE MESSAGE,' LTEMP = 20 ELSEIF (LEVEL .EQ. 1) THEN TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' LTEMP = 30 ELSE TEMP(1:12) = 'FATAL ERROR,' LTEMP = 12 ENDIF C C THEN WHETHER THE PROGRAM WILL CONTINUE. C IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' LTEMP = LTEMP + 14 ELSE TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' LTEMP = LTEMP + 16 ENDIF C C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. C IF (LKNTRL .GT. 0) THEN TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' LTEMP = LTEMP + 20 ELSE TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' LTEMP = LTEMP + 24 ENDIF CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) ENDIF C C NOW SEND OUT THE MESSAGE. C CALL XERPRN (' * ', -1, MESSG, 72) C C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A C TRACEBACK. C IF (LKNTRL .GT. 0) THEN WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR DO 10 I=16,22 IF (TEMP(I:I) .NE. ' ') GO TO 20 10 CONTINUE C 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) CALL FDUMP ENDIF C C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. C IF (LKNTRL .NE. 0) THEN CALL XERPRN (' * ', -1, ' ', 72) CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) CALL XERPRN (' ', 0, ' ', 72) ENDIF C C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. C 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN C C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. C IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN IF (LEVEL .EQ. 1) THEN CALL XERPRN * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) ELSE CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) ENDIF CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) CALL XERHLT (' ') ELSE CALL XERHLT (MESSG) ENDIF RETURN END PDL-2.018/Lib/Slatec/slatec/xerprn.f0000644060175006010010000002162212562522365015270 0ustar chmNone*DECK XERPRN SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) C***BEGIN PROLOGUE XERPRN C***SUBSIDIARY C***PURPOSE Print error messages processed by XERMSG. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XERPRN-A) C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR C***AUTHOR Fong, Kirby, (NMFECC at LLNL) C***DESCRIPTION C C This routine sends one or more lines to each of the (up to five) C logical units to which error messages are to be sent. This routine C is called several times by XERMSG, sometimes with a single line to C print and sometimes with a (potentially very long) message that may C wrap around into multiple lines. C C PREFIX Input argument of type CHARACTER. This argument contains C characters to be put at the beginning of each line before C the body of the message. No more than 16 characters of C PREFIX will be used. C C NPREF Input argument of type INTEGER. This argument is the number C of characters to use from PREFIX. If it is negative, the C intrinsic function LEN is used to determine its length. If C it is zero, PREFIX is not used. If it exceeds 16 or if C LEN(PREFIX) exceeds 16, only the first 16 characters will be C used. If NPREF is positive and the length of PREFIX is less C than NPREF, a copy of PREFIX extended with blanks to length C NPREF will be used. C C MESSG Input argument of type CHARACTER. This is the text of a C message to be printed. If it is a long message, it will be C broken into pieces for printing on multiple lines. Each line C will start with the appropriate prefix and be followed by a C piece of the message. NWRAP is the number of characters per C piece; that is, after each NWRAP characters, we break and C start a new line. In addition the characters '$$' embedded C in MESSG are a sentinel for a new line. The counting of C characters up to NWRAP starts over for each new line. The C value of NWRAP typically used by XERMSG is 72 since many C older error messages in the SLATEC Library are laid out to C rely on wrap-around every 72 characters. C C NWRAP Input argument of type INTEGER. This gives the maximum size C piece into which to break MESSG for printing on multiple C lines. An embedded '$$' ends a line, and the count restarts C at the following character. If a line break does not occur C on a blank (it would split a word) that word is moved to the C next line. Values of NWRAP less than 16 will be treated as C 16. Values of NWRAP greater than 132 will be treated as 132. C The actual line length will be NPREF + NWRAP after NPREF has C been adjusted to fall between 0 and 16 and NWRAP has been C adjusted to fall between 16 and 132. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED I1MACH, XGETUA C***REVISION HISTORY (YYMMDD) C 880621 DATE WRITTEN C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE C SLASH CHARACTER IN FORMAT STATEMENTS. C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK C LINES TO BE PRINTED. C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. C 891214 Prologue converted to Version 4.0 format. (WRB) C 900510 Added code to break messages between words. (RWC) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERPRN CHARACTER*(*) PREFIX, MESSG INTEGER NPREF, NWRAP CHARACTER*148 CBUFF INTEGER IU(5), NUNIT CHARACTER*2 NEWLIN PARAMETER (NEWLIN = '$$') C***FIRST EXECUTABLE STATEMENT XERPRN CALL XGETUA(IU,NUNIT) C C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD C ERROR MESSAGE UNIT. C N = I1MACH(4) DO 10 I=1,NUNIT IF (IU(I) .EQ. 0) IU(I) = N 10 CONTINUE C C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING C THE REST OF THIS ROUTINE. C IF ( NPREF .LT. 0 ) THEN LPREF = LEN(PREFIX) ELSE LPREF = NPREF ENDIF LPREF = MIN(16, LPREF) IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX C C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE C TIME FROM MESSG TO PRINT ON ONE LINE. C LWRAP = MAX(16, MIN(132, NWRAP)) C C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. C LENMSG = LEN(MESSG) N = LENMSG DO 20 I=1,N IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 LENMSG = LENMSG - 1 20 CONTINUE 30 CONTINUE C C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. C IF (LENMSG .EQ. 0) THEN CBUFF(LPREF+1:LPREF+1) = ' ' DO 40 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) 40 CONTINUE RETURN ENDIF C C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. C C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH C OF THE SECOND ARGUMENT. C C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT C POSITION NEXTC. C C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE C REMAINDER OF THE CHARACTER STRING. LPIECE C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, C WHICHEVER IS LESS. C C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY C BLANK LINES. THIS TAKES CARE OF THE SITUATION C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC C SHOULD BE INCREMENTED BY 2. C C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. C C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 C RESET LPIECE = LPIECE-1. NOTE THAT THIS C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY C AT THE END OF A LINE. C NEXTC = 1 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) IF (LPIECE .EQ. 0) THEN C C THERE WAS NO NEW LINE SENTINEL FOUND. C IDELTA = 0 LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) IF (LPIECE .LT. LENMSG+1-NEXTC) THEN DO 52 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 54 ENDIF 52 CONTINUE ENDIF 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSEIF (LPIECE .EQ. 1) THEN C C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). C DON'T PRINT A BLANK LINE. C NEXTC = NEXTC + 2 GO TO 50 ELSEIF (LPIECE .GT. LWRAP+1) THEN C C LPIECE SHOULD BE SET DOWN TO LWRAP. C IDELTA = 0 LPIECE = LWRAP DO 56 I=LPIECE+1,2,-1 IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN LPIECE = I-1 IDELTA = 1 GOTO 58 ENDIF 56 CONTINUE 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + IDELTA ELSE C C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. C WE SHOULD DECREMENT LPIECE BY ONE. C LPIECE = LPIECE - 1 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) NEXTC = NEXTC + LPIECE + 2 ENDIF C C PRINT C DO 60 I=1,NUNIT WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) 60 CONTINUE C IF (NEXTC .LE. LENMSG) GO TO 50 RETURN END PDL-2.018/Lib/Slatec/slatec/xersve.f0000644060175006010010000001133712562522365015270 0ustar chmNone*DECK XERSVE SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + ICOUNT) C***BEGIN PROLOGUE XERSVE C***SUBSIDIARY C***PURPOSE Record that an error has occurred. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3 C***TYPE ALL (XERSVE-A) C***KEYWORDS ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C *Usage: C C INTEGER KFLAG, NERR, LEVEL, ICOUNT C CHARACTER * (len) LIBRAR, SUBROU, MESSG C C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) C C *Arguments: C C LIBRAR :IN is the library that the message is from. C SUBROU :IN is the subroutine that the message is from. C MESSG :IN is the message to be saved. C KFLAG :IN indicates the action to be performed. C when KFLAG > 0, the message in MESSG is saved. C when KFLAG=0 the tables will be dumped and C cleared. C when KFLAG < 0, the tables will be dumped and C not cleared. C NERR :IN is the error number. C LEVEL :IN is the error severity. C ICOUNT :OUT the number of times this message has been seen, C or zero if the table has overflowed and does not C contain this message specifically. When KFLAG=0, C ICOUNT will not be altered. C C *Description: C C Record that this error occurred and possibly dump and clear the C tables. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED I1MACH, XGETUA C***REVISION HISTORY (YYMMDD) C 800319 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 900413 Routine modified to remove reference to KFLAG. (WRB) C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling C sequence, use IF-THEN-ELSE, make number of saved entries C easily changeable, changed routine name from XERSAV to C XERSVE. (RWC) C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XERSVE PARAMETER (LENTAB=10) INTEGER LUN(5) CHARACTER*(*) LIBRAR, SUBROU, MESSG CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB CHARACTER*20 MESTAB(LENTAB), MES DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG DATA KOUNTX/0/, NMSG/0/ C***FIRST EXECUTABLE STATEMENT XERSVE C IF (KFLAG.LE.0) THEN C C Dump the table. C IF (NMSG.EQ.0) RETURN C C Print to each unit. C CALL XGETUA (LUN, NUNIT) DO 20 KUNIT = 1,NUNIT IUNIT = LUN(KUNIT) IF (IUNIT.EQ.0) IUNIT = I1MACH(4) C C Print the table header. C WRITE (IUNIT,9000) C C Print body of table. C DO 10 I = 1,NMSG WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), * NERTAB(I),LEVTAB(I),KOUNT(I) 10 CONTINUE C C Print number of other errors. C IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX WRITE (IUNIT,9030) 20 CONTINUE C C Clear the error tables. C IF (KFLAG.EQ.0) THEN NMSG = 0 KOUNTX = 0 ENDIF ELSE C C PROCESS A MESSAGE... C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. C LIB = LIBRAR SUB = SUBROU MES = MESSG DO 30 I = 1,NMSG IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. * LEVEL.EQ.LEVTAB(I)) THEN KOUNT(I) = KOUNT(I) + 1 ICOUNT = KOUNT(I) RETURN ENDIF 30 CONTINUE C IF (NMSG.LT.LENTAB) THEN C C Empty slot found for new message. C NMSG = NMSG + 1 LIBTAB(I) = LIB SUBTAB(I) = SUB MESTAB(I) = MES NERTAB(I) = NERR LEVTAB(I) = LEVEL KOUNT (I) = 1 ICOUNT = 1 ELSE C C Table is full. C KOUNTX = KOUNTX+1 ICOUNT = 0 ENDIF ENDIF RETURN C C Formats. C 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + ' LIBRARY SUBROUTINE MESSAGE START NERR', + ' LEVEL COUNT') 9010 FORMAT (1X,A,3X,A,3X,A,3I10) 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) 9030 FORMAT (1X) END PDL-2.018/Lib/Slatec/slatec/xgetua.f0000644060175006010010000000357112562522365015252 0ustar chmNone*DECK XGETUA SUBROUTINE XGETUA (IUNITA, N) C***BEGIN PROLOGUE XGETUA C***PURPOSE Return unit number(s) to which error messages are being C sent. C***LIBRARY SLATEC (XERROR) C***CATEGORY R3C C***TYPE ALL (XGETUA-A) C***KEYWORDS ERROR, XERROR C***AUTHOR Jones, R. E., (SNLA) C***DESCRIPTION C C Abstract C XGETUA may be called to determine the unit number or numbers C to which error messages are being sent. C These unit numbers may have been set by a call to XSETUN, C or a call to XSETUA, or may be a default value. C C Description of Parameters C --Output-- C IUNIT - an array of one to five unit numbers, depending C on the value of N. A value of zero refers to the C default unit, as defined by the I1MACH machine C constant routine. Only IUNIT(1),...,IUNIT(N) are C defined by XGETUA. The values of IUNIT(N+1),..., C IUNIT(5) are not defined (for N .LT. 5) or altered C in any way by XGETUA. C N - the number of units to which copies of the C error messages are being sent. N will be in the C range from 1 to 5. C C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC C Error-handling Package, SAND82-0800, Sandia C Laboratories, 1982. C***ROUTINES CALLED J4SAVE C***REVISION HISTORY (YYMMDD) C 790801 DATE WRITTEN C 861211 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C 920501 Reformatted the REFERENCES section. (WRB) C***END PROLOGUE XGETUA DIMENSION IUNITA(5) C***FIRST EXECUTABLE STATEMENT XGETUA N = J4SAVE(5,0,.FALSE.) DO 30 I=1,N INDEX = I+4 IF (I.EQ.1) INDEX = 3 IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) 30 CONTINUE RETURN END PDL-2.018/Lib/Slatec/slatec.pd0000644060175006010010000012356713036512175014136 0ustar chmNonepp_addpm({At=>Top},<<'EOD'); =head1 NAME PDL::Slatec - PDL interface to the slatec numerical programming library =head1 SYNOPSIS use PDL::Slatec; ($ndeg, $r, $ierr, $a) = polyfit($x, $y, $w, $maxdeg, $eps); =head1 DESCRIPTION This module serves the dual purpose of providing an interface to parts of the slatec library and showing how to interface PDL to an external library. Using this library requires a fortran compiler; the source for the routines is provided for convenience. Currently available are routines to: manipulate matrices; calculate FFT's; fit data using polynomials; and interpolate/integrate data using piecewise cubic Hermite interpolation. =head2 Piecewise cubic Hermite interpolation (PCHIP) PCHIP is the slatec package of routines to perform piecewise cubic Hermite interpolation of data. It features software to produce a monotone and "visually pleasing" interpolant to monotone data. According to Fritsch & Carlson ("Monotone piecewise cubic interpolation", SIAM Journal on Numerical Analysis 17, 2 (April 1980), pp. 238-246), such an interpolant may be more reasonable than a cubic spline if the data contains both "steep" and "flat" sections. Interpolation of cumulative probability distribution functions is another application. These routines are cryptically named (blame FORTRAN), beginning with 'ch', and accept either float or double piddles. Most of the routines require an integer parameter called C; if set to 0, then no checks on the validity of the input data are made, otherwise these checks are made. The value of C can be set to 0 if a routine such as L has already been successfully called. =over 4 =item * If not known, estimate derivative values for the points using the L, L, or L routines (the following routines require both the function (C) and derivative (C) values at a set of points (C)). =item * Evaluate, integrate, or differentiate the resulting PCH function using the routines: L; L; L; L. =item * If desired, you can check the monotonicity of your data using L. =back =cut EOD # ' un-confuse emacs # if define chbs, then add something like the following to point 3: # # or use L to convert a PCH function into B-representation # for use with the B-spline routines of slatec # (although no interface to them currently exist). # # add function definitions after finishing the first pp_addpm(), since this # adds a '=head1 FUNCTIONS' line at the end of the text pp_addpm(<<'END'); =head2 eigsys =for ref Eigenvalues and eigenvectors of a real positive definite symmetric matrix. =for usage ($eigvals,$eigvecs) = eigsys($mat) Note: this function should be extended to calculate only eigenvalues if called in scalar context! =head2 matinv =for ref Inverse of a square matrix =for usage ($inv) = matinv($mat) =head2 polyfit Convenience wrapper routine about the C C function. Separates supplied arguments and return values. =for ref Fit discrete data in a least squares sense by polynomials in one variable. Handles threading correctly--one can pass in a 2D PDL (as C<$y>) and it will pass back a 2D PDL, the rows of which are the polynomial regression results (in C<$r> corresponding to the rows of $y. =for usage ($ndeg, $r, $ierr, $a, $coeffs, $rms) = polyfit($x, $y, $w, $maxdeg, [$eps]); $coeffs = polyfit($x,$y,$w,$maxdeg,[$eps]); where on input: C<$x> and C<$y> are the values to fit to a polynomial. C<$w> are weighting factors C<$maxdeg> is the maximum degree of polynomial to use and C<$eps> is the required degree of fit. and the output switches on list/scalar context. In list context: C<$ndeg> is the degree of polynomial actually used C<$r> is the values of the fitted polynomial C<$ierr> is a return status code, and C<$a> is some working array or other (preserved for historical purposes) C<$coeffs> is the polynomial coefficients of the best fit polynomial. C<$rms> is the rms error of the fit. In scalar context, only $coeffs is returned. Historically, C<$eps> was modified in-place to be a return value of the rms error. This usage is deprecated, and C<$eps> is an optional parameter now. It is still modified if present. C<$a> is a working array accessible to Slatec - you can feed it to several other Slatec routines to get nice things out. It does not thread correctly and should probably be fixed by someone. If you are reading this, that someone might be you. =for bad This version of polyfit handles bad values correctly. Bad values in $y are ignored for the fit and give computed values on the fitted curve in the return. Bad values in $x or $w are ignored for the fit and result in bad elements in the output. =head2 polycoef Convenience wrapper routine around the C C function. Separates supplied arguments and return values. =for ref Convert the C/C coefficients to Taylor series form. =for usage $tc = polycoef($l, $c, $a); =head2 polyvalue Convenience wrapper routine around the C C function. Separates supplied arguments and return values. For multiple input x positions, a corresponding y position is calculated. The derivatives PDL is one dimensional (of size C) if a single x position is supplied, two dimensional if more than one x position is supplied. =for ref Use the coefficients generated by C (or C) to evaluate the polynomial fit of degree C, along with the first C of its derivatives, at a specified point. =for usage ($yfit, $yp) = polyvalue($l, $nder, $x, $a); =head2 detslatec =for ref compute the determinant of an invertible matrix =for example $mat = zeroes(5,5); $mat->diagonal(0,1) .= 1; # unity matrix $det = detslatec $mat; Usage: =for usage $determinant = detslatec $matrix; =for sig Signature: detslatec(mat(n,m); [o] det()) C computes the determinant of an invertible matrix and barfs if the matrix argument provided is non-invertible. The matrix threads as usual. This routine was previously known as C which clashes now with L which is provided by L. =head2 fft =for ref Fast Fourier Transform =for example $v_in = pdl(1,0,1,0); ($azero,$a,$b) = PDL::Slatec::fft($v_in); C is a convenience wrapper for L, and performs a Fast Fourier Transform on an input vector C<$v_in>. The return values are the same as for L. =head2 rfft =for ref reverse Fast Fourier Transform =for example $v_out = PDL::Slatec::rfft($azero,$a,$b); print $v_in, $vout [1 0 1 0] [1 0 1 0] C is a convenience wrapper for L, and performs a reverse Fast Fourier Transform. The input is the same as the output of L, and the output of C is a data vector, similar to what is input into L. =cut END use strict; # for MDim, ld[str] is interpreted as "leading dimension of ..." # Making the BAD BAD BAD assumption that PDL_Long == int # in fortran. BAD BAD BAD XXX (I'm going to regret this) my %ftypes = (S => 'F', D => 'D'); sub firstpar { $_[0] =~ /^\(([^),]+)[),]/ or die "Can't find first par from $_[0]"; $1 } # whether or not to append undercores my $uscore = (-e "f77_underscore" ? "_" : ""); # used in defslatec() #my %ignore_ppar = ( Incfd => 1, CheckFlag => 1 ); my %ignore_ppar = ( Incfd => 1 ); my %prototype = ( F => "float", D => "double" ); # an alternative is to declare the function in the Code section # of pp_def(), using something like: # # my $codeproto = "\$T".(join '',map {$_->[0]} @talts)."(". # (join ',',map {$_->[1].$uscore} @talts).") ();"; # if ( defined $fpar ) { # $codeproto = "\$T".(join '',map {$_->[0]} @talts)."(float,double) $codeproto"; # } # $codeproto = "extern $codeproto"; # # and then add `$codeproto . "\n" .' to the beginning of the Code # section. # # this then gets rid of the need of the prototype file. # open( PROTOS, "> SlatecProtos.h" ); # defslatec( $pdlname, $funcnames, $argstr, $docstring, $funcref ) # # $pdlname is the name of the PDL function to be created # $funcnames is a reference to a hash array, whose keys define # the single (S), and double precision (D) names of the # SLATEC routines to be linked to. # # $argstr is a list of arguments expected by the SLATEC routine # - some of the allowed type names are: # FuncRet # - specifies that this is a function, not a subroutine, and # that the output of the function should be stored in this # variable # Incfd # - used in the PCHIP functions to specify the INCFD argument # that we force to be 1, so the user never has to specify it # (this allows the PCHIP routines to use 2D data, but as it's # done in FORTRAN array order, and PDL has a much richer way # of accessing parts of an array we force the data to be 1D). # CheckFlag # - the PCHIP routined may change the value from 0 to 1 if an # error occurs but the checks were successful. As this complicates # things we copy the user value to a temporary variable, # so that the sent in value is not changed. # FortranIndex # - pchid()/dpchid() require FORTRAN array indices, so # this type flags that we should add 1 onto the input values # before sending to the slatec function # # $docstring gives the text to be used as the function dicumentation # # $funcref gets placed within a '=for ref' pod statement at the # start of the documentation - ie it is placed before the # text within $docstring. This string gets printed out # in the perldl or pdl2 shell after a '?? string' command # sub defslatec { my $debug = 0; # print out calls to pp_def my($pname,$fnames,$argstr,$docstring,$funcref) = @_; my @args = map {/^\s*$/ ? () : $_} split ';', $argstr; my @args2 = map { /^\s*([a-zA-Z]+)\s+ # "Type name" ((?:\[[^]]*\])?)\s* # Options ([a-zA-Z]+)\s* # Par name ((?:\([^)]*\))?)\s*$ # Dims /x or die("Invalid slatec par $_"); [$1,$2,$3,$4]} @args; # is this for a function (Type name eq "FuncRet") # or a subroutine? my $fpar; foreach ( @args2 ) { next unless $_->[0] eq "FuncRet"; die "Only one FuncRet allowed in pars list.\n" if defined $fpar; $fpar = "\$$_->[2]()"; } my @ppars = map { if($_->[0] =~ /^M?Dim$/ or defined $ignore_ppar{$_->[0]} ) { () } else { (($_->[0] eq "Mat" or $_->[0] eq "FuncRet") and join '',@{$_}[1,2,3]) or (($_->[0] eq "IntFlag" or $_->[0] eq "FortranIndex" or $_->[0] eq "CheckFlag") and "int ".join '',@{$_}[1,2,3]) or die "Invalid ppars ",(join ',',@$_),"\n"; } } @args2; # uncomment the following line to see what perl thinks the input pars are ##print "Pars: ",(join ';',@ppars),"\n"; my @talts = map { defined $ftypes{$_} or die "FTYPE $_ NOT THERE\n"; [$ftypes{$_},$fnames->{$_}] } sort keys %$fnames; my $func = "\$T".(join '',map {$_->[0]} @talts) . "(" . (join ',',map {$_->[1].$uscore} @talts).")"; if ( defined $fpar ) { $func = "$fpar = $func"; } my %lds = map { ($_->[0] eq "Mat" and $_->[3] ne "()") ? ("ld".$_->[2] => "&\$PRIV(__".firstpar($_->[3])."_size)") : () } @args2; my @funcpars; foreach ( @args2 ) { next if $_->[0] eq "FuncRet"; if ( $_->[0] eq "Mat" or $_->[0] eq "IntFlag" ) { push @funcpars, "\$P($_->[2])"; } elsif ( $_->[0] eq "Dim" ) { push @funcpars, "&\$PRIV(__$_->[2]_size)"; } elsif ( $_->[0] eq "MDim" ) { push @funcpars, $lds{$_->[2]}; } elsif ( $_->[0] eq "Incfd" or $_->[0] eq "CheckFlag" ) { push @funcpars, "&_" . lc($_->[0]); } elsif ( $_->[0] eq "FortranIndex" ) { push @funcpars, "&_$_->[2]"; } else { die "Invalid args2"; } } # _incfd = 1 makes sure PCHIP code treats piddle as 1D # _checkflag - copy input data to a temporary variable, in case # the PCHIP routine decides to change it # my @ifincode; foreach ( @args2 ) { if ( $_->[0] eq "Incfd" ) { push @ifincode, "int _" . lc($_->[0]) . " = 1;"; } elsif ( $_->[0] eq "CheckFlag" ) { push @ifincode, "int _" . lc($_->[0]) . " = \$$_->[2]();"; } elsif ( $_->[0] eq "FortranIndex" ) { # convert from C to F77 index push @ifincode, "int _$_->[2] = \$$_->[2]() + 1;" } } foreach ( @talts ) { my $codeproto = "extern "; if ( defined $fpar ) { $codeproto .= "$prototype{$_->[0]} "; } else { $codeproto .= "int "; } $codeproto .= "$_->[1]$uscore ();"; print PROTOS $codeproto . "\n"; } # add on the function reference, if supplied, to the start of # the doc string if ( defined $docstring ) { $docstring = "\n=for ref\n\n$funcref\n\n$docstring" if defined $funcref; } else { $docstring = ''; } # If debug flag set, then print out pp_def call for each call to defslatec if ($debug) { my $pars = (join ';',@ppars); my $code = (join '',@ifincode) . "\n " . $func . " (". (join ',',@funcpars) . ");\n"; my $generictypes = "[" . join (", ", map {$_->[0]} @talts) . "],\n"; print <<"ENDDBG"; pp_def($pname, Pars => $pars, OtherPars => '', Code => $code, GenericTypes => $generictypes, Doc => $docstring ); ENDDBG } pp_def($pname, Pars => (join ';',@ppars), OtherPars => '', Code => (join '',@ifincode) . "\n " . $func . " (". (join ',',@funcpars) . ");\n", # . (join '',@ifoutcode), GenericTypes => [map {$_->[0]} @talts], Doc => $docstring # %$opts, ); } # sub: defslatec() pp_addhdr(qq| #include "SlatecProtos.h" void MAIN__ () { /* Cheat to define MAIN__ symbol */ croak("This should never happen"); } void slatecbarf$uscore() { croak("slatec called halt"); } |); pp_add_exported('',"eigsys matinv polyfit polycoef polyvalue"); pp_addpm(<<'END'); use PDL::Core; use PDL::Basic; use PDL::Primitive; use PDL::Ufunc; use strict; # Note: handles only real symmetric positive-definite. *eigsys = \&PDL::eigsys; sub PDL::eigsys { my($h) = @_; $h = float($h); rs($h, (my $eigval=PDL->null), (long (pdl (1))),(my $eigmat=PDL->null), (my $fvone = PDL->null),(my $fvtwo = PDL->null), (my $errflag=PDL->null) ); # print $covar,$eigval,$eigmat,$fvone,$fvtwo,$errflag; if(sum($errflag) > 0) { barf("Non-positive-definite matrix given to eigsys: $h\n"); } return ($eigval,$eigmat); } *matinv = \&PDL::matinv; sub PDL::matinv { my($m) = @_; my(@dims) = $m->dims; # Keep from dumping core (FORTRAN does no error checking) barf("matinv requires a 2-D square matrix") unless( @dims >= 2 && $dims[0] == $dims[1] ); $m = $m->copy(); # Make sure we don't overwrite :( gefa($m,(my $ipvt=null),(my $info=null)); if(sum($info) > 0) { barf("Uninvertible matrix given to inv: $m\n"); } gedi($m,$ipvt,(pdl 0,0),(null),(long( pdl (1)))); $m; } *detslatec = \&PDL::detslatec; sub PDL::detslatec { my($m) = @_; $m = $m->copy(); # Make sure we don't overwrite :( gefa($m,(my $ipvt=null),(my $info=null)); if(sum($info) > 0) { barf("Uninvertible matrix given to inv: $m\n"); } gedi($m,$ipvt,(my $det=null),(null),(long( pdl (10)))); return $det->slice('(0)')*10**$det->slice('(1)'); } sub prepfft { my($n) = @_; my $tmp = PDL->zeroes(float(),$n*3+15); $n = pdl $n; ezffti($n,$tmp); return $tmp; } sub fft (;@) { my($v) = @_; my $ws = prepfft($v->getdim(0)); ezfftf($v,(my $az = PDL->null), (my $a = PDL->null), (my $b = PDL->null), $ws); return ($az,$a,$b); } sub rfft { my($az,$a,$b) = @_; my $ws = prepfft($a->getdim(0)); my $v = $a->copy(); ezfftb($v,$az,$a,$b,$ws); return $v; } # polynomial fitting routines # simple wrappers around the SLATEC implementations *polyfit = \&PDL::polyfit; sub PDL::polyfit { barf 'Usage: polyfit($x, $y, $w, $maxdeg, [$eps]);' unless (@_ == 5 || @_==4 ); my ($x_in, $y_in, $w_in, $maxdeg_in, $eps_in) = @_; # if $w_in does not match the data vectors ($x_in, $y_in), then we can resize # it to match the size of $y_in : $w_in = $w_in + $y_in->zeros; # Create the output arrays my $r = PDL->null; # A array needs some work space my $sz = ((3 * $x_in->getdim(0)) + (3*$maxdeg_in) + 3); # Buffer size called for by Slatec my @otherdims = $_[0]->dims; shift @otherdims; # Thread dims my $a = PDL::new_from_specification('PDL',$x_in->type,$sz,@otherdims); my $coeffs = PDL::new_from_specification('PDL',$x_in->type, $maxdeg_in + 1, @otherdims); my $ierr = PDL->null; my $ndeg = PDL->null; # Now call polfit my $rms = pdl($eps_in); polfit($x_in, $y_in, $w_in, $maxdeg_in, $ndeg, $rms, $r, $ierr, $a, $coeffs); # Preserve historic compatibility by flowing rms error back into the argument if( UNIVERSAL::isa($eps_in,'PDL') ){ $eps_in .= $rms; } # Return the arrays if(wantarray) { return ($ndeg, $r, $ierr, $a, $coeffs, $rms ); } else { return $coeffs; } } *polycoef = \&PDL::polycoef; sub PDL::polycoef { barf 'Usage: polycoef($l, $c, $a);' unless @_ == 3; # Allocate memory for return PDL # Simply l + 1 but cant see how to get PP to do this - TJ # Not sure the return type since I do not know # where PP will get the information from my $tc = PDL->zeroes( abs($_[0]) + 1 ); # Run the slatec routine pcoef($_[0], $_[1], $tc, $_[2]); # Return results return $tc; } *polyvalue = \&PDL::polyvalue; sub PDL::polyvalue { barf 'Usage: polyvalue($l, $nder, $x, $a);' unless @_ == 4; # Two output arrays my $yfit = PDL->null; # This one must be preallocated and must take into account # the size of $x if greater than 1 my $yp; if ($_[2]->getdim(0) == 1) { $yp = $_[2]->zeroes($_[1]); } else { $yp = $_[2]->zeroes($_[1], $_[2]->getdim(0)); } # Run the slatec function pvalue($_[0], $_[2], $yfit, $yp, $_[3]); # Returns return ($yfit, $yp); } END defslatec( 'svdc',{S => 'ssvdc'}, 'Mat x (n,p); MDim ldx; Dim n; Dim p; Mat [o] s (p); Mat [o] e (p); Mat [o] u (n,p); MDim ldu; Mat [o] v (p,p); MDim ldv; Mat [o] work (n); IntFlag job (); IntFlag [o] info (); ', 'singular value decomposition of a matrix' ); defslatec( 'poco',{S => 'spoco', D => 'dpoco'}, 'Mat a (n,n); MDim lda; Dim n; Mat rcond (); Mat [o] z (n); IntFlag [o] info (); ', 'Factor a real symmetric positive definite matrix and estimate the condition number of the matrix.' ); defslatec( 'geco',{S => 'sgeco', D => 'dgeco'}, 'Mat a (n,n); MDim lda; Dim n; IntFlag [o] ipvt (n); Mat [o] rcond (); Mat [o] z (n); ', 'Factor a matrix using Gaussian elimination and estimate the condition number of the matrix.' ); defslatec( 'gefa',{S => 'sgefa', D => 'dgefa'}, 'Mat a (n,n); MDim lda; Dim n; IntFlag [o] ipvt (n); IntFlag [o] info (); ', 'Factor a matrix using Gaussian elimination.' ); # XXX Ensure two == 2!! # # pofa and sqrdc aren't (yet?) implemented # defslatec( 'podi',{S => 'spodi', D => 'dpodi'}, 'Mat a (n,n); MDim lda; Dim n; Mat [o] det (two=2); IntFlag job (); ', 'Compute the determinant and inverse of a certain real symmetric positive definite matrix using the factors computed by L.' ); defslatec( 'gedi',{S => 'sgedi', D => 'dgedi'}, 'Mat a (n,n); MDim lda; Dim n; IntFlag [o] ipvt (n); Mat [o] det (two=2); Mat [o] work (n); IntFlag job (); ', 'Compute the determinant and inverse of a matrix using the factors computed by L or L.' ); defslatec( 'gesl',{S => 'sgesl', D => 'dgesl'}, 'Mat a (lda,n); MDim lda; Dim n; IntFlag ipvt (n); Mat b (n); IntFlag job (); ', 'Solve the real system C or C using the factors computed by L or L.' ); defslatec( 'rs', {S => 'rsfoo'}, 'MDim lda; Dim n; Mat a (n,n); Mat [o] w (n); IntFlag matz (); Mat [o] z (n,n); Mat [t] fvone (n); Mat [t] fvtwo (n); IntFlag [o] ierr (); ', 'This subroutine calls the recommended sequence of subroutines from the eigensystem subroutine package (EISPACK) to find the eigenvalues and eigenvectors (if desired) of a REAL SYMMETRIC matrix.' ); # XXX wsave : at least 3n+15 defslatec( 'ezffti', {S => 'ezffti'}, 'IntFlag n (); Mat [o] wsave(foo); ', 'Subroutine ezffti initializes the work array C which is used in both L and L. The prime factorization of C together with a tabulation of the trigonometric functions are computed and stored in C.' ); # XXX Correct for azero, a and b defslatec( 'ezfftf', {S => 'ezfftf'}, 'Dim n; Mat r(n); Mat [o] azero(); Mat [o] a(n); Mat [o] b(n); Mat wsave(foo); ' ); defslatec( 'ezfftb', {S => 'ezfftb'}, 'Dim n; Mat [o] r(n); Mat azero(); Mat a(n); Mat b(n); Mat wsave(foo); ' ); ################################################################## ################################################################## defslatec( 'pcoef', {S => 'pcoef', D => 'dpcoef'}, ' IntFlag l (); Mat c (); Mat [o] tc (bar); Mat a (foo); ', 'Convert the C coefficients to Taylor series form. C and C must be of the same type.' ); defslatec( 'pvalue', {S => 'pvalue', D => 'dp1vlu'}, ' IntFlag l (); Dim nder; Mat x (); Mat [o] yfit (); Mat [o] yp (nder); Mat a (foo); ', 'Use the coefficients generated by C to evaluate the polynomial fit of degree C, along with the first C of its derivatives, at a specified point. C and C must be of the same type.' ); ################################################################## ################################################################## # # PCHIP library # defslatec( 'chim', {S => 'pchim', D => 'dpchim'}, 'Dim n; Mat x (n); Mat f (n); Mat [o] d (n); Incfd dummy; IntFlag [o] ierr (); ', 'Calculate the derivatives at the given set of points (C<$x,$f>, where C<$x> is strictly increasing). The resulting set of points - C<$x,$f,$d>, referred to as the cubic Hermite representation - can then be used in other functions, such as L, L, and L. The boundary conditions are compatible with monotonicity, and if the data are only piecewise monotonic, the interpolant will have an extremum at the switch points; for more control over these issues use L. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E 0 if there were C switches in the direction of monotonicity (data still valid). =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =back =cut ', 'Calculate the derivatives of (x,f(x)) using cubic Hermite interpolation.' ); # switch has become mflag, since `switch' is a reserved word in # C. # # can not say (nwk=2*n) --- the rhs has to equal a number # -> could Basic/Gen/PP/Dims.pm be hacked to allow this? # # I didn't have much success with preceding wk by [t] # defslatec( 'chic', {S => 'pchic', D => 'dpchic'}, 'IntFlag ic (two=2); Mat vc (two=2); Mat mflag (); Dim n; Mat x (n); Mat f (n); Mat [o] d (n); Incfd dummy; Mat wk (nwk); Dim nwk; IntFlag [o] ierr (); ', 'Calculate the derivatives at the given points (C<$x,$f>, where C<$x> is strictly increasing). Control over the boundary conditions is given by the C<$ic> and C<$vc> piddles, and the value of C<$mflag> determines the treatment of points where monotoncity switches direction. A simpler, more restricted, interface is available using L. The first and second elements of C<$ic> determine the boundary conditions at the start and end of the data respectively. If the value is 0, then the default condition, as used by L, is adopted. If greater than zero, no adjustment for monotonicity is made, otherwise if less than zero the derivative will be adjusted. The allowed magnitudes for C are: =over 4 =item * 1 if first derivative at C is given in C. =item * 2 if second derivative at C is given in C. =item * 3 to use the 3-point difference formula for C. (Reverts to the default b.c. if C 3>) =item * 4 to use the 4-point difference formula for C. (Reverts to the default b.c. if C 4>) =item * 5 to set C so that the second derivative is continuous at C. (Reverts to the default b.c. if C 4>) =back The values for C are the same as above, except that the first-derivative value is stored in C for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. Set C<$mflag = 0> if interpolant is required to be monotonic in each interval, regardless of the data. This causes C<$d> to be set to 0 at all switch points. Set C<$mflag> to be non-zero to use a formula based on the 3-point difference formula at switch points. If C<$mflag E 0>, then the interpolant at swich points is forced to not deviate from the data by more than C<$mflag*dfloc>, where C is the maximum of the change of C<$f> on this interval and its two immediate neighbours. If C<$mflag E 0>, no such control is to be imposed. The piddle C<$wk> is only needed for work space. However, I could not get it to work as a temporary variable, so you must supply it; it is a 1D piddle with C<2*n> elements. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * 1 if C 0> and C had to be adjusted for monotonicity. =item * 2 if C 0> and C had to be adjusted for monotonicity. =item * 3 if both 1 and 2 are true. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 5>. =item * -5 if C 5>. =item * -6 if both -4 and -5 are true. =item * -7 if C 2*(n-1)>. =back =cut ', 'Calculate the derivatives of (x,f(x)) using cubic Hermite interpolation.' ); # as above, have made wk an actual piddle, rather than a [t] defslatec( 'chsp', {S => 'pchsp', D => 'dpchsp'}, 'IntFlag ic (two=2); Mat vc (two=2); Dim n; Mat x (n); Mat f (n); Mat [o] d (n); Incfd dummy; Mat wk (nwk); Dim nwk; IntFlag [o] ierr (); ', 'Calculate the derivatives, using cubic spline interpolation, at the given points (C<$x,$f>), with the specified boundary conditions. Control over the boundary conditions is given by the C<$ic> and C<$vc> piddles. The resulting values - C<$x,$f,$d> - can be used in all the functions which expect a cubic Hermite function. The first and second elements of C<$ic> determine the boundary conditions at the start and end of the data respectively. The allowed values for C are: =over 4 =item * 0 to set C so that the third derivative is continuous at C. =item * 1 if first derivative at C is given in C). =item * 2 if second derivative at C) is given in C. =item * 3 to use the 3-point difference formula for C. (Reverts to the default b.c. if C 3>.) =item * 4 to use the 4-point difference formula for C. (Reverts to the default b.c. if C 4>.) =back The values for C are the same as above, except that the first-derivative value is stored in C for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. The piddle C<$wk> is only needed for work space. However, I could not get it to work as a temporary variable, so you must supply it; it is a 1D piddle with C<2*n> elements. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 0> or C 4>. =item * -5 if C 0> or C 4>. =item * -6 if both of the above are true. =item * -7 if C 2*n>. =item * -8 in case of trouble solving the linear system for the interior derivative values. =back =cut ', 'Calculate the derivatives of (x,f(x)) using cubic spline interpolation.' ); defslatec( 'chfd', {S => 'pchfd', D => 'dpchfd'}, 'Dim n; Mat x (n); Mat f (n); Mat d (n); Incfd dummy; CheckFlag check (); Dim ne; Mat xe (ne); Mat [o] fe (ne); Mat [o] de (ne); IntFlag [o] ierr (); ', 'Given a piecewise cubic Hermite function - such as from L - evaluate the function (C<$fe>) and derivative (C<$de>) at a set of points (C<$xe>). If function values alone are required, use L. Set C to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E0 if extrapolation was performed at C points (data still valid). =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 1>. =item * -5 if an error has occurred in a lower-level routine, which should never happen. =back =cut ', 'Interpolate function and derivative values.' ); defslatec( 'chfe', {S => 'pchfe', D => 'dpchfe'}, 'Dim n; Mat x (n); Mat f (n); Mat d (n); Incfd dummy; CheckFlag check (); Dim ne; Mat xe (ne); Mat [o] fe (ne); IntFlag [o] ierr (); ', 'Given a piecewise cubic Hermite function - such as from L - evaluate the function (C<$fe>) at a set of points (C<$xe>). If derivative values are also required, use L. Set C to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E0 if extrapolation was performed at C points (data still valid). =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 1>. =back =cut ', 'Interpolate function values.' ); defslatec( 'chia', {S => 'pchia', D => 'dpchia'}, 'Dim n; Mat x (n); Mat f (n); Mat d (n); Incfd dummy; CheckFlag check (); Mat a (); Mat b (); FuncRet [o] ans (); IntFlag [o] ierr (); ', 'Evaluate the definite integral of a a piecewise cubic Hermite function over an arbitrary interval, given by C<[$a,$b]>. See L if the integration limits are data points. Set C to 0 to skip checks on the input data. The values of C<$a> and C<$b> do not have to lie within C<$x>, although the resulting integral value will be highly suspect if they are not. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * 1 if C<$a> lies outside C<$x>. =item * 2 if C<$b> lies outside C<$x>. =item * 3 if both 1 and 2 are true. =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if an error has occurred in a lower-level routine, which should never happen. =back =cut ', 'Integrate (x,f(x)) over arbitrary limits.' ); defslatec( 'chid', {S => 'pchid', D => 'dpchid'}, 'Dim n; Mat x (n); Mat f (n); Mat d (n); Incfd dummy; CheckFlag check (); FortranIndex ia (); FortranIndex ib (); FuncRet [o] ans (); IntFlag [o] ierr (); ', 'Evaluate the definite integral of a a piecewise cubic Hermite function between C and C. See L for integration between arbitrary limits. Although using a fortran routine, the values of C<$ia> and C<$ib> are zero offset. Set C to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<$ia> or C<$ib> is out of range. =back =cut ', 'Integrate (x,f(x)) between data points.' ); defslatec( 'chcm', {S => 'pchcm', D => 'dpchcm'}, 'Dim n; Mat x (n); Mat f (n); Mat d (n); Incfd dummy; CheckFlag check (); IntFlag [o] ismon (n); IntFlag [o] ierr (); ', 'The outout piddle C<$ismon> indicates over which intervals the function is monotonic. Set C to 0 to skip checks on the input data. For the data interval C<[x(i),x(i+1)]>, the values of C can be: =over 4 =item * -3 if function is probably decreasing =item * -1 if function is strictly decreasing =item * 0 if function is constant =item * 1 if function is strictly increasing =item * 2 if function is non-monotonic =item * 3 if function is probably increasing =back If C, the derivative values are near the boundary of the monotonicity region. A small increase produces non-monotonicity, whereas a decrease produces strict monotonicity. The above applies to C. The last element of C<$ismon> indicates whether the entire function is monotonic over $x. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =back =cut ', 'Check the given piecewise cubic Hermite function for monotonicity.' ); =pod ignore function for now although code is in slatec/ directory =cut # XXX tsize = 2*n+4 # bsize = 2*n # # ndim gets set to 2*n # # Changed by routine: # nknots # t defslatec( 'chbs', {S => 'pchbs', D => 'dpchbs'}, 'Dim n; Mat x (n); Mat f (n); Mat d (n); Incfd dummy; IntFlag knotyp (); IntFlag nknots (); Mat t (tsize); Mat [o] bcoef (bsize); IntFlag [o] ndim (); IntFlag [o] kord (); IntFlag [o] ierr (); ', 'The resulting B-spline representation of the data (i.e. C, C, C, C, and C) can be evaluated by C (which is currently not available). Array sizes: C, C, and C. C is a flag which controls the knot sequence. The knot sequence C is normally computed from C<$x> by putting a double knot at each C and setting the end knot pairs according to the value of C (where C): =over =item * 0 - Quadruple knots at the first and last points. =item * 1 - Replicate lengths of extreme subintervals: C and C =item * 2 - Periodic placement of boundary knots: C and C =item * E0 - Assume the C and C were set in a previous call. =back C is the number of knots and may be changed by the routine. If C= 0>, C will be set to C, otherwise it is an input variable, and an error will occur if its value is not equal to C. C is the array of C<2*n+4> knots for the B-representation and may be changed by the routine. If C= 0>, C will be changed so that the interior double knots are equal to the x-values and the boundary knots set as indicated above, otherwise it is assumed that C was set by a previous call (no check is made to verify that the data forms a legitimate knot sequence). Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -4 if C 2>. =item * -5 if C 0> and C. =back =cut ', 'Piecewise Cubic Hermite function to B-Spline converter.' ); ################################################################## ################################################################## # # This version of polfit accepts bad values and also allows threading # # # indices: # n runs across input points; # foo runs across wacky Slatec buffer size; # bar runs across polynomial coefficients. # pp_def('polfit', Pars => 'x(n); y(n); w(n); int maxdeg(); int [o]ndeg(); [o]eps(); [o]r(n); int [o]ierr(); [o]a(foo); [o]coeffs(bar);[t]xtmp(n);[t]ytmp(n);[t]wtmp(n);[t]rtmp(n)', OtherPars => '', Code => ' int maxord; int ord; int k; $GENERIC() zero = 0; $TFD(polfit'.$uscore.',dpolft'.$uscore.') (&$PRIV(__n_size),$P(x),$P(y),$P(w),$P(maxdeg),$P(ndeg),$P(eps),$P(r),$P(ierr),$P(a)); maxord = ($P(a))[0]+0.5; ord = ($P(a))[maxord * 3 + 2]; if(ord >= $maxdeg()) { ord = $maxdeg(); } $TFD(pcoef'.$uscore.',dpcoef'.$uscore.') ( &(ord), &(zero), $P(coeffs), $P(a)); for(k=ord+1; k<=$maxdeg(); k++) ($P(coeffs))[k] = 0; ', GenericTypes => ['F','D'], HandleBad => 1, NoBadifNaN => 1, BadCode => 'int ns = $SIZE(n); int i; int j = 0; if($SIZE(n)<$maxdeg()) { barf("polfit: Must have at least points to fit coefficients"); } for (i=0;ii)) && $ISGOOD(x(n=>i)) && $ISGOOD(w(n=>i))) { $xtmp(n=>j) = $x(n=>i); $ytmp(n=>j) = $y(n=>i); $wtmp(n=>j) = $w(n=>i); j++; } } if (j <= $maxdeg()) { /* Not enough good datapoints -- set this whole row to BAD. */ for (i=0;ii)); } $ierr() = 2; } else { /* Found enough good datapoints for a fit -- do the fit */ int k; int ord; int maxord; $GENERIC() zero = 0; /* Do the fit */ $TFD(polfit'.$uscore.',dpolft'.$uscore.') (&j,$P(xtmp),$P(ytmp),$P(wtmp),$P(maxdeg),$P(ndeg),$P(eps),$P(rtmp),$P(ierr),$P(a)); maxord = ($P(a))[0]+0.5; ord = ($P(a))[maxord * 3 + 2]; if(ord >= $maxdeg()) { ord = $maxdeg(); } /* Extract the polynomial coefficients into coeffs -- used for bad values */ $TFD(pcoef'.$uscore.',dpcoef'.$uscore.') ( &(ord), &(zero), $P(coeffs), $P(a)); for(k=ord+1; k<=$maxdeg(); k++) ($P(coeffs))[k] = 0; j=0; for (i=0;ii))) { $r(n=>i) = $rtmp(n=>j); j++; } else if($ISGOOD(x(n=>i))) { /* Bad values are omitted from the call to polfit, so we must reconstitute them on return */ /* (just because a value is bad in y, does not mean the fit itself is bad there) */ /* */ /* The number in ord is not the number of coefficients in the polynomial, it is the highest */ /* order coefficient -- so 3 for a cubic, which has 4 coefficients. */ /* --CED */ int ii; $GENERIC() acc = 0; for( ii=ord; ii>0; ii-- ) { acc += $coeffs(bar=>ii); acc *= $x(n=>i); } acc += $coeffs(bar=>0); $r(n=>i) = acc; } else { /* x and y are bad here... */ $SETBAD(r(n=>i)); } } }', Doc => 'Fit discrete data in a least squares sense by polynomials in one variable. C, C and C must be of the same type. This version handles bad values appropriately', ); #these two need to be done manually because we don't use defslatec for them print PROTOS "extern int polfit_ ();\nextern int dpolft_ ();\n"; close( PROTOS ); ################################################################## ################################################################## pp_addpm(<<'EOD'); =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Copyright (C) 2000 Tim Jenness, Doug Burke. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.018/Lib/Transform/0000755060175006010010000000000013110402046013044 5ustar chmNonePDL-2.018/Lib/Transform/Cartography/0000755060175006010010000000000013110402046015327 5ustar chmNonePDL-2.018/Lib/Transform/Cartography/Cartography.pm0000644060175006010010000024372613036512175020202 0ustar chmNone=head1 NAME PDL::Transform::Cartography - Useful cartographic projections =head1 SYNOPSIS # make a Mercator map of Earth use PDL::Transform::Cartography; $a = earth_coast(); $a = graticule(10,2)->glue(1,$a); $t = t_mercator; $w = pgwin(xs); $w->lines($t->apply($a)->clean_lines()); =head1 DESCRIPTION PDL::Transform::Cartography includes a variety of useful cartographic and observing projections (mappings of the surface of a sphere), including reprojected observer coordinates. See L for more information about image transforms in general. Cartographic transformations are used for projecting not just terrestrial maps, but also any nearly spherical surface including the Sun, the Celestial sphere, various moons and planets, distant stars, etc. They also are useful for interpreting scientific images, which are themselves generally projections of a sphere onto a flat focal plane (e.g. the L projection). Unless otherwise noted, all the transformations in this file convert from (theta,phi) coordinates on the unit sphere (e.g. (lon,lat) on a planet or (RA,dec) on the celestial sphere) into some sort of projected coordinates, and have inverse transformations that convert back to (theta,phi). This is equivalent to working from the equidistant cylindrical (or L<"plate caree"|/t_caree>) projection, if you are a cartography wonk. The projected coordinates are generally in units of body radii (radians), so that multiplying the output by the scale of the map yields physical units that are correct wherever the scale is correct for that projection. For example, areas should be correct everywhere in the authalic projections; and linear scales are correct along meridians in the equidistant projections and along the standard parallels in all the projections. The transformations that are authalic (equal-area), conformal (equal-angle), azimuthal (circularly symmetric), or perspective (true perspective on a focal plane from some viewpoint) are marked. The first two categories are mutually exclusive for all but the L<"unit sphere"|/t_unit_sphere> 3-D projection. Extra dimensions tacked on to each point to be transformed are, in general, ignored. That is so that you can add on an extra index to keep track of pen color. For example, L returns a 3x piddle containing (lon, lat, pen) at each list location. Transforming the vector list retains the pen value as the first index after the dimensional directions. =head1 GENERAL NOTES ON CARTOGRAPHY Unless otherwise noted, the transformations and miscellaneous information in this section are taken from Snyder & Voxland 1989: "An Album of Map Projections", US Geological Survey Professional Paper 1453, US Printing Office (Denver); and from Snyder 1987: "Map Projections - A Working Manual", US Geological Survey Professional Paper 1395, US Printing Office (Denver, USA). You can obtain your own copy of both by contacting the U.S. Geological Survey, Federal Center, Box 25425, Denver, CO 80225 USA. The mathematics of cartography have a long history, and the details are far trickier than the broad overview. For terrestrial (and, in general, planetary) cartography, the best reference datum is not a sphere but an oblate ellipsoid due to centrifugal force from the planet's rotation. Furthermore, because all rocky planets, including Earth, have randomly placed mass concentrations that affect the gravitational field, the reference gravitational isosurface (sea level on Earth) is even more complex than an ellipsoid and, in general, different ellipsoids have been used for different locations at the same time and for the same location at different times. The transformations in this package use a spherical datum and hence include global distortion at about the 0.5% level for terrestrial maps (Earth's oblateness is ~1/300). This is roughly equal to the dimensional precision of physical maps printed on paper (due to stretching and warping of the paper) but is significant at larger scales (e.g. for regional maps). If you need more precision than that, you will want to implement and use the ellipsoidal transformations from Snyder 1987 or another reference work on geodesy. A good name for that package would be C<...::Cartography::Geodetic>. =head1 GENERAL NOTES ON PERSPECTIVE AND SCIENTIFIC IMAGES Cartographic transformations are useful for interpretation of scientific images, as all cameras produce projections of the celestial sphere onto the focal plane of the camera. A simple (single-element) optical system with a planar focal plane generates L images -- that is to say, gnomonic projections of a portion of the celestial sphere near the paraxial direction. This is the projection that most consumer grade cameras produce. Magnification in an optical system changes the angle of incidence of the rays on the focal plane for a given angle of incidence at the aperture. For example, a 10x telescope with a 2 degree field of view exhibits the same gnomonic distortion as a simple optical system with a 20 degree field of view. Wide-angle optics typically have magnification less than 1 ('fisheye lenses'), reducing the gnomonic distortion considerably but introducing L<"equidistant azimuthal"|/t_az_eqd> distortion -- there's no such thing as a free lunch! Because many solar-system objects are spherical, PDL::Transform::Cartography includes perspective projections for producing maps of spherical bodies from perspective views. Those projections are L<"t_vertical"|/t_vertical> and L<"t_perspective"|/t_perspective>. They map between (lat,lon) on the spherical body and planar projected coordinates at the viewpoint. L<"t_vertical"|/t_vertical> is the vertical perspective projection given by Snyder, but L<"t_perspective"|/t_perspective> is a fully general perspective projection that also handles magnification correction. =head1 TRANSVERSE & OBLIQUE PROJECTIONS; STANDARD OPTIONS Oblique projections rotate the sphere (and graticule) to an arbitrary angle before generating the projection; transverse projections rotate the sphere exactly 90 degrees before generating the projection. Most of the projections accept the following standard options, useful for making transverse and oblique projection maps. =over 3 =item o, origin, Origin [default (0,0,0)] The origin of the oblique map coordinate system, in (old-theta, old-phi) coordinates. =item r, roll, Roll [default 0.0] The roll angle of the sphere about the origin, measured CW from (N = up) for reasonable values of phi and CW from (S = up) for unreasonable values of phi. This is equivalent to observer roll angle CCW from the same direction. =item u, unit, Unit [default 'degree'] This is the name of the angular unit to use in the lon/lat coordinate system. =item b, B The "B" angle of the body -- used for extraterrestrial maps. Setting this parameter is exactly equivalent to setting the phi component of the origin, and in fact overrides it. =item l,L The longitude of the central meridian as observed -- used for extraterrestrial maps. Setting this parameter is exactly equivalent to setting the theta component of the origin, and in fact overrides it. =item p,P The "P" (or position) angle of the body -- used for extraterrestrial maps. This parameter is a synonym for the roll angle, above. =item bad, Bad, missing, Missing [default nan] This is the value that missing points get. Mainly useful for the inverse transforms. (This should work fine if set to BAD, if you have bad-value support compiled in). The default nan is asin(1.2), calculated at load time. =back =head1 EXAMPLES Draw a Mercator map of the world on-screen: $w = pgwin(xs); $w->lines(earth_coast->apply(t_mercator)->clean_lines); Here, C returns a 3xn piddle containing (lon, lat, pen) values for the included world coastal outline; C converts the values to projected Mercator coordinates, and C breaks lines that cross the 180th meridian. Draw a Mercator map of the world, with lon/lat at 10 degree intervals: $w = pgwin(xs) $a = earth_coast()->glue(1,graticule(10,1)); $w->lines($a->apply(t_mercator)->clean_lines); This works just the same as the first example, except that a map graticule has been applied with interline spacing of 10 degrees lon/lat and inter-vertex spacing of 1 degree (so that each meridian contains 181 points, and each parallel contains 361 points). =head1 NOTES Currently angular conversions are rather simpleminded. A list of common conversions is present in the main constructor, which inserts a conversion constant to radians into the {params} field of the new transform. Something like Math::Convert::Units should be used instead to generate the conversion constant. A cleaner higher-level interface is probably needed (see the examples); for example, earth_coast could return a graticule if asked, instead of needing one to be glued on. The class structure is somewhat messy because of the varying needs of the different transformations. PDL::Transform::Cartography is a base class that interprets the origin options and sets up the basic machinery of the Transform. The conic projections have their own subclass, PDL::Transform::Conic, that interprets the standard parallels. Since the cylindrical and azimuthal projections are pretty simple, they are not subclassed. The perl 5.6.1 compiler is quite slow at adding new classes to the structure, so it does not makes sense to subclass new transformations merely for the sake of pedantry. =head1 AUTHOR Copyright 2002, Craig DeForest (deforest@boulder.swri.edu). This module may be modified and distributed under the same terms as PDL itself. The module comes with NO WARRANTY. The included digital world map is derived from the 1987 CIA World Map, translated to ASCII in 1988 by Joe Dellinger (geojoe@freeusp.org) and simplified in 1995 by Kirk Johnson (tuna@indra.com) for the program XEarth. The map comes with NO WARRANTY. An ASCII version of the map, and a sample PDL function to read it, may be found in the Demos subdirectory of the PDL source distribution. =head1 FUNCTIONS The module exports both transform constructors ('t_') and some auxiliary functions (no leading 't_'). =cut # Import PDL::Transform into the calling package -- the cartography # stuff isn't much use without it. use PDL::Transform; package PDL::Transform::Cartography; use PDL::Core ':Internal'; # Load 'topdl' (internal routine) @ISA = ( 'Exporter','PDL::Transform' ); our $VERSION = "0.6"; $VERSION = eval $VERSION; BEGIN { use Exporter (); @EXPORT_OK = qw(graticule earth_image earth_coast clean_lines t_unit_sphere t_orthographic t_rot_sphere t_caree t_mercator t_utm t_sin_lat t_sinusoidal t_conic t_albers t_lambert t_stereographic t_gnomonic t_az_eqd t_az_eqa t_vertical t_perspective t_hammer t_aitoff); @EXPORT = @EXPORT_OK; %EXPORT_TAGS = (Func=>[@EXPORT_OK]); } use PDL; use PDL::Transform; use PDL::MatrixOps; use PDL::NiceSlice; use Carp; ############################## # Steal _opt from PDL::Transform. *PDL::Transform::Cartography::_opt = \&PDL::Transform::_opt; use overload '""' => \&_strval; use strict; our $PI = $PDL::Transform::PI; our $DEG2RAD = $PDL::Transform::DEG2RAD; our $RAD2DEG = $PDL::Transform::RAD2DEG; sub _strval { my($me) = shift; $me->stringify(); } ###################################################################### =head2 graticule =for usage $lonlatp = graticule(,); $lonlatp = graticule(,,1); =for ref (Cartography) PDL constructor - generate a lat/lon grid. Returns a grid of meridians and parallels as a list of vectors suitable for sending to L for plotting. The grid is in degrees in (theta, phi) coordinates -- this is (E lon, N lat) for terrestrial grids or (RA, dec) for celestial ones. You must then transform the graticule in the same way that you transform the map. You can attach the graticule to a vector map using the syntax: $out = graticule(10,2)->glue(1,$map); In array context you get back a 2-element list containing a piddle of the (theta,phi) pairs and a piddle of the pen values (1 or 0) suitable for calling L. In scalar context the two elements are combined into a single piddle. The pen values associated with the graticule are negative, which will cause L to plot them as hairlines. If a third argument is given, it is a hash of options, which can be: =over 3 =item nan - if true, use two columns instead of three, and separate lines with a 'nan' break =item lonpos - if true, all reported longitudes are positive (0 to 360) instead of (-180 to 180). =item dup - if true, the meridian at the far boundary is duplicated. =back =cut sub graticule { my $grid = shift; my $step = shift; my $hash = shift; $hash = {} unless defined($hash); # avoid // for ancient compatibility my $two_cols = $hash->{nan} || 0; my $lonpos = $hash->{lonpos} || 0; my $dup = $hash->{dup} || 0; $grid = 10 unless defined($grid); $grid = $grid->at(0) if(ref($grid) eq 'PDL'); $step = $grid/2 unless defined($step); $step = $step->at(0) if(ref($step) eq 'PDL'); # Figure number of parallels and meridians my $np = 2 * int(90/$grid); my $nm = 2 * int(180/$grid); # First do parallels. my $xp = xvals(360/$step + 1 + !!$two_cols, $np + 1) * $step - 180 * (!$lonpos); my $yp = yvals(360/$step + 1 + !!$two_cols, $np + 1) * 180/$np - 90; $xp->(-1,:) .= $yp->(-1,:) .= asin(pdl(1.1)) if($two_cols); # Next do meridians. my $xm = yvals( 180/$step + 1 + !!$two_cols, $nm + !!$dup ) * 360/$nm - 180 * (!$lonpos); my $ym = xvals( 180/$step + 1 + !!$two_cols, $nm + !!$dup ) * $step - 90; $xm->(-1,:) .= $ym->(-1,:) .= asin(pdl(1.1)) if($two_cols); if($two_cols) { return pdl( $xp->flat->append($xm->flat), $yp->flat->append($ym->flat) )->mv(1,0); } else { our $pp = (zeroes($xp)-1); $pp->((-1)) .= 0; our $pm = (zeroes($xm)-1); $pm->((-1)) .= 0; if(wantarray) { return ( pdl( $xp->flat->append($xm->flat), $yp->flat->append($ym->flat) )->mv(1,0), $pp->flat->append($pm->flat) ); } else { return pdl( $xp->flat->append($xm->flat), $yp->flat->append($ym->flat), $pp->flat->append($pm->flat) )->mv(1,0); } barf "This can't happen"; } } =head2 earth_coast =for usage $a = earth_coast() =for ref (Cartography) PDL constructor - coastline map of Earth Returns a vector coastline map based on the 1987 CIA World Coastline database (see author information). The vector coastline data are in plate caree format so they can be converted to other projections via the L method and cartographic transforms, and are suitable for plotting with the L method in the PGPLOT output library: the first dimension is (X,Y,pen) with breaks having a pen value of 0 and hairlines having negative pen values. The second dimension threads over all the points in the data set. The vector map includes lines that pass through the antipodean meridian, so if you want to plot it without reprojecting, you should run it through L first: $w = pgwin(); $w->lines(earth_coast->clean_lines); # plot plate caree map of world $w->lines(earth_coast->apply(t_gnomonic))# plot gnomonic map of world C is just a quick-and-dirty way of loading the file "earth_coast.vec.fits" that is part of the normal installation tree. =cut sub earth_coast { my $fn = "PDL/Transform/Cartography/earth_coast.vec.fits"; local $_; foreach(@INC) { my $file = "$_/$fn"; return rfits($file) if(-e $file); } barf("earth_coast: $fn not found in \@INC.\n"); } =head2 earth_image =for usage $rgb = earth_image() =for ref (Cartography) PDL constructor - RGB pixel map of Earth Returns an RGB image of Earth based on data from the MODIS instrument on the NASA EOS/Terra satellite. (You can get a full-resolution image from L). The image is a plate caree map, so you can convert it to other projections via the L method and cartographic transforms. This is just a quick-and-dirty way of loading the earth-image files that are distributed along with PDL. =cut sub earth_image { my($nd) = shift; my $f; my $dir = "PDL/Transform/Cartography/earth_"; $f = ($nd =~ m/^n/i) ? "${dir}night.jpg" : "${dir}day.jpg"; local $_; my $im; my $found = 0; foreach(@INC) { my $file = "$_/$f"; if(-e $file) { $found = 1; $im = rpic($file)->mv(0,-1); } last if defined($im); } barf("earth_image: $f not found in \@INC\n") unless defined($found); barf("earth_image: couldn't load $f; you may need to install netpbm.\n") unless defined($im); my $h = $im->fhdr; $h->{SIMPLE} = 'T'; $h->{NAXIS} = 3; $h->{NAXIS1}=2048; $h->{CRPIX1}=1024.5; $h->{CRVAL1}=0; $h->{NAXIS2}=1024; $h->{CRPIX2}=512.5; $h->{CRVAL2}=0; $h->{NAXIS3}=3, $h->{CRPIX3}=1; $h->{CRVAL3}=0; $h->{CTYPE1}='Longitude'; $h->{CUNIT1}='degrees'; $h->{CDELT1}=180/1024.0; $h->{CTYPE2}='Latitude'; $h->{CUNIT2}='degrees'; $h->{CDELT2}=180/1024.0; $h->{CTYPE3}='RGB'; $h->{CUNIT3}='index'; $h->{CDELT3}=1.0; $h->{COMMENT}='Plate Caree Projection'; $h->{HISTORY}='PDL Distribution Image, derived from NASA/MODIS data', $im->hdrcpy(1); $im; } =head2 clean_lines =for usage $a = clean_lines(t_mercator->apply(scalar(earth_coast()))); $a = clean_lines($line_pen, [threshold]); $a = $lines->clean_lines; =for ref (Cartography) PDL method - remove projection irregularities C massages vector data to remove jumps due to singularities in the transform. In the first (scalar) form, C<$line_pen> contains both (X,Y) points and pen values suitable to be fed to L: in the second (list) form, C<$lines> contains the (X,Y) points and C<$pen> contains the pen values. C assumes that all the outline polylines are local -- that is to say, there are no large jumps. Any jumps larger than a threshold size are broken by setting the appropriate pen values to 0. The C parameter sets the relative size of the largest jump, relative to the map range (as determined by a min/max operation). The default size is 0.1. NOTES This almost never catches stuff near the apex of cylindrical maps, because the anomalous vectors get arbitrarily small. This could be improved somewhat by looking at individual runs of the pen and using a relative length scale that is calibrated to the rest of each run. it is probably not worth the computational overhead. =cut *PDL::clean_lines = \&clean_lines; sub clean_lines { my($lines) = shift; my($a) = shift; my($b) = shift; my($l,$p,$th); $th = 0.1; if(defined($b)) { # separate case with thresh $l = $lines; $p = $a->is_inplace?$a:$a->copy; $th = $b; } else { if(!defined($a)) { # duplex case no thresh $l = $lines->(0:1); $p = $lines->is_inplace ? $lines->((2)) : $lines->((2))->sever; } elsif(UNIVERSAL::isa($a,'PDL') && $lines->((0))->nelem == $a->nelem) { # Separate case no thresh $l = $lines; $p = $a->is_inplace ? $a : $a->copy;; } else { # duplex case with thresh $l = $lines->(0:1); $p = $lines->is_inplace ? $lines->((2)) : $lines->((2))->sever; $th = $a; } } my $pok = (($p != 0) & isfinite($p)); # Kludge to work around minmax bug (nans confuse it!) my($l0) = $l->((0)); my($x0,$x1) = $l0->where(isfinite($l0) & $pok)->minmax; my($xth) = abs($x1-$x0) * $th; my($l1) = $l->((1)); ($x0,$x1) = $l1->where(isfinite($l1) & $pok)->minmax; my($yth) = abs($x1-$x0) * $th; my $diff = abs($l->(:,1:-1) - $l->(:,0:-2)); $diff->where(!isfinite($diff)) .= 2*($xth + $yth); $p->where(($diff->((0)) > $xth) | ($diff->((1)) > $yth)) .= 0; if(wantarray){ return($l,$p); } else { return $l->append($p->dummy(0,1)); } } ###################################################################### ### # Units parser # Get unit, return conversion factor to radii, or undef if no match found. # sub _uconv{ ### # Replace this with a more general units resolver call! ### local($_) = shift; my($silent) =shift; my($a) = ( m/^deg/i ? $DEG2RAD : m/^arcmin/i ? $DEG2RAD / 60 : m/^arcsec/i ? $DEG2RAD / 3600 : m/^hour/i ? $DEG2RAD * 15 : # Right ascension m/^min/i ? $DEG2RAD * 15/60 : # Right ascension m/^microrad/i ? 1e-6 : m/^millirad/i ? 1e-3 : m/^rad(ian)?s?$/i ? 1.0 : m/^meter/ ? 1.0/6371000 : # Assuming Earth cartography! m/^kilometer/ ? 1.0/6371 : m/^km/ ? 1.0/6371 : m/^Mm/ ? 1.0/6.371 : m/^mile/ ? 1.0/(637100000/2.54/12/5280) : undef ); print STDERR "Cartography: unrecognized unit '$_'\n" if( (!defined $a) && !$silent && ($PDL::debug || $PDL::verbose)); $a; } ### # # Cartography general constructor -- called by the individual map # constructors. Not underscored because it's certainly OK to call from # outside -- but the *last* argument is the name of the transform. # # The options list is put into the {options} field of the newly constructed # Transform -- fastidious subclass constructors will want to delete it before # returning. # sub _new { new('PDL::Transform::Cartography',@_); } # not exported sub new { my($class) = shift; my($name) = pop; my($o) = $_[0]; $o = {@_} unless(ref $o eq 'HASH'); my($me) = PDL::Transform::new($class); $me->{idim} = $me->{odim} = 2; $me->{name} = $name; #### # Parse origin and units arguments # my $or = _opt($o,['o','origin','Origin'],zeroes(2)); if($or->nelem != 2) { croak("PDL::Transform::Cartography: origin must have 2 elements\n"); } my($l) = _opt($o,['l','L']); my($b) = _opt($o,['b','B']); $or->(0) .= $l if defined($l); $or->(1) .= $b if defined($b); my $roll = topdl(_opt($o,['r','roll','Roll','P'],0)); my $unit = _opt($o,['u','unit','Unit'],'degrees'); $me->{params}->{conv} = my $conv = _uconv($unit); $me->{params}->{u} = $unit; $me->{itype} = ['longitude','latitude']; $me->{iunit} = [$me->{params}->{u},$me->{params}->{u}]; my($ou) = _opt($o,['ou','ounit','OutputUnit'],undef); $me->{params}->{ou} = $ou; if(defined $ou) { if(!(ref $ou)) { $me->{params}->{oconv} = _uconv($ou); } else { my @oconv; map {push(@oconv,_uconv($_))} @$ou; $me->{params}->{oconv} = topdl([@oconv]); } } else { $me->{params}->{oconv} = undef; } $me->{ounit} = $me->{params}->{ou}; $me->{params}->{o} = $or * $conv; $me->{params}->{roll} = $roll * $conv; $me->{params}->{bad} = _opt($o,['b','bad','Bad','missing','Missing'], asin(pdl(1.1))); # Get the standard parallel (in general there's only one; the conics # have two but that's handled by _c_new) $me->{params}->{std} = topdl(_opt($me->{options}, ['s','std','standard','Standard'], 0))->at(0) * $me->{params}->{conv}; $me->{options} = $o; $me; } # Compose self with t_rot_sphere if necessary -- useful for # finishing off the transformations that accept the origin and roll # options. sub PDL::Transform::Cartography::_finish { my($me) = shift; if( ($me->{params}->{o}->(0) != 0) || ($me->{params}->{o}->(1) != 0) || ($me->{params}->{roll} != 0) ) { my $out = t_compose($me,t_rot_sphere($me->{options})); $out->{itype} = $me->{itype}; $out->{iunit} = $me->{iunit}; $out->{otype} = $me->{otype}; $out->{ounit} = $me->{ounit}; $out->{odim} = 2; $out->{idim} = 2; return $out; } return $me; } ###################################################################### =head2 t_unit_sphere =for usage $t = t_unit_sphere(); =for ref (Cartography) 3-D globe projection (conformal; authalic) This is similar to the inverse of L, but the inverse transform projects 3-D coordinates onto the unit sphere, yielding only a 2-D (lon/lat) output. Similarly, the forward transform deprojects 2-D (lon/lat) coordinates onto the surface of a unit sphere. The cartesian system has its Z axis pointing through the pole of the (lon,lat) system, and its X axis pointing through the equator at the prime meridian. Unit sphere mapping is unusual in that it is both conformal and authalic. That is possible because it properly embeds the sphere in 3-space, as a notional globe. This is handy as an intermediate step in lots of transforms, as Cartesian 3-space is cleaner to work with than spherical 2-space. Higher dimensional indices are preserved, so that "rider" indices (such as pen value) are propagated. There is no oblique transform for t_unit_sphere, largely because it's so easy to rotate the output using t_linear once it's out into Cartesian space. In fact, the other projections implement oblique transforms by L L with L. OPTIONS: =over 3 =item radius, Radius (default 1.0) The radius of the sphere, for the inverse transform. (Radius is ignored in the forward transform). Defaults to 1.0 so that the resulting Cartesian coordinates are in units of "body radii". =back =cut sub t_unit_sphere { my($me) = _new(@_,'Unit Sphere Projection'); $me->{odim} = 3; $me->{params}->{otype} = ['X','Y','Z']; $me->{params}->{ounit} = ['body radii','body radii','body radii']; $me->{params}->{r} = topdl(_opt($me->{options}, ['r','radius','Radius'], 1.0) )->at(0); $me->{func} = sub { my($d,$o) = @_; my(@dims) = $d->dims; $dims[0] ++; my $out = zeroes(@dims); my($thetaphi) = ((defined $o->{conv} && $o->{conv} != 1.0) ? $d->(0:1) * $o->{conv} : $d->(0:1) ); my $th = $thetaphi->((0)); my $ph = $thetaphi->((1)); # use x as a holding tank for the cos-phi multiplier $out->((0)) .= $o->{r} * cos($ph) ; $out->((1)) .= $out->((0)) * sin($th); $out->((0)) *= cos($th); $out->((2)) .= $o->{r} * sin($ph); if($d->dim(0) > 2) { $out->(3:-1) .= $d->(2:-1); } $out; }; $me->{inv} = sub { my($d,$o) = @_; my($d0,$d1,$d2) = ($d->((0)),$d->((1)),$d->((2))); my($r) = sqrt(($d->(0:2)*$d->(0:2))->sumover); my(@dims) = $d->dims; $dims[0]--; my($out) = zeroes(@dims); $out->((0)) .= atan2($d1,$d0); $out->((1)) .= asin($d2/$r); if($d->dim(0) > 3) { $out->(2:-1) .= $d->(3:-1); } $out->(0:1) /= $o->{conv} if(defined $o->{conv} && $o->{conv} != 1.0); $out; }; $me; } ###################################################################### =head2 t_rot_sphere =for usage $t = t_rot_sphere({origin=>[,],roll=>[]}); =for ref (Cartography) Generate oblique projections You feed in the origin in (theta,phi) and a roll angle, and you get back out (theta', phi') coordinates. This is useful for making oblique or transverse projections: just compose t_rot_sphere with your favorite projection and you get an oblique one. Most of the projections automagically compose themselves with t_rot_sphere if you feed in an origin or roll angle. t_rot_sphere converts the base plate caree projection (straight lon, straight lat) to a Cassini projection. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =back =cut # helper routine for making the rotation matrix sub _rotmat { my($th,$ph,$r) = @_; pdl( [ cos($th) , -sin($th), 0 ], # apply theta [ sin($th) , cos($th), 0 ], [ 0, 0, 1 ] ) x pdl( [ cos($ph), 0, -sin($ph) ], # apply phi [ 0, 1, 0 ], [ sin($ph), 0, cos($ph) ] ) x pdl( [ 1, 0 , 0 ], # apply roll last [ 0, cos($r), -sin($r) ], [ 0, sin($r), cos($r) ]) ; } sub t_rot_sphere { my($me) = _new(@_,'Spherical rotation'); my($th,$ph) = $me->{params}->{o}->list; my($r) = $me->{params}->{roll}->at(0); my($rotmat) = _rotmat($th,$ph,$r); my $out = t_wrap( t_linear(m=>$rotmat, d=>3), t_unit_sphere()); $out->{itype} = $me->{itype}; $out->{iunit} = $me->{iunit}; $out->{otype} = ['rotated longitude','rotated latitude']; $out->{ounit} = $me->{iunit}; $out; } ###################################################################### =head2 t_orthographic =for usage $t = t_orthographic(); =for ref (Cartography) Ortho. projection (azimuthal; perspective) This is a perspective view as seen from infinite distance. You can specify the sub-viewer point in (lon,lat) coordinates, and a rotation angle of the map CW from (north=up). This is equivalent to specify viewer roll angle CCW from (north=up). t_orthographic is a convenience interface to t_unit_sphere -- it is implemented as a composition of a t_unit_sphere call, a rotation, and a slice. [*] In the default case where the near hemisphere is mapped, the inverse exists. There is no single inverse for the whole-sphere case, so the inverse transform superimposes everything on a single hemisphere. If you want an invertible 3-D transform, you want L. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item m, mask, Mask, h, hemisphere, Hemisphere [default 'near'] The hemisphere to keep in the projection (see L). =back NOTES Alone of the various projections, this one does not use L to handle the standard options, because the cartesian coordinates of the rotated sphere are already correctly projected -- t_rot_sphere would put them back into (theta', phi') coordinates. =cut sub t_orthographic { my($me) = _new(@_,'Orthographic Projection'); $me->{otype} = ['projected X','projected Y']; $me->{ounit} = ['body radii','body radii']; my $m= _opt($me->{options}, ['m','mask','Mask','h','hemi','hemisphere','Hemisphere'], 1); if($m=~m/^b/i) { $me->{params}->{m} = 0; } elsif($m=~m/^n/i) { $me->{params}->{m} = 1; } elsif($m=~m/^f/i) { $me->{params}->{m} = 2; } else { $me->{params}->{m} = $m; } my $origin= $me->{params}->{o} * $RAD2DEG; my $roll = $me->{params}->{roll} * $RAD2DEG; $me->{params}->{t_int} = t_compose( t_linear(rot=>[90 - $origin->at(1), 0, 90 + $origin->at(0)], d=>3), t_unit_sphere(u=>$me->{params}->{u}) ); $me->{params}->{t_int} = t_compose( t_linear(rot=>[0,0,$roll->at(0)],d=>3), $me->{params}->{t_int} ) if($roll->at(0)); $me->{name} = "orthographic"; $me->{idim} = 2; $me->{odim} = 2; $me->{func} = sub { my ($d,$o) = @_ ; my ($out) = $o->{t_int}->apply($d); if($o->{m}) { my $idx; $idx = whichND($out->((2)) < 0) if($o->{m} == 1); $idx = whichND($out->((2)) > 0) if($o->{m} == 2); if(defined $idx && ref $idx eq 'PDL' && $idx->nelem){ $out->((0))->range($idx) .= $o->{bad}; $out->((1))->range($idx) .= $o->{bad}; } } my($d0) = $out->dim(0); # Remove the Z direction ($d0 > 3) ? $out->(pdl(0,1,3..$d0-1)) : $out->(0:1); }; # This is slow to run, quick to code -- could be made better by # having its own 2-d inverse instead of calling the internal one. $me->{inv} = sub { my($d,$o) = @_; my($d1) = $d->(0:1); my(@dims) = $d->dims; $dims[0]++; my($out) = zeroes(@dims); $out->(0:1) .= $d1; $out->(3:-1) .= $d->(2:-1) if($dims[0] > 3); $out->((2)) .= sqrt(1 - ($d1*$d1)->sumover); $out->((2)) *= -1 if($o->{m} == 2); $o->{t_int}->invert($out); }; $me; } ###################################################################### =head2 t_caree =for usage $t = t_caree(); =for ref (Cartography) Plate Caree projection (cylindrical; equidistant) This is the simple Plate Caree projection -- also called a "lat/lon plot". The horizontal axis is theta; the vertical axis is phi. This is a no-op if the angular unit is radians; it is a simple scale otherwise. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item s, std, standard, Standard (default 0) The standard parallel where the transformation is conformal. Conformality is achieved by shrinking of the horizontal scale to match the vertical scale (which is correct everywhere). =back =cut @PDL::Transform::Cartography::Caree::ISA = ('PDL::Transform::Cartography'); sub t_caree { my($me) = _new(@_,'Plate Caree Projection'); my $p = $me->{params}; $me->{otype} = ['projected longitude','latitude']; $me->{ounit} = ['proj. body radii','body radii']; $p->{stretch} = cos($p->{std}); $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) *= $o->{conv}; $out->(0) *= $p->{stretch}; $out; }; $me->{inv} = sub { my($d,$o)= @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) /= $o->{conv}; $out->(0) /= $p->{stretch}; $out; }; $me->_finish; } ###################################################################### =head2 t_mercator =for usage $t = t_mercator(); =for ref (Cartography) Mercator projection (cylindrical; conformal) This is perhaps the most famous of all map projections: meridians are mapped to parallel vertical lines and parallels are unevenly spaced horizontal lines. The poles are shifted to +/- infinity. The output values are in units of globe-radii for easy conversion to kilometers; hence the horizontal extent is -pi to pi. You can get oblique Mercator projections by specifying the C or C options; this is implemented via L. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item c, clip, Clip (default 75 [degrees]) The north/south clipping boundary of the transformation. Because the poles are displaced to infinity, many applications require a clipping boundary. The value is in whatever angular unit you set with the standard 'units' option. The default roughly matches interesting landforms on Earth. For no clipping at all, set b=>0. For asymmetric clipping, use a 2-element list ref or piddle. =item s, std, Standard (default 0) This is the parallel at which the map has correct scale. The scale is also correct at the parallel of opposite sign. =back =cut @PDL::Transform::Cartography::Mercator::ISA = ('PDL::Transform::Cartography'); sub t_mercator { my($me) = _new(@_,'Mercator Projection'); my $p = $me->{params}; # This is a lot of shenanigans just to get the clip parallels, but what the # heck -- it's not a hot spot and it saves copying the input data (for # nondestructive clipping). $p->{c} = _opt($me->{options}, ['c','clip','Clip'], undef); if(defined($p->{c})) { $p->{c} = topdl($p->{c}); $p->{c} *= $p->{conv}; } else { $p->{c} = pdl($DEG2RAD * 75); } $p->{c} = abs($p->{c}) * pdl(-1,1) if($p->{c}->nelem == 1); $p->{c} = log(tan(($p->{c}/2) + $PI/4)); $p->{c} = [$p->{c}->list]; $p->{std} = topdl(_opt($me->{options}, ['s','std','standard','Standard'], 0))->at(0) * $p->{conv}; if($p->{std} == 0) { $me->{otype} = ['longitude','tan latitude']; $me->{ounit} = ['radians',' '] unless(defined $me->{ounit}); } else { $me->{otype} = ['proj. longitude','proj. tan latitude']; $me->{ounit} = ['radians',' '] unless(defined $me->{ounit}); } $p->{stretch} = cos($p->{std}); $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) *= $o->{conv}; $out->((1)) .= log(tan($out->((1))/2 + $PI/4)); $out->((1)) .= $out->((1))->clip(@{$o->{c}}) unless($o->{c}->[0] == $o->{c}->[1]); $out->(0:1) *= $o->{stretch}; $out->(0:1) /= $o->{oconv} if(defined $o->{oconv}); $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace? $d : $d->copy; $out->(0:1) *= $o->{oconv} if defined($o->{oconv}); $out->(0:1) /= $o->{stretch}; $out->((1)) .= (atan(exp($out->((1)))) - $PI/4)*2; $out->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_utm =for usage $t = t_utm(,); =for ref (Cartography) Universal Transverse Mercator projection (cylindrical) This is the internationally used UTM projection, with 2 subzones (North/South). The UTM zones are parametrized individually, so if you want a Zone 30 map you should use C. By default you get the northern subzone, so that locations in the southern hemisphere get negative Y coordinates. If you select the southern subzone (with the "subzone=>-1" option), you get offset southern UTM coordinates. The 20-subzone military system is not yet supported. If/when it is implemented, you will be able to enter "subzone=>[a-t]" to select a N/S subzone. Note that UTM is really a family of transverse Mercator projections with different central meridia. Each zone properly extends for six degrees of longitude on either side of its appropriate central meridian, with Zone 1 being centered at -177 degrees longitude (177 west). Properly speaking, the zones only extend from 80 degrees south to 84 degrees north; but this implementation lets you go all the way to 90 degrees. The default UTM coordinates are meters. The origin for each zone is on the equator, at an easting of -500,000 meters. The default output units are meters, assuming that you are wanting a map of the Earth. This will break for bodies other than Earth (which have different radii and hence different conversions between lat/lon angle and meters). The standard UTM projection has a slight reduction in scale at the prime meridian of each zone: the transverse Mercator projection's standard "parallels" are 180km e/w of the central meridian. However, many Europeans prefer the "Gauss-Kruger" system, which is virtually identical to UTM but with a normal tangent Mercator (standard parallel on the prime meridian). To get this behavior, set "gk=>1". Like the rest of the PDL::Transform::Cartography package, t_utm uses a spherical datum rather than the "official" ellipsoidal datums for the UTM system. This implementation was derived from the rather nice description by Denis J. Dean, located on the web at: http://www.cnr.colostate.edu/class_info/nr502/lg3/datums_coordinates/utm.html OPTIONS =over 3 =item STANDARD OPTIONS (No positional options -- Origin and Roll are ignored) =item ou, ounit, OutputUnit (default 'meters') (This is likely to become a standard option in a future release) The unit of the output map. By default, this is 'meters' for UTM, but you may specify 'deg' or 'km' or even (heaven help us) 'miles' if you prefer. =item sz, subzone, SubZone (default 1) Set this to -1 for the southern hemisphere subzone. Ultimately you should be able to set it to a letter to get the corresponding military subzone, but that's too much effort for now. =item gk, gausskruger (default 0) Set this to 1 to get the (European-style) tangent-plane Mercator with standard parallel on the prime meridian. The default of 0 places the standard parallels 180km east/west of the prime meridian, yielding better average scale across the zone. Setting gk=>1 makes the scale exactly 1.0 at the central meridian, and >1.0 everywhere else on the projection. The difference in scale is about 0.3%. =back =cut sub t_utm { my $zone = (int(shift)-1) % 60 + 1; my($a) = _new(@_,"UTM-$zone"); my $opt = $a->{options}; ## Make sure that there is a conversion (default is 'meters') $a->{ounit} = ['meter','meter'] unless defined($a->{ounit}); $a->{ounit} = [$a->{ounit},$a->{ounit}] unless ref($a->{ounit}); $a->{params}->{oconv} = _uconv($a->{ounit}->[0]); ## Define our zone and NS offset my $subzone = _opt($opt,['sz', 'subzone', 'SubZone'],1); my $offset = zeroes(2); $offset->(0) .= 5e5*(2*$PI/40e6)/$a->{params}->{oconv}; $offset->(1) .= ($subzone < 0) ? $PI/2/$a->{params}->{oconv} : 0; my $merid = ($zone * 6) - 183; my $gk = _opt($opt,['gk','gausskruger'],0); my($me) = t_compose(t_linear(post=>$offset, rot=>-90 ), t_mercator(o=>[$merid,0], r=>90, ou=>$a->{ounit}, s=>$gk ? 0 : ($RAD2DEG * (180/6371)) ) ); my $s = ($zone < 0) ? "S Hemisphere " : ""; $me->{otype} = ["UTM-$zone Easting","${s}Northing"]; $me->{ounit} = $a->{ounit}; return $me; } ###################################################################### =head2 t_sin_lat =for usage $t = t_sin_lat(); =for ref (Cartography) Cyl. equal-area projection (cyl.; authalic) This projection is commonly used in solar Carrington plots; but not much for terrestrial mapping. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item s,std, Standard (default 0) This is the parallel at which the map is conformal. It is also conformal at the parallel of opposite sign. The conformality is achieved by matched vertical stretching and horizontal squishing (to achieve constant area). =back =cut @PDL::Transform::Cartography::SinLat::ISA = ('PDL::Transform::Cartography'); sub t_sin_lat { my($me) = _new(@_,"Sine-Latitude Projection"); $me->{params}->{std} = topdl(_opt($me->{options}, ['s','std','standard','Standard'], 0))->at(0) * $me->{params}->{conv}; if($me->{params}->{std} == 0) { $me->{otype} = ['longitude','sin latitude']; $me->{ounit} = ['radians',' ']; # nonzero but blank! } else { $me->{otype} = ['proj. longitude','proj. sin latitude']; $me->{ounit} = ['radians',' ']; } $me->{params}->{stretch} = sqrt(cos($me->{params}->{std})); $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) *= $me->{params}->{conv}; $out->((1)) .= sin($out->((1))) / $o->{stretch}; $out->((0)) *= $o->{stretch}; $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->((1)) .= asin($out->((1)) * $o->{stretch}); $out->((0)) /= $o->{stretch}; $out->(0:1) /= $me->{params}->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_sinusoidal =for usage $t = t_sinusoidal(); =for ref (Cartography) Sinusoidal projection (authalic) Sinusoidal projection preserves the latitude scale but scales longitude according to sin(lat); in this respect it is the companion to L, which is also authalic but preserves the longitude scale instead. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =back =cut sub t_sinusoidal { my($me) = _new(@_,"Sinusoidal Projection"); $me->{otype} = ['longitude','latitude']; $me->{ounit} = [' ','radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) *= $o->{conv}; $out->((0)) *= cos($out->((1))); $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $out->((0)); my($y) = $out->((1)); $x /= cos($out->((1))); my($rej) = ( (abs($x)>$PI) | (abs($y)>($PI/2)) )->flat; $x->flat->($rej) .= $o->{bad}; $y->flat->($rej) .= $o->{bad}; $out->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### # # Conic projections are subclassed for easier stringification and # parsing of the standard parallels. The constructor gets copied # into the current package for ease of hackage. # # This is a little kludgy -- it's intended for direct calling # rather than method calling, and it puts its own class name on the # front of the argument list. But, hey, it works... # @PDL::Transform::Cartography::Conic::ISA = ('PDL::Transform::Cartography'); sub _c_new { my($def_std) = pop; my($me) = new('PDL::Transform::Cartography::Conic',@_); my($p) = $me->{params}; $p->{std} = _opt($me->{options},['s','std','standard','Standard'], $def_std); $p->{std} = topdl($p->{std}) * $me->{params}->{conv}; $p->{std} = topdl([$PI/2 * ($p->{std}<0 ? -1 : 1), $p->{std}->at(0)]) if($p->{std}->nelem == 1); $me->{params}->{cylindrical} = 1 if(approx($p->{std}->(0),-$p->{std}->(1))); $me; } sub PDL::Transform::Cartography::Conic::stringify { my($me) = shift; my($out) = $me->SUPER::stringify; $out .= sprintf("\tStd parallels: %6.2f,%6.2f %s\n", $me->{params}->{std}->at(0) / $me->{params}->{conv}, $me->{params}->{std}->at(1) / $me->{params}->{conv}, $me->{params}->{u}); $out; } ###################################################################### =head2 t_conic =for usage $t = t_conic() =for ref (Cartography) Simple conic projection (conic; equidistant) This is the simplest conic projection, with parallels mapped to equidistant concentric circles. It is neither authalic nor conformal. This transformation is also referred to as the "Modified Transverse Mercator" projection in several maps of Alaska published by the USGS; and the American State of New Mexico re-invented the projection in 1936 for an official map of that State. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item s, std, Standard (default 29.5, 45.5) The locations of the standard parallel(s) (where the cone intersects the surface of the sphere). If you specify only one then the other is taken to be the nearest pole. If you specify both of them to be one pole then you get an equidistant azimuthal map. If you specify both of them to be opposite and equidistant from the equator you get a Plate Caree projection. =back =cut sub t_conic { my($me) = _c_new(@_,"Simple Conic Projection",[29.5,45.5]); my($p) = $me->{params}; if($p->{cylindrical}) { print STDERR "Simple conic: degenerate case; using Plate Caree\n" if($PDL::verbose); return t_caree($me->{options}); } $p->{n} = ((cos($p->{std}->((0))) - cos($p->{std}->((1)))) / ($p->{std}->((1)) - $p->{std}->((0)))); $p->{G} = cos($p->{std}->((0)))/$p->{n} + $p->{std}->((0)); $me->{otype} = ['Conic X','Conic Y']; $me->{ounit} = ['Proj. radians','Proj. radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($rho) = $o->{G} - $d->((1)) * $o->{conv}; my($theta) = $o->{n} * $d->((0)) * $o->{conv}; $out->((0)) .= $rho * sin($theta); $out->((1)) .= $o->{G} - $rho * cos($theta); $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $d->((0)); my($y) = $o->{G} - $d->((1)); my($rho) = sqrt($x*$x + $y*$y); $rho *= -1 if($o->{n}<0); my($theta) = ($o->{n} < 0) ? atan2(-$x,-$y) : atan2($x,$y); $out->((1)) .= $o->{G} - $rho; $out->((1))->where(($out->((1)) < -$PI/2) | ($out->((1)) > $PI/2)) .= $o->{bad}; $out->((0)) .= $theta / $o->{n}; $out->((0))->where(($out->((0)) < -$PI) | ($out->((0)) > $PI/2)) .= $o->{bad}; $out->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_albers =for usage $t = t_albers() =for ref (Cartography) Albers conic projection (conic; authalic) This is the standard projection used by the US Geological Survey for sectionals of the 50 contiguous United States of America. The projection reduces to the Lambert equal-area conic (infrequently used and not to be confused with the Lambert conformal conic, L!) if the pole is used as one of the two standard parallels. Notionally, this is a conic projection onto a cone that intersects the sphere at the two standard parallels; it works best when the two parallels straddle the region of interest. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item s, std, standard, Standard (default (29.5,45.5)) The locations of the standard parallel(s). If you specify only one then the other is taken to be the nearest pole and a Lambert Equal-Area Conic map results. If you specify both standard parallels to be the same pole, then the projection reduces to the Lambert Azimuthal Equal-Area map as aq special case. (Note that L is Lambert's Conformal Conic, the most commonly used of Lambert's projections.) The default values for the standard parallels are those chosen by Adams for maps of the lower 48 US states: (29.5,45.5). The USGS recommends (55,65) for maps of Alaska and (8,18) for maps of Hawaii -- these latter are chosen to also include the Canal Zone and Philippine Islands farther south, which is why both of those parallels are south of the Hawaiian islands. The transformation reduces to the cylindrical equal-area (sin-lat) transformation in the case where the standard parallels are opposite and equidistant from the equator, and in fact this is implemented by a call to t_sin_lat. =back =cut sub t_albers { my($me) = _c_new(@_,"Albers Equal-Area Conic Projection",[29.5,45.5]); my($p) = $me->{params}; if($p->{cylindrical}) { print STDERR "Albers equal-area conic: degenerate case; using equal-area cylindrical\n" if($PDL::verbose); return t_sin_lat($me->{options}); } $p->{n} = sin($p->{std})->sumover / 2; $p->{C} = (cos($p->{std}->((1)))*cos($p->{std}->((1))) + 2 * $p->{n} * sin($p->{std}->((1))) ); $p->{rho0} = sqrt($p->{C}) / $p->{n}; $me->{otype} = ['Conic X','Conic Y']; $me->{ounit} = ['Proj. radians','Proj. radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($rho) = sqrt( $o->{C} - 2 * $o->{n} * sin($d->((1)) * $o->{conv}) ) / $o->{n}; my($theta) = $o->{n} * $d->((0)) * $o->{conv}; $out->((0)) .= $rho * sin($theta); $out->((1)) .= $p->{rho0} - $rho * cos($theta); $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $d->((0)); my($y) = $o->{rho0} - $d->((1)); my($theta) = ($o->{n} < 0) ? atan2 -$x,-$y : atan2 $x, $y; my($rho) = sqrt( $x*$x + $y*$y ) * $o->{n}; $out->((1)) .= asin( ( $o->{C} - ( $rho * $rho ) ) / (2 * $o->{n}) ); $out->((0)) .= $theta / $o->{n}; $out->((0))->where(($out->((0))>$PI) | ($out->((0))<-$PI)) .= $o->{bad}; $out->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_lambert =for usage $t = t_lambert(); =for ref (Cartography) Lambert conic projection (conic; conformal) Lambert conformal conic projection is widely used in aeronautical charts and state base maps published by the USA's FAA and USGS. It's especially useful for mid-latitude charts. In particular, straight lines approximate (but are not exactly) great circle routes of up to ~2 radians. The default standard parallels are 33 and 45 to match the USGS state 1:500,000 base maps of the United States. At scales of 1:500,000 and larger, discrepancies between the spherical and ellipsoidal projections become important; use care with this projection on spheres. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item s, std, standard, Standard (default (33,45)) The locations of the standard parallel(s) for the conic projection. The transform reduces to the Mercator projection in the case where the standard parallels are opposite and equidistant from the equator, and in fact this is implemented by a call to t_mercator. =item c, clip, Clip (default [-75,75]) Because the transform is conformal, the distant pole is displaced to infinity. Many applications require a clipping boundary. The value is in whatever angular unit you set with the standard 'unit' option. For consistency with L, clipping works the same way even though in most cases only one pole needs it. Set this to 0 for no clipping at all. =back =cut sub t_lambert { my($me)= _c_new(@_,"Lambert Conformal Conic Projection",[33,45]); my($p) = $me->{params}; if($p->{cylindrical}){ print STDERR "Lambert conformal conic: std parallels are opposite & equal; using Mercator\n" if($PDL::verbose); return t_mercator($me->{options}); } # Find clipping parallels $p->{c} = _opt($me->{options},['c','clip','Clip'],undef); if(defined($p->{c})) { $p->{c} = topdl($p->{c}); } else { $p->{c} = topdl([-75,75]); } $p->{c} = abs($p->{c}) * topdl([-1,1]) if($p->{c}->nelem == 1); $p->{c} = [$p->{c}->list]; # Prefrobnicate if(approx($p->{std}->((0)),$p->{std}->((1)))) { $p->{n} = sin($p->{std}->((0))); } else { $p->{n} = (log(cos($p->{std}->((0)))/cos($p->{std}->((1)))) / log( tan( $PI/4 + $p->{std}->((1))/2 ) / tan( $PI/4 + $p->{std}->((0))/2 ) ) ); } $p->{F} = ( cos($p->{std}->((0))) * ( tan( $PI/4 + $p->{std}->((0))/2 ) ** $p->{n} ) / $p->{n} ); $p->{rho0} = $p->{F}; $me->{otype} = ['Conic X','Conic Y']; $me->{ounit} = ['Proj. radians','Proj. radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($cl) = ( ($o->{c}->[0] == $o->{c}->[1]) ? $d->((1))*$o->{conv} : ($d->((1))->clip(@{$o->{c}}) * $o->{conv}) ); my($rho) = $o->{F} / ( tan($PI/4 + ($cl)/2 ) ** $o->{n} ); my($theta) = $o->{n} * $d->((0)) * $o->{conv}; $out->((0)) .= $rho * sin($theta); $out->((1)) .= $o->{rho0} - $rho * cos($theta); $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $d->((0)); my($y) = $o->{rho0} - $d->((1)); my($rho) = sqrt($x * $x + $y * $y); $rho *= -1 if($o->{n} < 0); my($theta) = ($o->{n} < 0) ? atan2(-$x,-$y):(atan2 $x,$y); $out->((0)) .= $theta / $o->{n}; $out->((0))->where(($out->((0)) > $PI) | ($out->((0)) < -$PI)) .= $o->{bad}; $out->((1)) .= 2 * atan(($o->{F}/$rho)**(1.0/$o->{n})) - $PI/2; $out->((1))->where(($out->((1)) > $PI/2) | ($out->((1)) < -$PI/2)) .= $o->{bad}; $out->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_stereographic =for usage $t = t_stereographic(); =for ref (Cartography) Stereographic projection (az.; conf.; persp.) The stereographic projection is a true perspective (planar) projection from a point on the spherical surface opposite the origin of the map. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item c, clip, Clip (default 120) This is the angular distance from the center to the edge of the projected map. The default 120 degrees gives you most of the opposite hemisphere but avoids the hugely distorted part near the antipodes. =back =cut sub t_stereographic { my($me) = _new(@_,"Stereographic Projection"); $me->{params}->{k0} = 1.0; $me->{params}->{c} = _opt($me->{options}, ['c','clip','Clip'], 120) * $me->{params}->{conv}; $me->{otype} = ['Stereo X','Stereo Y']; $me->{ounit} = ['Proj. body radii','Proj. radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($th,$ph) = ($out->((0)) * $o->{conv}, $out->((1)) * $o->{conv}); my($cph) = cos($ph); # gets re-used my($k) = 2 * $o->{k0} / (1 + cos($th) * $cph); $out->((0)) .= $k * $cph * sin($th); $out->((1)) .= $k * sin($ph); my($cl0) = 2*$o->{k0} / (1 + cos($o->{c})); $out->((0))->where($k>$cl0) .= $o->{bad}; $out->((1))->where($k>$cl0) .= $o->{bad}; $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $d->((0)); my($y) = $d->((1)); my($rho) = sqrt($x*$x + $y*$y); my($c) = 2 * atan2($rho,2*$o->{k0}); $out->((0)) .= atan2($x * sin($c), $rho * cos($c)); $out->((1)) .= asin($y * sin($c) / $rho); $out ->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_gnomonic =for usage $t = t_gnomonic(); =for ref (Cartography) Gnomonic (focal-plane) projection (az.; persp.) The gnomonic projection projects a hemisphere onto a tangent plane. It is useful in cartography for the property that straight lines are great circles; and it is useful in scientific imaging because it is the projection generated by a simple optical system with a flat focal plane. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item c, clip, Clip (default 75) This is the angular distance from the center to the edge of the projected map. The default 75 degrees gives you most of the hemisphere but avoids the hugely distorted part near the horizon. =back =cut sub t_gnomonic { my($me) = _new(@_,"Gnomonic Projection"); $me->{params}->{k0} = 1.0; # Useful for standard parallel (TBD: add one) $me->{params}->{c} = topdl(_opt($me->{options}, ['c','clip','Clip'], 75) * $me->{params}->{conv}); $me->{params}->{c} .= $me->{params}->{c}->clip(undef,(90-1e-6)*$me->{params}->{conv}); $me->{otype} = ['Tangent-plane X','Tangent-plane Y']; $me->{ounit} = ['Proj. radians','Proj. radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($th,$ph) = ($out->((0)) * $o->{conv}, $out->((1)) * $o->{conv}); my($cph) = cos($ph); # gets re-used my($k) = $o->{k0} / (cos($th) * $cph); my($cl0) = $o->{k0} / (cos($o->{c})); $out->((0)) .= $k * $cph * sin($th); $out->((1)) .= $k * sin($ph); my $idx = whichND(($k > $cl0) | ($k < 0) | (!isfinite($k))); if($idx->nelem) { $out->((0))->range($idx) .= $o->{bad}; $out->((1))->range($idx) .= $o->{bad}; } $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $d->((0)); my($y) = $d->((1)); my($rho) = sqrt($x*$x + $y*$y); my($c) = atan($rho/$o->{k0}); $out->((0)) .= atan2($x * sin($c), $rho * cos($c)); $out->((1)) .= asin($y * sin($c) / $rho); my $idx = whichND($rho==0); if($idx->nelem) { $out->((0))->range($idx) .= 0; $out->((1))->range($idx) .= 0; } $out->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_az_eqd =for usage $t = t_az_eqd(); =for ref (Cartography) Azimuthal equidistant projection (az.; equi.) Basic azimuthal projection preserving length along radial lines from the origin (meridians, in the original polar aspect). Hence, both azimuth and distance are correct for journeys beginning at the origin. Applied to the celestial sphere, this is the projection made by fisheye lenses; it is also the projection into which C puts perspective views. The projected plane scale is normally taken to be planetary radii; this is useful for cartographers but not so useful for scientific observers. Setting the 't=>1' option causes the output scale to shift to camera angular coordinates (the angular unit is determined by the standard 'Units' option; default is degrees). OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item c, clip, Clip (default 180 degrees) The largest angle relative to the origin. Default is the whole sphere. =back =cut sub t_az_eqd { my($me) = _new(@_,"Equidistant Azimuthal Projection"); $me->{params}->{c} = topdl(_opt($me->{options}, ['c','clip','Clip'], 180) * $me->{params}->{conv}); $me->{otype} = ['X distance','Y distance']; $me->{ounit} = ['radians','radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($ph) = $d->((1)) * $o->{conv}; my($th) = $d->((0)) * $o->{conv}; my $cos_c = cos($ph) * cos($th); my $c = acos($cos_c); my $k = $c / sin($c); $k->where($c==0) .= 1; my($x,$y) = ($out->((0)), $out->((1))); $x .= $k * cos($ph) * sin($th); $y .= $k * sin($ph); my $idx = whichND($c > $o->{c}); if($idx->nelem) { $x->range($idx) .= $o->{bad}; $y->range($idx) .= $o->{bad}; } $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $d->((0)); my($y) = $d->((1)); my $rho = sqrt(($d->(0:1)*$d->(0:1))->sumover); # Order is important -- ((0)) overwrites $x if is_inplace! $out->((0)) .= atan2( $x * sin($rho), $rho * cos $rho ); $out->((1)) .= asin( $y * sin($rho) / $rho ); my $idx = whichND($rho == 0); if($idx->nelem) { $out->((0))->range($idx) .= 0; $out->((1))->range($idx) .= 0; } $out->(0:1) /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_az_eqa =for usage $t = t_az_eqa(); =for ref (Cartography) Azimuthal equal-area projection (az.; auth.) OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item c, clip, Clip (default 180 degrees) The largest angle relative to the origin. Default is the whole sphere. =back =cut sub t_az_eqa { my($me) = _new(@_,"Equal-Area Azimuthal Projection"); $me->{params}->{c} = topdl(_opt($me->{options}, ['c','clip','Clip'], 180) * $me->{params}->{conv}); $me->{otype} = ['Azimuthal X','Azimuthal Y']; $me->{ounit} = ['Proj. radians','Proj. radians']; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($ph) = $d->((1)) * $o->{conv}; my($th) = $d->((0)) * $o->{conv}; my($c) = acos(cos($ph) * cos($th)); my($rho) = 2 * sin($c/2); my($k) = 1.0/cos($c/2); my($x,$y) = ($out->((0)),$out->((1))); $x .= $k * cos($ph) * sin($th); $y .= $k * sin($ph); my $idx = whichND($c > $o->{c}); if($idx->nelem) { $x->range($idx) .= $o->{bad}; $y->range($idx) .= $o->{bad}; } $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x,$y) = ($d->((0)),$d->((1))); my($ph,$th) = ($out->((0)),$out->((1))); my($rho) = sqrt($x*$x + $y*$y); my($c) = 2 * asin($rho/2); $ph .= asin($d->((1)) * sin($c) / $rho); $th .= atan2($x * sin($c),$rho * cos($c)); $ph /= $o->{conv}; $th /= $o->{conv}; $out; }; $me->_finish; } ###################################################################### =head2 t_aitoff C in an alias for C =head2 t_hammer =for ref (Cartography) Hammer/Aitoff elliptical projection (az.; auth.) The Hammer/Aitoff projection is often used to display the Celestial sphere. It is mathematically related to the Lambert Azimuthal Equal-Area projection (L), and maps the sphere to an ellipse of unit eccentricity, with vertical radius sqrt(2) and horizontal radius of 2 sqrt(2). OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =back =cut *t_aitoff = \&t_hammer; sub t_hammer { my($me) = _new(@_,"Hammer/Aitoff Projection"); $me->{otype} = ['Longitude','Latitude']; $me->{ounit} = [' ',' ']; $me->{odim} = 2; $me->{idim} = 2; $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) *= $o->{conv}; my($th) = $out->((0)); my($ph) = $out->((1)); my($t) = sqrt( 2 / (1 + cos($ph) * cos($th/2))); $th .= 2 * $t * cos($ph) * sin($th/2); $ph .= $t * sin($ph); $out; } ; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($x) = $out->((0)); my($y) = $out->((1)); my($rej) = which(($x*$x/8 + $y*$y/2)->flat > 1); my($zz); my($z) = sqrt( $zz = (1 - $x*$x/16 - $y*$y/4) ); $x .= 2 * atan( ($z * $x) / (4 * $zz - 2) ); $y .= asin($y * $z); $out->(0:1) /= $o->{conv}; $x->flat->($rej) .= $o->{bad}; $y->flat->($rej) .= $o->{bad}; $out; }; $me->_finish; } ###################################################################### =head2 t_zenithal Vertical projections are also called "zenithal", and C is an alias for C. =head2 t_vertical =for usage $t = t_vertical(); =for ref (Cartography) Vertical perspective projection (az.; persp.) Vertical perspective projection is a generalization of L and L projection, and a special case of L projection. It is a projection from the sphere onto a tangent plane from a point at the camera location. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS =item m, mask, Mask, h, hemisphere, Hemisphere [default 'near'] The hemisphere to keep in the projection (see L). =item r0, R0, radius, d, dist, distance [default 2.0] The altitude of the focal plane above the center of the sphere. The default places the point of view one radius above the surface. =item t, telescope, Telescope, cam, Camera (default '') If this is set, then the central scale is in telescope or camera angular units rather than in planetary radii. The angular units are parsed as with the normal 'u' option for the lon/lat specification. If you specify a non-string value (such as 1) then you get telescope-frame radians, suitable for working on with other transformations. =item f, fish, fisheye (default '') If this is set then the output is in azimuthal equidistant coordinates instead of in tangent-plane coordinates. This is a convenience function for '(t_az_eqd) x !(t_gnomonic) x (t_vertical)'. =back =cut sub t_vertical { my($me) = _new(@_,'Vertical Perspective'); my $p = $me->{params}; my $m= _opt($me->{options}, ['m','mask','Mask','h','hemi','hemisphere','Hemisphere'], 1); $me->{otype} = ['Perspective X','Perspective Y']; $me->{ounit} = ['Body radii','Body radii']; if($m=~m/^b/i) { $p->{m} = 0; } elsif($m=~m/^n/i) { $p->{m} = 1; } elsif($m=~m/^f/i) { $p->{m} = 2; } else { $p->{m} = $m; } $p->{r0} = _opt($me->{options}, ['r0','R0','radius','Radius', 'd','dist','distance','Distance'], 2.0 ); if($p->{r0} == 0) { print "t_vertical: r0 = 0; using t_gnomonic instead\n" if($PDL::verbose); return t_gnomonic($me->{options}); } if($p->{r0} == 1) { print "t_vertical: r0 = 1; using t_stereographic instead\n" if($PDL::verbose); return t_stereographic($me->{options}); } $p->{t} = _opt($me->{options}, ['t','tele','telescope','Telescope', 'cam','camera','Camera'], undef); $p->{f} = _opt($me->{options}, ['f','fish','fisheye','Fisheye'], undef); $p->{t} = 'rad' if($p->{f} && !defined($p->{t})); $p->{tconv} = _uconv($p->{t},1) || _uconv('rad') if(defined $p->{t}); $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; my($th) = $d->((0))*$o->{conv}; my($ph) = $d->((1))*$o->{conv}; my($cph) = cos($ph); my($cos_c) = $cph * cos($th); my($k) = (($o->{r0} - 1) / ($o->{r0} - $cos_c)); # If it's a telescope perspective, figure the apparent size # of the globe and scale accordingly. if($o->{t}) { my($theta) = asin(1/$o->{r0}); } $out->(0:1) /= ($o->{r0} - 1.0) * ($o->{f} ? 1.0 : $o->{tconv}) if($o->{t}); $out->((0)) .= $cph * sin($th); $out->((1)) .= sin($ph); # Handle singularity at the origin $k->where(($out->((0)) == 0) & ($out->((1)) == 0)) .= 0; $out->(0:1) *= $k->dummy(0,2); if($o->{m}) { my $idx; $idx = whichND($cos_c < 1.0/$o->{r0}) if($o->{m} == 1); $idx = whichND($cos_c > 1.0/$o->{r0}) if($o->{m} == 2); if(defined $idx && ref $idx eq 'PDL' && $idx->nelem){ $out->((0))->range($idx) .= $o->{bad}; $out->((1))->range($idx) .= $o->{bad}; } } $out; }; $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; # Reverse the hemisphere if the mask is set to 'far' my($P) = ($o->{m} == 2) ? -$o->{r0} : $o->{r0}; $out->(0:1) *= ($P - 1.0) * ($o->{f} ? 1.0 : $o->{tconv}) if($o->{t}); my($rho) = sqrt(sumover($d->(0:1) * $d->(0:1))); my($sin_c) = ( ( $P - sqrt( 1 - ($rho*$rho * ($P+1)/($P-1)) ) ) / ( ($P-1)/$rho + $rho/($P-1) ) ); my($cos_c) = sqrt(1 - $sin_c*$sin_c); # Switch c's quadrant where necessary, by inverting cos(c). if($P<0) { my $idx = whichND($rho > ($P-1/$P)); $cos_c->range($idx) *= -1 if($idx->nelem > 0); } $out->((0)) .= atan( $d->((0)) * $sin_c / ($rho * $cos_c) ); $out->((1)) .= asin( $d->((1)) * $sin_c / $rho ); $out->(0:1) /= $o->{conv}; $out; }; # Compose on both front and back as necessary. return t_compose( t_scale(1.0/$p->{tconv}), t_az_eqd, t_gnomonic->inverse, $me->_finish ) if($p->{f}); $me->_finish; } *t_zenithal = \&t_vertical; ###################################################################### =head2 t_perspective =for usage $t = t_perspective(); =for ref (Cartography) Arbitrary perspective projection Perspective projection onto a focal plane from an arbitrary location within or without the sphere, with an arbitrary central look direction, and with correction for magnification within the optical system. In the forward direction, t_perspective generates perspective views of a sphere given (lon/lat) mapping or vector information. In the reverse direction, t_perspective produces (lon/lat) maps from aerial or distant photographs of spherical objects. Viewpoints outside the sphere treat the sphere as opaque by default, though you can use the 'm' option to specify either the near or far surface (relative to the origin). Viewpoints below the surface treat the sphere as transparent and undergo a mirror reversal for consistency with projections that are special cases of the perspective projection (e.g. t_gnomonic for r0=0 or t_stereographic for r0=-1). Magnification correction handles the extra edge distortion due to higher angles between the focal plane and focused rays within the optical system of your camera. If you do not happen to know the magnification of your camera, a simple rule of thumb is that the magnification of a reflective telescope is roughly its focal length (plate scale) divided by its physical length; and the magnification of a compound refractive telescope is roughly twice its physical length divided by its focal length. Simple optical systems with a single optic have magnification = 1. Fisheye lenses have magnification < 1. This transformation was derived by direct geometrical calculation rather than being translated from Voxland & Snyder. OPTIONS =over 3 =item STANDARD POSITIONAL OPTIONS As always, the 'origin' field specifies the sub-camera point on the sphere. The 'roll' option is the roll angle about the sub-camera point, for consistency with the other projectons. =item p, ptg, pointing, Pointing (default (0,0,0)) The pointing direction, in (horiz. offset, vert. offset, roll) of the camera relative to the center of the sphere. This is a spherical coordinate system with the origin pointing directly at the sphere and the pole pointing north in the pre-rolled coordinate system set by the standard origin. It's most useful for space-based images taken some distance from the body in question (e.g. images of other planets or the Sun). Be careful not to confuse 'p' (pointing) with 'P' (P angle, a standard synonym for roll). =item c, cam, camera, Camera (default undef) Alternate way of specifying the camera pointing, using a spherical coordinate system with poles at the zenith (positive) and nadir (negative) -- this is useful for aerial photographs and such, where the point of view is near the surface of the sphere. You specify (azimuth from N, altitude from horizontal, roll from vertical=up). If you specify pointing by this method, it overrides the 'pointing' option, above. This coordinate system is most useful for aerial photography or low-orbit work, where the nadir is not necessarily the most interesting part of the scene. =item r0, R0, radius, d, dist, distance [default 2.0] The altitude of the point of view above the center of the sphere. The default places the point of view 1 radius aboove the surface. Do not confuse this with 'r', the standard origin roll angle! Setting r0 < 1 gives a viewpoint inside the sphere. In that case, the images are mirror-reversed to preserve the chiralty of the perspective. Setting r0=0 gives gnomonic projections; setting r0=-1 gives stereographic projections. Setting r0 < -1 gives strange results. =item iu, im_unit, image_unit, Image_Unit (default 'degrees') This is the angular units in which the viewing camera is calibrated at the center of the image. =item mag, magnification, Magnification (default 1.0) This is the magnification factor applied to the optics -- it affects the amount of tangent-plane distortion within the telescope. 1.0 yields the view from a simple optical system; higher values are telescopic, while lower values are wide-angle (fisheye). Higher magnification leads to higher angles within the optical system, and more tangent-plane distortion at the edges of the image. The magnification is applied to the incident angles themselves, rather than to their tangents (simple two-element telescopes magnify tan(theta) rather than theta itself); this is appropriate because wide-field optics more often conform to the equidistant azimuthal approximation than to the tangent plane approximation. If you need more detailed control of the relationship between incident angle and focal-plane position, use mag=1.0 and compose the transform with something else to tweak the angles. =item m, mask, Mask, h, hemisphere, Hemisphere [default 'near'] 'hemisphere' is by analogy to other cartography methods although the two regions to be selected are not really hemispheres. =item f, fov, field_of_view, Field_Of_View [default 60 degrees] The field of view of the telescope -- sets the crop radius on the focal plane. If you pass in a scalar, you get a circular crop. If you pass in a 2-element list ref, you get a rectilinear crop, with the horizontal 'radius' and vertical 'radius' set separately. =back EXAMPLES Model a camera looking at the Sun through a 10x telescope from Earth (~230 solar radii from the Sun), with an 0.5 degree field of view and a solar P (roll) angle of 30 degrees, in February (sub-Earth solar latitude is 7 degrees south). Convert a solar FITS image taken with that camera to a FITS lon/lat map of the Sun with 20 pixels/degree latitude: # Define map output header (no need if you don't want a FITS output map) $maphdr = {NAXIS1=>7200,NAXIS2=>3600, # Size of image CTYPE1=>longitude,CTYPE2=>latitude, # Type of axes CUNIT1=>deg,CUNIT2=>deg, # Unit of axes CDELT1=>0.05,CDELT2=>0.05, # Scale of axes CRPIX1=>3601,CRPIX2=>1801, # Center of map CRVAL1=>0,CRVAL2=>0 # (lon,lat) of center }; # Set up the perspective transformation, and apply it. $t = t_perspective(r0=>229,fov=>0.5,mag=>10,P=>30,B=>-7); $map = $im->map( $t , $maphdr ); Draw an aerial-view map of the Chesapeake Bay, as seen from a sounding rocket at an altitude of 100km, looking NNE from ~200km south of Washington (the radius of Earth is 6378 km; Washington D.C. is at roughly 77W,38N). Superimpose a linear coastline map on a photographic map. $a = graticule(1,0.1)->glue(1,earth_coast()); $t = t_perspective(r0=>6478/6378.0,fov=>60,cam=>[22.5,-20],o=>[-77,36]) $w = pgwin(size=>[10,6],J=>1); $w->fits_imag(earth_image()->map($t,[800,500],{m=>linear})); $w->hold; $w->lines($a->apply($t),{xt=>'Degrees',yt=>'Degrees'}); $w->release; Model a 5x telescope looking at Betelgeuse with a 10 degree field of view (since the telescope is looking at the Celestial sphere, r is 0 and this is just an expensive modified-gnomonic projection). $t = t_perspective(r0=>0,fov=>10,mag=>5,o=>[88.79,7.41]) =cut sub t_perspective { my($me) = _new(@_,'Focal-Plane Perspective'); my $p = $me->{params}; my $m= _opt($me->{options}, ['m','mask','Mask','h','hemi','hemisphere','Hemisphere'], 1); $p->{m} = $m; $p->{m} = 0 if($m=~m/^b/i); $p->{m} = 1 if($m=~m/^n/i); $p->{m} = 2 if($m=~m/^f/i); $p->{r0} = _opt($me->{options}, ['r0','R0','radius','Radius', 'd','dist','distance','Distance'], 2.0 ); $p->{iu} = _opt($me->{options}, ['i','iu','image_unit','Image_Unit'], 'degrees'); $p->{tconv} = _uconv($p->{iu}); $p->{mag} = _opt($me->{options}, ['mag','magnification','Magnification'], 1.0); # Regular pointing pseudovector -- make sure there are exactly 3 elements $p->{p} = (topdl(_opt($me->{options}, ['p','ptg','pointing','Pointing'], [0,0,0]) ) * $p->{tconv} )->append(zeroes(3))->(0:2); $p->{pmat} = _rotmat( (- $p->{p})->list ); # Funky camera pointing pseudovector overrides normal pointing option $p->{c} = _opt($me->{options}, ['c','cam','camera','Camera'], undef ); if(defined($p->{c})) { $p->{c} = (topdl($p->{c}) * $p->{tconv})->append(zeroes(3))->(0:2); $p->{pmat} = ( _rotmat( 0,-$PI/2,0 ) x _rotmat( (-$p->{c})->list ) ); } # Reflect X axis if we're inside the sphere. if($p->{r0}<1) { $p->{pmat} = topdl([[-1,0,0],[0,1,0],[0,0,1]]) x $p->{pmat}; } $p->{f} = ( _opt($me->{options}, ['f','fov','field_of_view','Field_of_View'], topdl($PI*2/3) / $p->{tconv} / $p->{mag} ) * $p->{tconv} ); $me->{otype} = ['Tan X','Tan Y']; $me->{ounit} = [$p->{iu},$p->{iu}]; # "Prefilter" -- subsidiary transform to convert the # spherical coordinates to 3-D coords in the viewer's # reference frame (Y,Z are more-or-less tangent-plane X and Y, # and -X is the direction toward the planet, before rotation # to account for pointing). $me->{params}->{prefilt} = t_compose( # Offset for the camera pointing. t_linear(m=>$p->{pmat}, d=>3), # Rotate the sphere so the correct origin is at the # maximum-X point, then move the whole thing in the # -X direction by r0. t_linear(m=>(_rotmat($p->{o}->at(0), $p->{o}->at(1), $p->{roll}->at(0)) ), d=>3, post=> topdl( [- $me->{params}->{r0},0,0] ) ), # Put initial sci. coords into Cartesian space t_unit_sphere(u=>'radian') ); # Store the origin of the sphere -- useful for the inverse function $me->{params}->{sph_origin} = ( topdl([-$me->{params}->{r0},0,0]) x $p->{pmat} )->(:,(0)); # # Finally, the meat -- the forward function! # $me->{func} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) *= $o->{conv}; # If we're outside the sphere, do hemisphere filtering my $idx; if(abs($o->{r0}) < 1 ) { $idx = null; } else { # Great-circle distance to origin my($cos_c) = ( sin($o->{o}->((1))) * sin($out->((1))) + cos($o->{o}->((1))) * cos($out->((1))) * cos($out->((0)) - $o->{o}->((0))) ); my($thresh) = (1.0/$o->{r0}); if($o->{m}==1) { $idx = whichND($cos_c < $thresh); } elsif($o->{m}==2) { $idx = whichND($cos_c > $thresh); } else { $idx = null; } } ### Transform everything -- just chuck out the bad points at the end. ## convert to 3-D viewer coordinates (there's a dimension change!) my $dc = $out->apply($o->{prefilt}); ## Apply the tangent-plane transform, and scale by the magnification. my $dcyz = $dc->(1:2); my $r = ( $dcyz * $dcyz ) -> sumover -> sqrt ; my $rscale; if( $o->{mag} == 1.0 ) { $rscale = - 1.0 / $dc->((0)); } else { print "(using magnification...)\n" if $PDL::verbose; $rscale = - tan( $o->{mag} * atan( $r / $dc->((0)) ) ) / $r; } $r *= $rscale; $out->(0:1) .= $dcyz * $rscale->dummy(0,1); # Chuck points that are outside the FOV: glue those points # onto the removal list. The conditional works around a bug # in 2.3.4cvs and earlier: null piddles make append() crash. my $w; if(ref $o->{f} eq 'ARRAY') { $w = whichND( ( abs($dcyz->((0))) > $o->{f}->[0] ) | ( abs($dcyz->((1))) > $o->{f}->[1] ) | ($r < 0) ); } else { $w = whichND( ($r > $o->{f}) | ($r < 0) ); } $idx = ($idx->nelem) ? $idx->glue(1,$w) : $w if($w->nelem); if($idx->nelem) { $out->((0))->range($idx) .= $o->{bad}; $out->((1))->range($idx) .= $o->{bad}; } ## Scale by the output conversion factor $out->(0:1) /= $o->{tconv}; $out; }; # # Inverse function # $me->{inv} = sub { my($d,$o) = @_; my($out) = $d->is_inplace ? $d : $d->copy; $out->(0:1) *= $o->{tconv}; my $oyz = $out->(0:1) ; ## Inverse-magnify if required if($o->{mag} != 1.0) { my $r = ($oyz * $oyz)->sumover->sqrt; my $scale = tan( atan( $r ) / $o->{mag} ) / $r; $out->(0:1) *= $scale->dummy(0,1); } ## Solve for the X coordinate of the surface. ## This is a quadratic in the tangent-plane coordinates; ## so here we just figure out the coefficients and plug into ## the quadratic formula. $b here is actually -B/2. my $a = ($oyz * $oyz)->sumover + 1; my $b = ( $o->{sph_origin}->((0)) - ($o->{sph_origin}->(1:2) * $oyz)->sumover ); my $c = topdl($o->{r0}*$o->{r0} - 1); my $x; if($o->{m} == 2) { # Exceptional case: mask asks for the far hemisphere $x = - ( $b - sqrt($b*$b - $a * $c) ) / $a; } else { # normal case: mask asks for the near hemisphere $x = - ( $b + sqrt($b*$b - $a * $c) ) / $a; } ## Assemble the 3-space coordinates of the points my $int = $out->(0)->append($out); $int->sever; $int->((0)) .= -1.0; $int->(0:2) *= $x->dummy(0,3); ## convert back to (lon,lat) coordinates... $out .= $int->invert($o->{prefilt}); # If we're outside the sphere, do hemisphere filtering my $idx; if(abs($o->{r0}) < 1 ) { $idx = null; } else { # Great-circle distance to origin my($cos_c) = ( sin($o->{o}->((1))) * sin($out->((1))) + cos($o->{o}->((1))) * cos($out->((1))) * cos($out->((0)) - $o->{o}->((0))) ); my($thresh) = (1.0/$o->{r0}); if($o->{m}==1) { $idx = whichND($cos_c < $thresh); } elsif($o->{m}==2) { $idx = whichND($cos_c > $thresh); } else { $idx = null; } } ## Convert to the units the user requested $out->(0:1) /= $o->{conv}; ## Mark bad values if($idx->nelem) { $out->((0))->range($idx) .= $o->{bad}; $out->((1))->range($idx) .= $o->{bad}; } $out; }; $me; } 1; PDL-2.018/Lib/Transform/Cartography/earth_coast.vec.fits0000644060175006010010000152700012562522365021314 0ustar chmNoneSIMPLE = T / PDL::IO::FITS::wfits (http://pdl.perl.org) BITPIX = -64 NAXIS = 2 NAXIS1 = 3 NAXIS2 = 18031 BUNIT = 'Data Value' END @@ ßťö@?)4<ē?đ@?ÚÜÜŇ@@?S_ĘÜť?đ@@ă Ĺ@?dW#Đ'?đ@?úGH4.w@?nč1dsz?đ@?Ŕ™‘{ßń@?|–FŤ?đ@?nM@üO@?}Ŕ2J2?đ@?ę˛ň*ź@?Šę/+Y?đ@>Ěyűga@?lâœe?đ@>ą")P”ô@?ušĐ´r(?đ@>ÎK€ĺů@?ˆś)ët5?đ@>eŔVr3°@?sLĘŹ|?đ@>.Ŕ( @?DkľVoŤ?đ@=×Čů„=#@?+!9ÖÜ?đ@=’cçIí@>ţIÚAL!?đ@=F>ßŔ“B@>Ühý3żƒ?đ@<ň§´×@>Ý;DŒ&?đ@<¨{ţߊÉ@?œEN- ?đ@?đ@:nJLg°a@?ƒ„ŚŮÝ?đ@:M“źH@?•ÍJďi?đ@9ĹXxk3×@?˜ńK<1?đ@9q^˘E*Ą@?„šÇ?đ@9*,,•Şâ@?ž‘=Ţ?đ@9s“°żî@?ĺA–qƅ?đ@8ľ›ĂÚd2@@!špI?đ@8^ˇ2Ęâ@?˙>ü°?đ@8&:w9Đ@@„ô•î?đ@7ť ćK@@6í‘u?đ@7]ďVšÎš@@óÜň$?đ@7!oÓ.2(@@0‘Bœť?đ@7=(č´é@@Q€~œ?đ@6°ŕâ$@@`!\Ú?đ@6^Oá¤ń@@mŕ8Ĺ?đ@6 ‹8Űü´@@u8wžy›?đ@5­ąy™@@u+‹°Ď_?đ@5]~žeľœ@@e_ K?đ@5YŻÍś@@_œÂ§„?đ@4ś×Ľ,č @@NŒYb[˘?đ@4k÷7+ˆ2@@;,) ?™?đ@4,˘I@@!™˛’g?đ@3üC:Őp@@ëôš )?đ@3î~\ü@?źÜŤĎşh?đ@4Ź™ˇî@?tIß2j?đ@4"üʇ¤&@?0čN2Ĺž?đ@4Ą5;@>ésF7y?đ@3ć\‚ů@>Ť'tĎKY?đ@3Ş+$ĘĎa@>uÎůě˘ç?đ@3_¸)Š @>Pęüˆąs?đ@3 H¤óçr@>F - â~?đ@2˝QKřş=@>b˜(î|´?đ@2xŻí+f*@>Ž/ŐŔj?đ@279•űĺ@>˝í\?,,?đ@1éŢ{Í@>ßn~š¨-?đ@1›{†1&@>ü„ő˘)?đ@1K”˜É ő@?™|Ě–?đ@0ř0—BőS@?+9*U+?đ@0¤9c‡Ş@?9Đoňý?đ@0Lúoí‹@?;\/tl?đ@/ň2ƒ™n@?L–šĆšĆ?đ@/]GBášÖ@?rPëÉ??đ@.ů§rš=@?Žžy Ř?đ@.žŢŽ‚¨@?óŘšś?đ@. ˝ŠO"@@댇ü7?đ@.!œő]!@@4śpĆv§?đ@-r5ăŃhj@@;X{ąŽ?đ@,ĎŹÜĐ4@@HuŘ#P?đ@,:NĖ˛ă@@[_aŔ™Ý?đ@+ó ´l@@d•Š˙ĺŞ?đ@*ç—zš@@@m-íJD?đ@*@G;\†Ů@@qP똤ô?đ@)•eG,6_@@fë97)ë?đ@(äÚŽ'b!@@hˇ Ş?đ@(CB•ź>@@v XÄq(?đ@'–Ë Ç,‹@@ŠŤŁ#:Ű?đ@'لŚęf@@•ŇÚ"„!?đ@&|ůlK:Ľ@@˘]ÝđŘo?đ@%óľ/iƒ@@ÇE¤QŃ?đ@%Ržj´ě@@ÎŤö”X?đ@$¨9†-@@ۊWbČ?đ@$0vâbOű@@öÝ DX9?đ@$•Ż–DK@Aü×FE?đ@$œ¸Ďüý@A4o9џË?đ@%-şQśHY@AJ\A–+Ý?đ@%ĽEPs@AeWĐ^=?đ@%ů‹”Ž÷˝@A†)Žp@b?đ@&$s`Ď!@AŚŕ¸qM?đ@%ů–,kév@AÍ0Úf]?đ@%qzBH”@A嗥ćB?đ@%áš3ń@BĆbxŮ?đ@%˘|f"@B(˝i }2?đ@%•&v‚đü@B@¤ch‘O?đ@%ůLhCPh@B`gWŇ$ü?đ@%ôîx-‚7@BP•Ľ ę?đ@%5OÇUí§@Bl~¸ŹW?đ@$˜ (t8Y@Bh•‚“äě?đ@$d[ějçE@Bdż ×?đ@#Ç/÷Ԅđ@BöŢS4?đ@#3ÚĚ–Ů@B§X ÝŰ?đ@"ćö4ńç@BœL-R?đ@!ćdŻúÜţ@BˆÂ Žmp?đ@!F…5 †@BxËK H0?đ@ Žb&Â@Bv*-Hé–?đ@Űqśő@Brm ďv?đ@L‡ťk@B€Ě*˛+?đ@ű­ş<˝@B‚Ź\ˆ{?đ@–)zPŠ@Bu‡´ĆŤĄ?đ@C˘1ˇ“@B‚Œg´Ěź?đ@Nh|úÍ@B~Ÿ=PyÁ?đ@ĺĚĘ[Ĺ@BkŸÎL,n?đ@†DŐÉM~@Bb˜6ßKć?đ@5tbĎ @BSěф–?đ@ F=<b@Beš›”’r?đ@§ŐE…ÇB@Bqˆąĺz?đ@3˝Ţě“÷@Bs˜AË9?đ@}žť-Ô@Brť˙wí6?đ@ Ń^°÷@BhK}d?đ@ 哫€Ę„@Bbź:Ď(Ń?đ@3@˝I+@Ba´c_N?đ@|Ľů6ô#@BM͚ě?đ@´u˝ÓYe@BMG +˛\?đ?ýÁnU@BGžhaˆě?đ?÷ö™ „@BDŽ‘n@Î?đ?ňf+˙Ú7…@B?síÇ9?đ?ę‘c k@B0+PÖ1?đ?ŕ$ŁŠ›?y@B ‹(?›?đ?ˇîĚZĐF@B 7ÔîÎŢ?đż|ô–§ƒŮś@Aí˘sö”Ž?đż×†eÚĺ˙}@AěÓJƒs°?đżćpĄJŹë@AßGŢu?đżđ‚óM_ˇł@AÔhí-Ń?đżôżgÔ @AšôüŻ^?đżřAsa¸@A˘T”;úO?đżýCŇŻŽ;@A°çßP?đŔPK+rň}@A‹ŒJL?đŔč^y@AŽÝŤ Mŕ?đŔ¸Î u¤@A—2źČx?đŔx.nÍUđ@AŞÔ”?đŔ ŕ﯃­@AšÖśˆž?đŔ]¤N;3@Ažű-Ägž?đŔJŢAH@AšŠrIˇ?đŔď<Şe'@A•ü͌×ń?đŔGŠÓÂ:=@A˘ÝcJą?đŔ`ďSˆŞ&@AşŒ:>b¸?đŔ.Ý/  L@Aך(ź9?đŔϸĄç@AďáM[,Ë?đŔt˝W;Ěř@Aâ/jýë?đŔŹ2bv@AÁŘŽÝç˜?đŔ’˜Űň@+@AžüďSšp?đŔБřĆ*@A|ű>Ů.?đŔ”Q3đÎŘ@AYŘőv#?đŔ0}&„–Â@A8Öc1×?đŔߔą‡Ď‚@AŸÇĽô?đŔŤ˛ú¸­@@úő~2žŠ?đŔҢc˛ů@@ć-ÇШ?đŔ“Şßp@@Ô.‹˘ŚY?đŔI.ś@@Äaĺç=?đŔ GAQ#ˇ@@ľţĹ&ÎŃ?đŔ áAőÚ˛@@¤ZL­X?đŔ!WťEx@@‹Íě°č?đŔ!ĚHiŮ­ą@@nýšĂŤ4?đŔ"GęÚÖÍů@@Uś˝vV?đŔ"‰ßsŃS1@@5čŐşńZ?đŔ" 4â j @@f­\ô_?đŔ"˙m‚T@?ĺŞ)ąHă?đŔ#a>1 Ź@?¨Ö=‘œ?đŔ#žLe‡á™@?câŰEęŸ?đŔ#¨DžJđĹ@?š!m`M?đŔ#Ť@Ż ŹD@>Î臾„ú?đŔ#Šć8ö7@>’Ąe°ĆŞ?đŔ#AY’'ý@>QG§‘Cq?đŔ#hŠ„ÄŽ@>ëoŚÜ&?đŔ#ż°uÍű5@=ÉBAçz?đŔ$"nýpá@=’˙?đŔ$2™ĐrX@=P{š ‚q?đŔ$íAklŔ™@=66g?đŔ%qƒĐ|¨@<ę ĂźEţ?đŔ&ăÍɸ@<ÄśtX‰Ă?đŔ&ŢŞ}ü@<’—ŞÂÎ?đŔ&ď‰VÇDƒ@@9LWď?đŔ-­˛Ý @9Öć\B„?đŔ-іŚó–@8šşß¨Éţ?đŔ.9ĺMUů@8ƒ];ôW?đŔ.ŹQGü•@8OXuŠ0?đŔ/<Łh˜@8Šł(’đ?đŔ/šßăLż@7ë%oŻTQ?đŔ/ÁFšl@7˝’Çî¸b?đŔ0j‘ëe°@7e)ö_¸š?đŔ0)…ő@7ےöť˙?đŔ0Dœw(Ęb@6ß@3.Ą?đŔ0_\ĹâÚ @6™ľS–E?đŔ0‰Wyóát@6VňBŞˇ{?đŔ0Ć`ňíŃ@6,G’¤ďż?đŔ0ë~üÍÓ:@5ęZ>Aĺ?đŔ0ř; Š )@5Ł0Y5?đŔ1Ĺ:IŹp@5XÁľö?đŔ1çHǒÔ@5şP˘‹:?đŔ1ń˜„Č@4î­­ÄÇč?đŔ0ŮËGEcg@5] k I?đŔ0łö5g•A@4ĹOü¸/n?đŔ0|Đŕ‚E@4˘Ň´f[¨?đŔ0NLwŒS@4_JŽĘ?đŔ09y–}Ć@4PŇEŘ?đŔ0E!´7O)@3Ř@D?đŔ0d˘4Z4Ć@3‹š7:Č?đŔ0fń›ř @3hƒ<Ýa?đŔ0>ůpZű!@3 ńPe?đŔ0(\~ˆŇ™@2Ç.Ű8Ű?đŔ0đĹu@2`Ëdc?đŔ0 1‹…Ąî@25ŻĺŸÂÓ?đŔ0 ţăÄű@1ëŹg¤!Ż?đŔ0Ă{5Վ@1ĄÜ%¤?đŔ0$U,{<@1YúGÚ!?đŔ0AÖĽ_ů@1[‰3#?đŔ0aËh,Ś@0Ňúš¸¸"?đŔ0xUÝÖ>:@0Œ‘†Żň1?đŔ0†ĂW’@0D3V ¸)?đŔ0ˆJ/ń+=@/ó­hJ?đŔ0–ń3lP=@/eUÉĚ~?đŔ0ż(â‰7@.äw*tš?đŔ0č Ssý&@.gťVž•?đŔ1ĐZşÖÝ@-őH˘­bÍ?đŔ1W÷n5%@-¤9Ż&cç?đŔ1gç_™@-lŞ,Ő?đŔ1c꥽i@-桥Ě?đŔ0ńĹřőZ@,¨Ń;Dˆ ?đŔ0Îöž4Ň@,#”Ž&!?đŔ0´P0ŠŔ•@+ţOs¤Sí?đŔ0‹ŠŠ8‹@,#¨E]Ćf?đŔ0“_ëLôŸ@+ ’źgŞ×?đŔ0‹ńbD Â@+ť9ľÍÜ?đŔ0[€dŚó@*şU3Öä?đŔ0ţÄV,Ć@*âwŸiŕ@?đŔ/‡;łqˇƒ@*ńŸřŮö?đŔ.öščR ë@*ü}Üscú?đŔ.ÝćőNq@*đ€;ĺ˜}?đŔ/‰Q™+ @*⃅{&?đŔ0‹3ŔŤě@*ÓköČě?đŔ0PçŸ^ř@*‹öĆŁłĆ?đŔ0› %eÉ@*ÎUŞC=Ő?đŔ0ˁ§šë@*Ś9 P*°?đŔ0Ä8Ă"/@*‡GFĽq?đŔ0Ä?5Rć@)~ł› A?đŔ0Ÿm0éË@)XKéÉV?đŔ0eÔšwŹ@):ö&ŽQü?đŔ0 抾<@)MóŰŃ-?đŔ/ˆ?—5ĐF@)1ú˘¸ö?đŔ/)&Cs@)g!:ăť?đŔ.úé3ĚŁí@)w%˜Š ¸?đŔ/}Şg5Ž@) ׈c?đŔ0 †b‰–@)4ó¤gN?đŔ0Uťlő/š@)&ő+5"í?đŔ0žTs:!@)&ďOr?đŔ0ťůß:>Č@(Ä˝OŁe?đŔ0t=ŞJĂ@(p‰‡˙ş?đŔ0=5–ó@(oĂx‰?đŔ0)6ŔŻ@'ŐĹí°ľ?đŔ/ÁŰŘą`@'řľşˇ,?đŔ/¨˝>ä9@'婚÷Î?đŔ/¨ÇŰN@'›ş-7ž?đŔ/¤„Qí@'Çśš'Xw?đŔ.†ě1{ľ@'Ý˝P<2‚?đŔ.,Ő \¤‚@'źž+xńD?đŔ.ö*K“‘É@'wŮČϏf?đŔ.­EéÖa@'Lč°Ö?đŔ._ą(lK4@':ń6P?đŔ.Ěaľ…Ž@&ÎĽŠL*?đŔ.Š;q ´Ę@&IƒO‰î?đŔ.CÉĹŹ%Ć@&1œżŔ3?đŔ. ̤yź@&°Ęƒ†˙?đŔ-ăÁy%Ÿ@%Ďŕ˜8ź?đŔ-„]T˙r@%Ôů<Ĺ'ś?đŔ-T–Źť‘ś@%|LüŚŒ?đŔ-!kp÷[ @%ƒ5oĚüq?đŔ-/j˙ ĂQ@$úă™C ?đŔ,Ďýš ç_@$zś0¤ž?đŔ,7kä;H@$;űő°?đŔ+Ě˝źů*ƒ@#Ôő ]‡Ł?đŔ+UeYІ@#–N,<őa?đŔ+&Š8Â=@#~&lu?đŔ*ˇ…‘5ˇ&@"uŁh9U?đŔ*{5hց@"/lľ–Ę°?đŔ*BÓ|ßöQ@!ąÇčgN?đŔ*;q{‘ŒŠ@!6,ц÷Ő?đŔ*ţĎ÷Zž@!Ľn`&ł?đŔ*w0ľœ‰@ Âb8 _?đŔ*VÁš@ b˘A —?đŔ)ȏ_č@ČXŰÄÖš?đŔ)“|pžu@Ă~ěx?đŔ(úŮhs| @Ş*v[{ť?đŔ(ˇ@ í/@Ţü+'Âr?đŔ(6É#Îú—@ř|—ˆ?đŔ'ŤV5@Ş”:đ?đŔ'-Ş#OÉ@î82jř?đŔ&Óż mŹ@#:áţąV?đŔ&S4ę˘K@{ŕ/ňęg?đŔ%ÍFX¸%3@őň9ůŚ?đŔ%zřI×Ě{@1řH1u?đŔ$ՇźÇ˛@ĄĄj‚=?đŔ$`üރ ž@A,ČVŒ?đŔ#ö^/sRk@;ť-vqŠ?đŔ#‡Č9Íy@mIw乇?đŔ#š˛ ~@ŹĂĂü`{?đŔ"­oľ;??đŔďPě`%@K-ŚpáŠ?đŔd>îG@hśŇ雫?đŔÇ…’@@Ť‡ßr‘ś?đŔ0ýÇŹ@•Í ó€?đŔě•ƒž]@żřp“>?đŔžď%['(@ÖťHäůŐ?đŔ‚6“›˝ň@ ÄâńĄ&?đŔđ=Œţä€@ŕƒ‡KMç?đŔz^án×0@˙튯D&?đŔŃ#ő'Ô@.öňž1?đŔgWú cÇ@2Ꞩá?đŔS(1—Œ@ýěăý8d?đŔ ž4I¤=@ľTa“Áx?đŔ D¸{,uÉ@ăƆ|č?đŔů͆@h¨˙`–™?đŔѲXýa@ç%ă˝?đŔ‹€sJá0@”łk9Ş?đŔh ˘]Xz@%6Şrö?đżü_ ˇ7e@ŠĐŔ¤7?đżř{lţZĎ@ƒŮÁ?đżóŇ Íó÷Ç@p…B_Ĺ$?đżîîhéBń¤@Ěĺň$/?đżć8?4őć@'5Żđů*?đżÜ\ÉŚëΙ@˛›šöŻŃ?đżĆ×lŮ÷˙@,aVPu?đ?´˘Ě I0Ő@Ź@"b5ł?đ?ÖɇĐ?đ@%Jľ­^Ŕ ÷žöœÇ‘?đ@%ą÷ŸLô§Ŕ –÷Ľ)?đ@& =4ŒŠŔez _v?đ@&u eŔ˜HĄ_ąŃ?đ@*ŽŘ×ĐŔ#¤F…ţ5?đ@*Ĺl ńĂÉŔ$'@úŹ•?đ@+ ÇI†ďŔ$˛ZÜN*?đ@+c(Zł‰GŔ%-ŤĽŔđß?đ@+‘!čÉÍJŔ%ŻL–]?đ@+Źި5Ŕ&Bg(C (?đ@+•őÔżAˇŔ&Ó ćĆd?đ@+’2Xţ\ľŔ'gÓ ÝĽ?đ@+x؈źĚŔ'úˇ'G‹¸?đ@+6.•XDŔ(‹Ą:Čp6?đ@*äănH;Ŕ(űÉ牜˜?đ@*jtƒmX›Ŕ)=Ýum֗?đ@)ňlÜŇ*Ŕ)Ś,ň´Â.?đ@)¸fĄČ6Ŕ*(ŃA´A?đ@)Qţëd ­Ŕ*’$’!?đ@) >öD7xŔ+Ÿˇa’˜?đ@(ńÎńâĚíŔ+Źˇcú¨?đ@(˛űľLhŔ,2Γ?g?đ@(Š]üX}Ŕ,ÂęĐÖNÚ?đ@(Œšť˛Ŕ-WŠď% ?đ@([2ĺÎŔ-ßř#‹˘?đ@(/‡ą'-ćŔ.gŹŽ0WBAÎÎ?đ@+ŤŐŃ;ƒŔ5{ĂřMŞ?đ@+îfç<ĺŔ5ż%ßąI?đ@,Mĺ;’a@Ŕ5ů—őK?đ@,ŞšĎŽ–œŔ652žĐ˛ő?đ@,ďFÇzüŔ6wżZ”P?đ@- rAđŔ6ż5cAę?đ@,ĺФéÚXŔ6ün?˘(ž?đ@,ńvK~ÇńŔ7T›Ú|Đž?đ@,ře€mśŔ7šńœúAG?đ@,řę+ŇbŘŔ7ĺĆJV+×?đ@,ű>(‘ŮCŔ8.†ť‡k1?đ@-0ŚĐ—trŔ8uóŰŢąě?đ@-q4X[Ŕ8ˇ‚””Ú?đ@-¤˝Ź>§?Ŕ8ýíňˍ?đ@-¤ǔ xŔ9G…k×y?đ@-śknŒ ‡Ŕ9‰$ L?đ@-Ć´›RĚŻŔ9Ř>Üíg?đ@-í„Ô˝ąŔ:öBľEh?đ@.Ôf%ć`Ŕ:b|„ÍŐ=?đ@.@ĺ˘5oůŔ:Śťy|Í?đ@.a쐙éŔ:íÜYłç?đ@.‹gr |Ŕ;4a€ :ł?đ@.Í ˘çߥŔ;vô§ŠŽđ?đ@/›lÂ@Ŕ;¸žŚôůÓ?đ@/q9u÷<ŸŔ;řʢe?đ@/⭖e‚Ŕ<0%€ż%6?đ@0,F‡˙ŰŔ(Á%RĆ?đ@1UJ,řĺ™Ŕ>mâ•vF?đ@1|G>íčŔ>Ż„ĐžÜ?đ@1ĄLź ŹŔ>ń‘wNEä?đ@1ĚP„>]Ŕ?2 f4ü?đ@1úŚú‹!ęŔ?oÓŐh?Á?đ@2+ň„ţGřŔ?­tšl!?đ@2G]Xť‡Ŕ?ô*3˙jŻ?đ@2TęĎáŔ@RFpB?đ@2PšŠ7ŮŮŔ@DWŮ>}?đ@2’űx˝Ŕ@^g¤ÖÇd?đ@1ŕˇÉĂČnŔ@lťr”űA?đ@2ĂGčŔŔ@ˆf’ćmç?đ@2\ŸöěŔ@žKrܸ ?đ@2ZŔ˘›Ŕ@ĘÇBÁ1ř?đ@2n›'cŔ@îţQŢO?đ@2X0ášüŔACƊă?đ@2załREŤŔA.…YĄë?đ@2Ęç˙JŮĂŔAls>ž^?đ@3—‰uŔA-M,K.!?đ@3NB—Ţ\¤ŔAA$M"˙?đ@3ŒŰűž ÁŔAZ"Ý0ż?đ@3่ÇŔAcďőř?đ@4'yúD vŔAYŠW”Tš?đ@4pGʓ1úŔABíü"ä?đ@4Ę'‘őœ:ŔA6šžxŒ?đ@5öOvÍ/ŔA1JŞ)?đ@5q/úá’)ŔA1Ĺe(ć+?đ@5Î|;xŔA-fĺa¸ă?đ@6 nä0ŔAďĐ7k´?đ@6bP‚mö ŔA&X“Ď}?đ@6ťôłĚpÇŔAÔ­xý2?đ@7 dœăMŔA ‘Ť L?đ@7c–ÂyqŔAů >?đ@7ş…MLT&ŔAUź&Ŕe?đ@8ÜŢŔƒŔAÉR ĂÓ?đ@8gîWŚ­ŔA™ujĄĂ?đ@8ĹI%ŰĹŔA•áé*?đ@9\VŇůřŔ@ţŐ¸bJ/?đ@9cŹÓţƒŔAě˜C‰?đ@9ĽE öĂVŔ@ůD˘Qč?đ@9܏Lç}Ŕ@ݘHŔŇť?đ@:5đ GkŔ@ß2˜:?đ@:ÄE^5Ŕ@Ýî—Mő°?đ@:ŢĂĹ-˛Ŕ@Î_Ä6O˝?đ@;+[ě+Ŕ@źôřź˘?đ@;rś†X}ĺŔ@§÷Ž´ż?đ@;šŃ,R(?€ZĹŔ?L y ?đ@>Z–Ş:UYŔ>ăj7ühW?đ@>†ň5B´ŘŔ>ŁŽŃ**?đ@>ąRž&Ÿ/Ŕ>cŁm]’Ĺ?đ@>ؓř¨_0Ŕ> Ŕ9I`??đ@?ůËŃ%YŔ=âśąb֟?đ@?(hˇÇWŔ=ž>ÇI;?đ@?XÇ+:`Ŕ=_ŹTŁ:?đ@?(§Ö˛Ŕ=(¸†HmÚ?đ@?ËőkćhŔ<ő0B°w?đ@@vď@ţŔ<Î2Ę5?đ@@(d ÇNŔ<šgE?đ@@9`?4îWŔÂňMŔ;‚ú8ވƒ?đ@@d¸y)ßŔ;<Ž(ćŢ?đ@@oŠ‰€90Ŕ:ô¨´Đ?đ@@sjP@AšŔ:ŤĚä=?đ@@v*mƒŔ:b7€@?đ@@k9@§ŁěŔ:/ߌŒfç?đ@@JŠ‹íŮŔ9řRőÖTŠ?đ@@bwA@ŻŔ9ş_¨FC?đ@@~!îˇŔ9yIt0)Ű?đ@@Ąťâ/|ŚŔ9M†Va7ú?đ@@ÄŮĆypxŔ90őŇPŐE?đ@@ęLAEđÝŔ9%‡ćÄ?đ@AťzS;Ŕ8ú_€fŮÜ?đ@A7,üĚŔ8ßÔJłĆ_?đ@A]ĄŃą ”Ŕ8ŖH—˝†?đ@A‚Z†XoŔ8Ľ3~#Ë ?đ@AžeĺçEÄŔ8r?hY[?đ@AśVšVćŔ84đÜhž'?đ@AÁˇżoîMŔ7ë-]?đ@A˛Y<0ŤŔ7Č^Ăo*^?đ@AşŹ4z‘Ŕ7^"—;ĚÔ?đ@AĂ ˘~ČŔ7íˇ­ ?đ@AÄËśĎuŔ6ÝŽŃž?đ@AÁŢU ďŔ6ŠćôÁÎĐ?đ@AÙ2R *Ŕ6?Ě,‡¤?đ@Aś6Ú,ˇ7Ŕ68kHQ¤m?đ@AŹng’QŔ6WˆiŸfđ?đ@A¨Dńđý.Ŕ5őRsŒM?đ@A üó,ÇţŔ5Ť‡ËA0Ň?đ@A‘œ&JJ‚Ŕ5f6âóź ?đ@AŠAÂW^Ŕ5)ҙYě ?đ@A„r€ÄťšŔ4ÚSĆϜÇ?đ@Ak˙ő)4ěŔ4Łvöć'×?đ@AXŔŸëLřŔ4jx2>đ?đ@A^ׂ`łŔ4ÝÔĽŁ?đ@A[Š—2ČŔ3Ő †ńX?đ@AXŔăśG‡Ŕ3śYůíä˝?đ@A€Ď¸Ŕ3Ȑq´Ri?đ@Až“ :ƒ‡Ŕ3›^âv~?đ@Aş8­OßŔ3fl…ĂS?đ@AŃęQ…üŔ3.—śFäđ?đ@AńLůs!0Ŕ2řĽ’“Ě?đ@B ŹěmŔ2ÚĐ°•!M?đ@B.í á4Ŕ2ˇ‘ŇG€ ?đ@BJ;˝Ë›@Ŕ2{Zš}1)?đ@Bgđ'ť8‰Ŕ2†ĂžŔd9Ss$?đ@Cl™&ľzľŔA˜œĂ?đ@Cz>ÝÔăŔ(˜5bDC?đ@C‡V!şiŔ ˇĎĂú?đ@C‘x<›cŔĺÔňo?đ@CžŠ§LĄ ŔŇ_¤ y{?đ@Cş_ăŠy Ŕ⌟/M?đ@CËߢlˇ Ŕ 4öż?đ@CŐŹ\jsŔýLń6H?đ@Cę™[¸ŰPŔ Š€ó$đ&?đ@Cń‡W||Ŕ -4,–Ź?đ@D¸L\¨xŔ O*ŔÍ_?đ@DŠxňďěŔűÁĂí÷~?đ@Důšžţ…ŔĂđ;Ű?đ@D9Ľ­6˙ŔsC =•ł?đ@D[ł?v$UŔŇłvŮíF?đ@Dq¤Ĺ‘ý4ŔQuž?đ@D{'ű0œŔ Özç?đ@D¤Œň°Ôżţî3`dŸÉ?đ@DŔŮLßIEżű¨żŃ˙˝V?đ@DטĄÂžůżřeLŸń?đ@Dě„2żó˝Ň÷ŹŸ?đ@DüťlńÔ żďyßĺĺs?đ@EĆcĐ4@żélĹúł.?đ@E-ějcBéżâEM„a?đ@EDň0ťö@ż× ŠXj?đ@E`׎íżÂUž‘#-Ł?đ@Ey_-xŐ?°Ÿă‹z?đ@E’síő§?Ńš3źGo?đ@EŤ˛ęä?ß+,6Ťu?đ@EĹs €Řđ?ć?4Íuďź?đ@EáĺL#T?ěkŒž9?đ@EţT$’ď ?đýĹFˇýâ?đ@FLoĚ?ôĐXţƒ?đ@F5M{!đ?÷"” Lţő?đ@FS ƕç?ůęśrLđ.?đ@FqzB߈ź?üƒÎgt]ô?đ@F‘y1ôO…?ţĆę Loœ?đ@F˛*ŐÎŻB@q“bŤ+?đ@FŇ,Ďőť™@žâÇt?đ@Fň1LÍt,@Či1 x?đ@GĂi7@@H;~źź?đ@G(”줨@çD5 J?đ@GCË)B.Đ@zŸüÇŮę?đ@G^Rr‘€S@ ˇ´ŁdŸ?đ@GwŞ*ĺr)@ ̋Áť‰­?đ@Gd_W@ ƒzŞŕEƒ?đ@GŞ Ĺ$=@.–:˜Kk?đ@GĂt|žŽ™@Ţ\ô?đ@GۧdŃŮp@Đięópi?đ@Gô“&óšl@ŹřŔăi?đ@H 0„UĎ@ĄG›öjj?đ@HÇ=&Í@¤kÇŚíÚ?đ@H0Ä`š)ß@•Ř7žďá?đ@HG‹ƒ:Ýj@˘ MĹ?đ@H\B•/ţ@wS~G:?đ@Hoůy7Ä=@rźʼn!?đ@HřĎ=ľ@v4â†^O?đ@H‹&p7q9@‘ŞNđžI?đ@H—MQŢó@Š2cȨ?đ@H§Ň?iöÍ@ąą/Ôw?đ@Hź4ÂĎ4@Ľs˛+Vę?đ@HŃNŸd`Ä@—ŇŮQ>ř?đ@HâyĘŻé@Ś(Bwú?đ@HěU ݲ‡@şŽÖuC ?đ@IOÉŇ|”@ Lăósł“?đ@I\5 ö•@ Ę['ł?đ@I,ĽâôľÎ@!Iߋ(Đô?đ@I{†m?đ@IJűÇ/?@'Ćş`şš?đ@I1ÁýżXŕ@'UÔl?łŁ?đ@I}riŸ@'ţ× S÷?đ@Hě ˘eĽ@&ôšđh?đ@HÇ—1˛"@&Ř)ÜóH?đ@H¤™tôÒ@&Ł.-ÔÂ?đ@H_­,\@&ƒN8m‘?đ@HZˆÂŽbß@&œ<"âß?đ@H4°­oÄ@&"°mH†?đ@HuŚš@&R|6Ŕşw?đ@GěÓźAß@&?yŘđw?đ@GČ[\gU@&NŤ1-ć?đ@G¤[´ě(Ĺ@&@ (ă?č?đ@G„ÔŠiBÜ@%đÍ[ĄÓ?đ@GdN7ŕů@%§ůĂ~??đ@GAćŁáŁE@%n^ÓԐŹ?đ@G_„Ş@%„!ŽsšN?đ@F÷‰ürţ@%Ą-Äyř?đ@FÖńłňą@% * 4}?đ@Fľ¨­eN@%X…Qá¨?đ@F”“ĐÓËŞ@%ßúڙg?đ@Fsłnűđ/@$á߇š ?đ@FLT=â6'@$Ü/˜ĘKE?đ@F&áůů[@$č DZ?đ@FY˘¸@@%=œD@^F?đ@EꕯźmT@%0oYŻ™?đ@EŇ)úö@& ˝lu°?đ@Ežöţl›•@&•4Đ0?đ@EĽy§ŕ@&ô#Á?đ@E†@üDQ@'2üŃžîÂ?đ@E])nT@'ń”Š6ŕ?đ@EO…¤˜3@'-ő’e§i?đ@Eqš-L0n@'Şqąl?đ@E“ iCô@'Ńż}lPo?đ@Eą‚ól†j@(#Šyˆ8n?đ@E­alÔĚL@(žšŻýT˘?đ@E™łzZ+t@)3é‹o?đ@Eöâáŕ@)¤ŐÍ´Ź?đ@Ea!B7u§@)â_ŞRÎî?đ@EF7$Ű?%@*WťO>ÓĄ?đ@E-vĂŐśK@*Ť$rR†o?đ@E_żo,Ë@+6GUęů?đ@DţĽý#*Č@+—„_š$’?đ@DÝđßew•@+áý€:÷?đ@DĈďc…@,Qnö˘č?đ@DŽŚg^@,Ć˙¤ŕB[?đ@D”íb´@-67LŐGš?đ@Doo2Ü@-dĝé?đ@DUd}řľˇ@-ž¤ěČđ?đ@D6Ev^íJ@-ń0ƒ”œŞ?đ@Dżřn@.ŠŮfSô?đ@DřŘž#@.šp˝ŮŁV?đ@Cę+'T]č@.ˇĹ$Ůoo?đ@CÝřČ0ž%@.Y›`Ąť?đ@Cǃ¤pʕ@.üąŚ‹Q?đ@C¸ ‘Lç@/e\Ýře ?đ@C¤Ě@î~@/ńŚ†Ęđ?đ@CšăĆý÷@0A‰ĽS3?đ@C•B4¸ľ@0ŠňĹ$0Ÿ?đ@CŽť*ží´@0ĐuěržÚ?đ@Cƒ;˙~Œ @1v”*Ő?đ@CvŇ^’|Î@1^…öçŮ?đ@Cf‡ˇ7W@1˘ÉŁrě?đ@CS¨B7@1ä÷Ď3J?đ@CAĹć3@2ƒ‘?đ@C!I Œü@2>ę~$ś?đ@C‚ĂK_…@2lÖÓ=?đ@Bĺîšáęt@2¤JŔĆ%?đ@BĹ×p…×@2Át(OŠE?đ@Bľ8cá@3#Kľń?đ@BŤ™\t˙@3L•Őa?đ@BĄGgĐ@3˜O¤â¨+?đ@B *R@Ë@3ÜŰ0ôŒ?đ@B™BmÂ9@4$E=Š?đ@B™ ƒđŔ@4qƸĎTÁ?đ@B“ť˛€Œ@4¸˝ş4—?đ@BŒPŽWáŸ@5´ňwi?đ@B•] řč@5+|_žke?đ@Bzd9c ‚@5‘ßz8äć?đ@Bp$łĚ•@5ŘU-¸”k?đ@BgčÖ"˙7@6~ő9Ŕ?đ@BGŽĺŸ@6IYdŠ:?đ@B+?ŒfĐq@6| |ÍÜĺ?đ@B ŔŹ‘lŒ@6Ş ä5ť?đ@AçŃšĐ÷K@6ĐÍĆ% ?đ@AŘ1펞@7ÚÉ˙ě´?đ@AĂýÂÚĎş@7IuÚČx?đ@AżNŇłă@7Řů3Žm?đ@AłŚm‘ń@7â)AÔL?đ@A؄Ťőß@8ŔŽ&R?đ@Aˇ-ŸdbZ@88'VD¨?đ@A™Lƀz@8z&1)"?đ@Aˆ8œlßX@8ťF†é‹0?đ@Ax!ë¸aÍ@8ţ$(g#?đ@Ae kb]w@9@”ŁÄäk?đ@ASw›°@9‚uĹďĄa?đ@A@‰Â@9ÄşŞ6ˆ?đ@A+z• ě@:NL„MŮ?đ@A‡‹ď‘‘@:FŤxO;?đ@Ať n:Ü@:ŠˆCR;†?đ@@űýћ”@:ĎC\–?đ@@đej @;jzŃŻ?đ@@Ţ!Ý#°Í@;R˜đ‰-?đ@@ČęË{Ó@;œHél–?đ@@ÄQůĎbź@;Öfo?Ľł?đ@@Šę!wľ‰@<¤íĐŕ?đ@@z™r@@ŕ@=ßRы2z?đ@@NdýÎ@=ßĺ\öŽ?đ@@[Ąp¨@=Šđ,d­ą?đ@@möz.˙˘@=NąÂŽ ć?đ@@‰‚š-v@=ƒ$ۡÝ?đ@@˜h4KT@<Ó'E•O?đ@@Ąš§R@<†ęű?đ@@ž_I‡Ęî@@)ýg?”ť?đ@Fş9Đ2 Z@*DžPPX?đ@Fօ9@*§1Š•­¤?đ@FűUöż™@*ĘjWălŮ?đ@G!Ž"´2@*ÔaKĐ­?đ@GGČPÖ¸@*Řu1Ń)J?đ@Glóľ@*ü2ď?đ@G&„F@+)ŃěD?đ@G´8d’€ç@+X#ľCć?đ@GҒĺEN‡@+ľŚ§‡ă?đ@Gô#ܑ˙Ö@+ýXä¸Ă ?đ@H‹šjń?@,GĂw+%?đ@H<Îe‚Ą@,€óüŃb?đ@HbëxĎ&@,5­Žœk?đ@H{ú`NŢŚ@,¤Ę,űE?đ@H”ýs8Ľ@-Đvť.?đ@Hˇˆŕ‚g@-T=6ľ´?đ@HÚĆ!ŮÝ6@-‰!no¸?đ@I}@-ŠdŤP%?đ@I$:Ę<@-ÍäIÉĽ?đ@IFmOĽ@.{hľ×?đ@Ikâ˛÷H@.1çëĄůN?đ@I‘>ľ@.T•<Ę2˘?đ@Iľq~—w @.„”ŁˇI?đ@I׀Ź˜40@.Âč*” ?đ@Iř8ƒČD´@/>ۧ{?đ@JŹ,' č@/[-óČč:?đ@Jř:ťI§@/ô­=T* ?đ@J&Qxń@0@’`;?đ@JDK™Ÿ+Ĺ@0oűmzŢ?đ@JgôůŹce@0‹úÉŁ?đ@J‹Ď™“l‡@0Ľy˛B-?đ@J°Ĺ¨% Ĺ@0ť|9ÄľÜ?đ@JŐÝ x™@0ĚŢUmç˛?đ@JůäŸŢŮ@0íÍçŸv?đ@Kޅ܊Ĺ@1ţœĘ\?đ@KC<Ňc_=@1 gكí?đ@KiĐp@0ůĐÎ`l™?đ@KŽT‚&ŸT@1ĚOCE ?đ@K˘úJFr@1SéBVhí?đ@K¤nW ó@1šÎQ=O?đ@K˝čđ€rý@1Ô ţBŠH?đ@Kä!ű™Şš@1ĺ÷u€ŕú?đ@L ž{Ž–@1ďH%?đ@L0âUľ@1ţĽ#ť'¨?đ@LH§´Ł˘@27^Ž~*P?đ@LR8"Ůńđ@2wZTqm?đ@Lhf„@Ţó@2źÁ†T??đ@LŠŘ°őâ˘@2Ý溛˙?đ@L°NÇ+Ž@2îóë˙a?đ@LŘio0>@2ô1Le?đ@Lć†Ÿ@3#˘ÎËrE?đ@L߆Ř*:?@3l0 Oíě?đ@Lۈ–Đc.@3ľn6dŚr?đ@LçwH g“@3ü“ć%*L?đ@Lň9Děp>@4Dî/-v?đ@MV 6”×@4„`˜ç?đ@M :Ć|!ä@4uä  €?đ@M?ë^•Ć„@4qMπ—D?đ@MU“Żž@4˝pš€Q?đ@Mfbwó6A@4÷›ßĘ?đ@M~ çńô@52ֆ$|?đ@M:•Ţş@5b ˝lź?đ@Mśƒx š@5—Ž§‘Łc?đ@MÉż8(s@5ŘŢFpGĄ?đ@MÜ^§DŒ@6¸›O)¸?đ@MęmŠxž@6]ďń5œî?đ@MÖ Œs°^@6ŠÝĺhęŹ?đ@MłP‰ł|U@6°î(Ąq„?đ@Mœ &@6ěń58 ?đ@Mƒ ľţR@7&cwŻ¨ä?đ@Mlä)áÔ@7cř?1č_?đ@MS› ĆŞz@7•'ëŤ'?đ@M,QŰô$ą@7˘á¨w+?đ@MßşÖő@7ˇ)Ţ ?đ@LÜéůKjß@7ĹŤ1đíĎ?đ@LľťtHSP@7Ü ôz ů?đ@L™× Ůŕ@7řo‘^~č@8;'"š?đ@JĆlŽ@7úÜ÷@G?đ@IńN‡ÁŁł@8*6äÉ?đ@IŮ16‚‘6@8?ťĚ¨|?đ@Iż›źż@8Mť[gý?đ@IŤŒŇůŹF@8l5ŻLN•?đ@IŽóŹí`Ů@8ŸG Ć=2?đ@IÉ]„‡‚@8ő÷u8mE?đ@IÉo‡…d5@9?vĺɓ?đ@IÁ p˜ m@9‰5ě‚b?đ@ILj ”8@9ĹËTAŠ?đ@IŻ?#ęJX@:ŔDŒ?đ@I=´üé@:‚EÚ?đ@Iy‰Ě/ö[@9ÖľM›?đ@ImĚŃć.ń@9‘ŁĂş?đ@Ia$ńŇër@9KĚ[Ό?đ@Igx~S@9ŰľX)Ą?đ@I_šý|yű@8ŮkŸö?đ@IEĎĆ_@9(ň­ď?đ@I4#ŽbłÝ@9sę´‹Đ?đ@I ŠœTü@9Źá”IËl?đ@I ~–ś¸@9ôuŃÎňŸ?đ@I 6sţëx@:">I¸ű?đ@I¸…Ţ#V@:dɁĚLŐ?đ@I\ęK09@:ŤYbÎ9?đ@HńGŹöň@:܍ži?đ@HК-湏@; žx6Ź?đ@H´ľ}'řÉ@;0i˙2nB?đ@Hœ>8o×@;ru.}?đ@Hu/q$×@;žë™c?đ@Hh˜ÍĽRŞ@;ŃĺU–˛E?đ@HS{@˜3@<]”)Ô?đ@HBĽ’#)@¸žšD?đ@H=X3Ś¤Ť@=ńä|őYŽ?đ@H`ˇlfí@>š?ö\?đ@HtWőY@^@>9şj#oˇ?đ@H€gČAä‹@>vAƒäú?đ@H‹ÇüЏ@>\şxÇš?đ@HŽQ)˝>ř@>(Šké?đ@HҨSˆC@>ö׳Ż?đ@I8H'Ţ@>, ŚăŘ?đ@Iń$‡˛@=ďéTh?đ@I0ăRcž@=°gŻ ˜?đ@IM†ŢŘ:@=x̔ph?đ@IZ@ŒBď@=/ů9Œp?đ@IoIäqC­@<öT%mOl?đ@I…ŇN/@<¸Jƒ97î?đ@IŮh ž‘@ÎFŞ­´@:•X–ƒ‡™?đ@KdOĂ]–ę@:ƒűDË5?đ@Kˆ ŸĂq@:¨ö,,rŔ?đ@K­|IÔ?]@:ÄoĐoş`?đ@KÎg§—O˜@:ęT{!n$?đ@KôűSϞŐ@;ďZÎ|?đ@Lâ9…Ý@;*y‚ž?đ@LC۞˘ŕ@;*€á}F|?đ@LjŻƒ<Ś@;SĚŞN?đ@L?ЌÜ@:áwŐhDô?đ@LŠ°ÍŒ4Š@:”¨ÝYs?đ@L‘UN–r–@:L&ń:?đ@LšćŤč,<@: “0ď—?đ@L˛šĄš@9Çߘđ¸?đ@LÝŢçLS@9łđŢ ?đ@M/qđ–@9 c=ň‚?đ@M(mk1­Đ@9“ŮkĚž?đ@MPö$4`ß@9’Ĺ*W‰˜?đ@MvśS‡bw@9|xĺ{R?đ@M›4‰.}›@9kżXXˆ™?đ@MĂj+OŽ%@9p-şď•?đ@Mě"œ˛ˆ@9c"‚Fƒ?đ@NmtG&@9[‡ôŠőe?đ@N=ŃĐÍő@9Zm"“‡˘?đ@NdGa:äţ@9>X´ýŇC?đ@NSArűL@9.)ýœ]ë?đ@Nˇ%ź:B×@9 ™ ŁÔ°?đ@NŘR*˝/@9'ŚÎq–?đ@NýVĹeh@9a-Űž?đ@O! ę˝-@9*ĺ°GěŽ?đ@O:ůË[ę>@94ĄÚ"€?đ@Oh{$-p@9>ÓďŮű?đ@O¤NaŘ8@9<¨™řk?đ@Oşń˘ˆřŽ@9?iÜńˆ7?đ@OÝO]ŞŢJ@9_6Yš“?đ@PôŃ*sB@9b äăĘt?đ@Pj%ś@9EÖEKƒ?đ@P*ŚŐFŐű@9=În_i?đ@P?qór„@9P*|*Ď´?đ@PS‚ű˙@9\*…EëŘ?đ@PguRx @9\ťˆQÎ?đ@P{)|ä•@9jCgú*?đ@PyŇ@á[@9těŒĺy?đ@P˜ŢůSE@@9~K”?đ@Q Žt0çM@7šëŞ/ ?đ@Q¨h~ľ@7¨Ý1'O*?đ@Q*ŐLĺ @7Đçđ0?đ@Q,Q­œIÜ@7Í1u+,?đ@QűŚb9@7‘XŒÓç.?đ@Q"üXöŠî@7U˜Ů‡MU?đ@Q.°Ě)Î@7şĐÍ?đ@Q@Úwë@6őŢßÁá?đ@QQřcÁôë@6ՅÓ# ?đ@QeጯôH@6Ä+F÷|e?đ@Qwčô‰ň@6Ú]Ęi+N?đ@Q‹6OK7 @6óMąP&?đ@Q™ÔA€ł@6ń 9řU?đ@Q‡Ş^ć@6‘Ě žâ§?đ@QsΚë?@6u0ÇDŚ?đ@QbCԅ‚ @6aw˘”W?đ@QMv= @6XfhŚ.?đ@Q@„.@ @6TňŕŚĘ?đ@QK>!ĎIR@64Ě?đ@QYœťBă@5Ń—F Ô?đ@Qh oʕD@5›]Á|pm?đ@QuزŐ3@@5e˝vвG?đ@Q‚Šűkf@5+ú(ŤOÎ?đ@Q‘3i/…@4ůÑÚ&ň?đ@QĄŕ7 â@4Ń])H÷ň?đ@Q´Z¨0 $@4śłˇNĐŔ?đ@QÇ%Ő>B@4ÂŮ+i?đ@QŮýœiš@4ßű9VEK?đ@Qę6>ëIŁ@4˙zűśę?đ@Qý'œJ6“@5 öo7Ń?đ@RŽ†(ć°@5RUÎÝO™?đ@R˛oí0@5›îĘ6Ĺ?đ@RÓ6ćIÄ@5ăÜ?đ@R˘ý^ç@68ëłqť@?đ@RP=ÁV@6H2ł™ ?đ@R.‘bľ /@64řMÍI?đ@R&ęëLIˆ@5ęßä˛CC?đ@R*WÇÜ|^@5Ž@ńvoď?đ@R:Ă~>>I@5¨ńM†4?đ@R(ţuî7@5aôÎy”L?đ@R/S?Rg@5“ÖŞŹœ?đ@R8Ą“ńs4@4×DȉZí?đ@R8c˘Ÿ@4ŒáĐZŒÁ?đ@R1ĹM-r@4Gmâ2?đ@R,Qwc &@3˙&Ď<?đ@R,Ĺ+'Ť3@3šţßŇđÂ?đ@R2ň5ź@3z&víI?đ@R88s[ĺĎ@3tJ@@#řĄş-@t?đ@SĆǏS&@#r>ŽĐó?đ@Sä7śVu@"ą4śZťľ?đ@Sƒ_B@"EY5Ěř/?đ@S&–J:@!×RĚ>l„?đ@S3<˛—{Ť@!8"xdůh?đ@S?)ĎÍ×@ ĹhľID;?đ@SMŔuÉÇ˙@ d›śđź?đ@S_žWŠ,@ 3'˝Bž?đ@Spí/Í°ß@ eˆy ňł?đ@S€äţ=FU@ ś ’-^q?đ@SˆŢF¤× @!8Çpś$?đ@SbůVŚ@!ľÉć~Ą?đ@SšĎ‘ŁW@",—h|#?đ@SŹŽž Ě@"[%˝Ú?đ@Sžu˙żm@"ƒŹâIQ9?đ@SŃGw=ě@"zÇ![űś?đ@SŐ rÝm@"´ó/f/?đ@SŔ‡ "`@"´GhĽî?đ@S˝ů.2už?đ@T gĚúź@)ĐStŢf:?đ@T*ˇF@*bň+J8?đ@T¸đúÇ%@*ÝâˇI?đ@T +kÚ \@+6ޢŒ$Ź?đ@T )Ť'@+Ěě=¨ˇ°?đ@T8TD$@,eFZ'ş?đ@T `ąÎÁi@,ůžÍ˜(?đ@T‘Əc-@-zőő6ĸ?đ@Tbú¨*@.Ťdř;é?đ@Tˇޚ@.Ąh†Š7Ó?đ@TŽ;F?"@/)’ Y-v?đ@TŸ ŕ@/™-,EY"?đ@T-‡m%ˆž@/ˇ÷×T?đ@T78vţdŰ@/ą}ATj7?đ@T@F°Ú>@/Ô=#)´K?đ@TNWéšE:@08_‹KlĽ?đ@T]ŐăFě@0\ ňňę—?đ@To›–Ťhł@0V x&ԋ?đ@T‚&M%@0nę(žîÔ?đ@T’ ˇâU@0™TŇńŠ”?đ@T•1đüół@0ŕżŃi3?đ@T™Ń u@1.Ďń?đ@T¨<[…ŽÉ@1K(R-h?đ@Tš—ŠŞ× @1ků`ç×ô?đ@TË*šTűw@1’éqźŸd?đ@TÖ?Wý@1Ŕ42?đ@TădXF^@1ű*WŁÔ‚?đ@TôU Mb@2'ĚnqÉÜ?đ@U:ݕzń@2KŃl5c?đ@UyŹ˘>ž@2ƒ’JŇţ&?đ@U@ËČPJ@2š3^D~?đ@U+˙îĺ‡@2óž˝DĚ?đ@U3†§Jßq@3'˝Ç×ys?đ@UDŕfr— @3bX{׈?đ@UThü`ܛ@3…áô^Š?đ@UVĹŞň@3žšß“7?đ@UJ’Ű&t@3™`ýŸ×Ć?đ@UY˙žÁ˙9@3ŮąĘËŰ?đ@Ueţ˘Äý@3źŽcĄ%?đ@UÔa'oć@3ÓđĽđ&_?đ@U‘NĚĹQ@4B„§OĹ?đ@Už‰§’á6@4ä#Úo`?đ@UŻ m„@4YNiąg?đ@Uˇ€@E3@4’ĽŮˇ?đ@U˝iđ4jV@4Á#ɸću?đ@Uśś+ňR¸@51áRăZ?đ@UťVz$ŚĆ@5UUG?đ@UĘZGą’ @5… R˙ÂT?đ@UÝvБżĺ@5™´Ż…Čë?đ@Uđs,ë˝9@5°ôwnłŠ?đ@U˙&ϒţ@5ăN¤ Œ?đ@V@yŕBs@6%Ű+u?đ@VćhI@6IVş=V?đ@V Sqچü@5üšŤâÇ?đ@V ĹăTţ@5ąűFÁaÇ?đ@VűŁ†P™@5Ť>a?đ@V"Ň=<Űř@5Ŕ.Ű=öń?đ@V+ßšĆę@6NŠYŕŇ?đ@V3˜ ˆI@5ŚL4żRę?đ@VBKQ!ŸŻ@5¸żUÁÚe?đ@VCaëfŠÝ@5ň>—4Ÿ?đ@VUżÇCÍź@5Ę"‹^?đ@V_ÔFŠŠŞ@6 pFĚә?đ@VcKA@5|Úk{Î?đ@Wg~Š&@53ę"^1?đ@W ŢăĽN)@4óióî0?đ@WË"ţá{@4ĺ@Ó<”?đ@WÜ#/Ÿ@5~ëo?đ@WÚo!ˆž@4ś@š?đ@W%ćE7Ďň@4zľnśj?đ@W-ËJß*Y@4jňzá¸ŕ?đ@W/Ł5ČH@4Šá˘Ąt×?đ@W6‚Öë@4<ÉCw?đ@WCŔETď@4Něd}”?đ@WCŽś`8@3ö܉oUÍ?đ@WKŽŇŚŞ@3ň¨źV@l?đ@W[÷Œ:Ć@42é‡J@?đ@Wj푯J@3ÎŐ5“=z?đ@WtĄŕĂ8Ú@3™T4˛‘ý?đ@WzQlef§@3RÍÝNց?đ@Wg? Ç@3>E˛?đ@WzŘâGœ@2ýc&Łż?đ@W‚Fšź$@3/ęυŕ?đ@Wˆ0†,ű>@2Ňů !ŻË?đ@WŽžŤ'Ž‘@2˘îŤÇ0m?đ@W—‰“ó}í@2P]Ѥż?đ@Wąi5s”@2 d=ZĚ?đ@WĄ[şşm@1Ä4°ďŽ$?đ@W¤ÎŔKR @1ƒˆRŕ Ÿ?đ@WĄGOż@18A_WÁ?đ@W›iŮ\š@0ísÇaN“?đ@W–>œf„@0Ąő7Ż??đ@WDşřĄ7@0cŻYÄԝ?đ@WóBěě[@0ŐKJűč?đ@W—’Bü @0 +!÷€R?đ@WĽOMřT^@0E˛%)şZ?đ@WŹ6|šV@0[$’Š1?đ@WŽŃőů@0÷ÁzMľ?đ@WşËúi@0ü[•ü{?đ@W˝ł#ň ˘@/ť°˙§Ö?đ@WČąçƒO•@0ŸĄrb?đ@WĎÝŽŞÁď@/Ę ę\m?đ@WŐ;3_'H@/ńŹC/ă?đ@WŰŔŔż°@/îÚâüL?đ@WéÛ÷‡@/ęmŃe–?đ@Wő“´ň@00ŇŻĽË“?đ@X5SO;q@0Sń Łţx?đ@X{у9’@0€Ć‘$í2?đ@XOšŐÉš@0ŤÚ~ŸŸ?đ@X&ĽääDĎ@0ŠŘÓcŸ?đ@X3ČU^+¤@0ĚÔ Xd ?đ@X86[ľr@1 ĽvXź7?đ@X<ł6üšL@1M9Ř˙)?đ@XL–ˆaóË@0˙óĂ8r?đ@XS*9Ńř@0°ÇrX­÷?đ@X^’”ŁL@0…\R†Ĺ?đ@Xj;;Ç @0s‹Šśô?đ@Xfœ§Ť@0ÓÝb{?đ@XmdžK€@/Ť€5Ďő?đ@XpsAl‰@/8dZU?đ@XqNiVó@.‡'%=)Ö?đ@XsN}ËYŕ@-ó@č>Z?đ@X{;ayŻ~@-k™p×Bž?đ@X~¨f¸Ńé@,×YfŔi?đ@X„˙˜ĺf—@,FŃą'&A?đ@X†ş.ô@+ŞŸűéW$?đ@XŠŕIłŘe@+dJœk7­?đ@XŽžš°@+ÇŢťE0t?đ@X–î…DŤ@+&᧡Ę~?đ@Xž˙Ë=ĺ@*¤AłÔÝ,?đ@XĽˇÔę˛@*€ŚË˛?đ@XŠÁÚÔĽ@)~÷݁M?đ@XŠŤ Q @(ńžŻś“Ë?đ@X¨śĺ÷ɢ@(dž[4?đ@XŠT–˙%ş@'Ć­Ŕt?đ@X°Ť-í@'ŢtęĺJ?đ@Xąœ—,Ż@'7ěż˙D?đ@XŽ¤0%ž‚@&§/ůŽ\C?đ@XŹKcňxY@& ÁŔ@?đ@XŁ!†á4Y@%ŠAÎ!^™?đ@XŸf M@%ţ€ ?đ@X ¤C (@$qžŇgśŇ?đ@X§éuA@$7A@Ţ â?đ@XŹËyâyˇ@$hËëĄQ?đ@X¤VEQb@#‡Ťý?đ@X  €źAż@#BB)?đ@X˜Ěˆ}!(@"Şa–˘:‹?đ@X–  M@"ł#5R?đ@X ’đ@!Ž5J°?đ@XŽX7i@!˛ą“Ą?đ@X™–Őľ9g@ }R˝ăř?đ@XŞ„ń2‰Ł@ —řÚDfj?đ@XľĆ˜:ŢĚ@ “ý}?đ@XÂ:űE(@YĹŘXúM?đ@XÍ×ěm@ž9ĺÖŞé@óĺ"4ĐŢ?đ@Xő$ˆW@kżţË?đ@Yö„ĽŸE@7]mł€?đ@Y DWď_@>ű j"?đ@YQs_&ř@;OŔ“?đ@Yuܝ@Śišžě?đ@Yŕ2ˇ+@ńnw=šű?đ@YO‘äđo@ČäŁ8Š?đ@YƋ\Ŕ\@ˇüžŔvR?đ@Y&Ę,;=@ÖLçěŒ?đ@Y&„ĆĚ/@ˇÖި|đ?đ@Y+T}źk@ĽY˛‚řď?đ@Y2Ś´ĐR@lB#žď?đ@Y=ąĄ˛i–@ fź}űě?đ@YHż {ŕ@ ˆŠřĂx?đ@YSP–xn@ Ž›;˘ĘM?đ@YUZr¨4@K‰'…%?đ@Ya5M? ă@‰?V §?đ@Yqyś™ô¨@_—#ŔH—?đ@Y~ž’CS @óv—™÷?đ@YŽ‹}.œb@›Óź(?đ@YŸ€Gў@˜¤TÎV'?đ@Y­tĹۈš?ţ2Oô€ź`?đ@Y˝’;ĐÓ$?űţƸK?*?đ@YÍś ŇëĐ?ůËU8]4?đ@YÚńß+×?öŰü“Ň&?đ@Yĺ˝" [=?őĘ&¤­y˜?đ@YůŒ}[ý?÷IŚ°8?đ@ZŁhľŔ?÷íä,ˆęô?đ@Z‚DšG?÷ý”LWŁ?đ@Z WƒKľo?ü˛Ď´Ý&‹?đ@Z śˆRČ@mŹŻa—¨?đ@YümLÔť@~ÇšŐ&?đ@Yň\M#@šaɋHE?đ@YăߝŠţ@öŢWw›ú?đ@YÜ%Éň… @ ƒbĚź0?đ@YÜ#_‰@ bÔ|§ Ď?đ@YÚ˙d â@ 7űžâU?đ@YŘf&A9Ö@ćýăá;o?đ@YŰr„‚ œ@š¤¨´?đ@YŢ+"F *@ŹŐßWÜ?đ@Yܢö<áę@ÖPićęĽ?đ@YÖ ~eTä@ă;‡Oř8?đ@Y͋žx5@čB3ýŻ?đ@YˆPg‡@Ůăzqš?đ@Ył$áű@€ĺĄ r\?đ@YĽPg/-ú@Eo=hó?đ@Yšˇp„óÔ@3mw}IŚ?đ@YŒ|űč=@ڐ˘ľüź?đ@Y|Ř?˛!‡@f?†ŕ”Â?đ@YoqĎŇĆó@0őpýň ?đ@YdɗCż@+MrhŔ?đ@YT@lY˝_@t='![?đ@YAŕ„ɤĆ@}ăűľč?đ@Y1AyČ,@śÚě q?đ@Y"Uó‡˜Ů@Ą†ť .Ä?đ@Ynţ}y@K NżM‡?đ@Y *ĄŮV•@Q`Í6ÁŢ?đ@Y+y¤ń@˘&lÄe?đ@Y֐PŻ@­ŠSŐ# ?đ@Yq'…/@LäŘtN›?đ@YăfƒÖś@ϕXŢŃF?đ@Yódyˆý@ďĚnÚĎ=?đ@Yj˘­ĹÉ@ ‰*Ô˙y?đ@Y´¤œz@ îčĆŁźz?đ@Xüńž„@!iŸÍ›?đ@XúĎH|[@!ţ_ńî?đ@XóBĐ÷@"ŠĄÍŮk›?đ@Xŕ8`˙Kr@"wÇ˝ľľ?đ@XŃŽp’`@"¤Yąi”ä?đ@XĚǡ¸‹E@#8 ˆy#?đ@XĘ'Śťq@#Čýů˜`'?đ@XĚ~y„Š@$]ÖHčl?đ@XĎJĽ4Â@$Ř7…zđ’?đ@X×A&čí@%djż˝g.?đ@XßtÜű(ď@%ăÜQˇ„ú?đ@XăyMcY@&yCđ?8?đ@XéƂĹÜ{@'đ?Lˇ}?đ@XňÜ2Ť’A@'Ň}z”…?đ@XúŸ Š@(ł%s?đ@YřŢ@(˜˝ţőćb?đ@Xţę“úó@).Ô?đ@YV;ă÷i@)žAežHK?đ@Y1ô@Ĺ@*GÎľ?đ@Yđ•U,Ł@*Âb$k))@)KÝřGůę?đ@YSSDvK˝@)DęĐEŔ˜?đ@YeBzœĽ@)Lć@Z÷c?đ@Yxw~+Lł@)7ňň …5?đ@Y„h™XzÓ@(˙¸zéyŘ?đ@Y’>%›FĹ@(§žUáË?đ@Y¤8@(FšÜlĺK?đ@Yą)âWűţ@'ďłŔô?đ@YšąЏů@'h´rŘŢÖ1&?đ@[DȂéo@-ZŁČ,+?đ@[<÷ËIůü@-ä ŰđXÁ?đ@[9>Ďňƒj@.qÉo !?đ@[.rş{úW@.ÜOŠ¸T?đ@[ žŤ y@/U5–˜ç?đ@[đoFčÖ@/Ď Ł'Ů˝?đ@[)ž˝ËŹ@0s.ąţ?đ@ZýÂP$3@0MQwËÎä?đ@ZírŘ 5@0{0G uœ?đ@ZŕćC^^@0¤VWĄ?đ@ZÎ]ý#u@0ŕ-I‰“Ö?đ@Zě#÷ý@1G65ň?đ@Zľiî6´ą@1H 9k?đ@Z¨=v˝ˇ@1~]QőFŒ?đ@ZšÓ„hó@1´Đľ¨<@?đ@Z›˝lt…Ř@1ËɢłţM?đ@Z™‹şĐL@2<8šh?đ@Z‹rů˜ĺL@2= …˜.˘?đ@Z}Žő‘Ď@2kĺV‡%č?đ@Zr Ěř@2ŽŇćsq?đ@Zj_ uš&@2çŹ0ůĚ?đ@Zo[)#›@3/+ˆŘĹF?đ@Zs@TdD@3v›Ďo˙?đ@Zx1Ó¨ł_@3šíΊ?đ@Z„ Ś×/D@3÷ĐU쪽?đ@Z“EĚY0Ű@4eh š)?đ@Z˘Ť: —d@4U4‘Ô“?đ@Z§jŽaŘ@4™†š‰L?đ@ZŻ*&C@4ŃúekW?đ@Z´.1âŚ@4÷đJŰ?đ@ZĆm+֞@4ýaő=›?đ@Z× áSÔĄ@5n_<„?đ@Zá€˙Č˙Ş@5P>J Ťf?đ@Zô"$S|@5y*§/á?đ@[Ţ.™´@5…Ěţ÷?đ@[%mBą@5œiB/‘/?đ@[ •âžý—@5ľ´& ­?đ@[%`Ë @5Ő<.ţPe?đ@[4Ž&2Ö@5´ hžWĎ?đ@[GĄČögĽ@5ƒÜ˛W?đ@[Y0@ŹŚ@5uůKPu:?đ@[hÁIŚa@5˜/ž:Ž•?đ@[wŐ*X@5a„‡?đ@[m,IU+5@5‹={•?đ@[o@Q‘Aß@4ÎDv™|?đ@[vmŐź;@4ad8F?đ@[4žl@4SŞBɸŽ?đ@[–âö}u´@4MGű7ä?đ@[œ*ă HZ@4ćNíšš?đ@[“ěƒ€UK@4Č Ń?đ@[^`?Ŕą@5\Ő;îŰ?đ@[˜/‡đV@5GËÉ/“˝?đ@[œ\<Ť÷@5NĽ™’š?đ@[ŤaF =@5W}Ş’lN?đ@[Ŕ݆˙Œ@5v™}UF?đ@[ĐJ?ă‚@5~iň`Đ?đ@[â̊(Í@51)T™'?đ@[ó„ ŘÔý@5ľ ŁĽÔŚ?đ@\0˛:˙@5Đh5|c÷?đ@\ӃÜm@5ÓŤTN˜ń?đ@\yR t@5í‰V˜t?đ@\+3ëŞó^@5Ú{Fßzę?đ@\?đ@]¤bö=Ü@6ř+íűË­?đ@]'Ě4)K@75¸Ŕö?đ@]*.~¤r¸@7PđÁŔX°?đ@]*ć*Ş,>@7a^‹}ß?đ@]:z4ˇŢ@7–ˆ˘Î?đ@]Lƒżľ˘@7§5㼐Ď?đ@]`x‡˘ÓP@7ŐÁVdŢ?đ@]o\ř@7ü¸Ę9Ä?đ@]}4ÝrNM@8(´ÁYHĹ?đ@^.°}m¨@;Ƌ~Ž ‡?đ@^-NI^Wƒ@;ţăüGsŤ?đ@^,‹iü6@< wg:"§?đ@^?Í;ëhß@<Ť‡Ęîä?đ@^Nş”Ľł¸@Ű@=Š@†Žśş?đ@^d‘[ŰČ@=„>îP e?đ@^}úZ%@=ÎďṤ>?đ@^}ę:ˇ7Ľ@=ć#Öm{?đ@^iŚŢPF@>öŠăń^?đ@^ZşAëá¤@>:(Řë8?đ@^G Ĺô!@>DYEŕSË?đ@^0™Ň*ˆĄ@>c @p…?đ@^ žĎ–ó @>;bO—!˛?đ@^‰đÚ@>KFnŔ+O?đ@^2ӌ-íw@>^ţ84=ö?đ@^ACŢ­ë—@>Œâű —?đ@^Sěl r@>ś`k{‡?đ@^fnG@>Ř%Œp b?đ@^vUA_ćP@>÷×$x‡`?đ@^lß~Ůŕ^@?Cü|t|3?đ@^[cŢ$"@?oXAŃzű?đ@^K’Ě_‹Ä@?ŁÍMC¸?đ@^7ýÖ6ä@?Ă_ś~€ă?đ@^+óď˜@?íĂ~™ ŕ?đ@^źč^@?ómĺGu?đ@]˙,{í@?őůŠý_]?đ@]îL°hœ@@vjđ‰a?đ@]ňĂIP:@@"l°Ď֚?đ@^ü›Â@?ýcȇMÄ?đ@^GčÔŮ@@ SŽ?đ@^)š Lƒ@@ gž‚Ő‹?đ@^<4™‹ěe@?ĺćí Đ;?đ@^PÖIˇĺ=@?ٍ,uŕD?đ@^düRzČ@?ÁrßÁ?x?đ@^uŚb}xŚ@?ËC"1V?đ@^g^^€Q@@|f,1î?đ@^YęEľy@@ţNSJ?đ@^N)*&?2@@ôä@B]íƒRY?đ@^ge•vŒ@BgśßńU?đ@^€ë&3A|@Byo „N?đ@^’Úr3@Br܂¨?đ@^ŸźˇőqÉ@B‡ěöEVž?đ@^¤Jޟţ@B­îdȲţ?đ@^‰¤GžË@B˝ňGŸ?đ@^vŠÄdč@Bş*Ą|K?đ@^^á‰ÜŻ@BÁěÁfË{?đ@^HbŔt%@BÓ1ŔĹŘ?đ@^4ގ ń5@Bç4Θ´?đ@^RÉ]íľ@BÝši‰w ?đ@^Ý4…Ůľ@BĘŕ‚jˆY?đ@]ű-×cör@BŹłĚĐçe?đ@]ěv×6Ş@B“y‡ěđ…?đ@]ÔđŸDO‰@B‘Î7Ú3?đ@]ŔśűfF@BŁŻSÜ.f?đ@]žÓýë,@BČ+“Š ?đ@]áKś@Bék{y×S?đ@]ˇâgb@C $ćnß?đ@]Ą˜…~ @CP@JđI?đ@]‰kŻˇL@CŻ„&t?đ@]u\I ŐÝ@C"’Ĺ_'?đ@]g$Ň@C?G“Ű`?đ@]e"žü?đ@^,mJ˝@D Z†,s?đ@^É]ş@DU)ww?đ@^&âúÝXJ@D6Cç$îœ?đ@^9Ę%ő…t@DVąďkÍ?đ@^Gń Yź@DoˆŽbçç?đ@^_XĘĘî@Dp˲•?đ@^v(PąÉ@DoJ"4Ó?đ@^Š‹bž:@DQŐČr–ˆ?đ@^‘ި{=@D2ŞĺŠÚN?đ@^€%Ď?)@DüĚX@)?đ@^qWÂUäČ@Cůľ(C‘Ž?đ@^`ąbu@CÜ!ƒo€?đ@^Xž;oŚ@CżHAœĐ?đ@^nÍŚ*u´@CŚçnLœ‡?đ@^]BQ/,@CƒČ3ŇRó?đ@^Q\Ě|Ó@Cka„ęp?đ@^pŢ2 í‘@C}3Œ”y?đ@^…Ą•”@CŃâśěY?đ@^•-ŘÓ¤@C­GʊŘÎ?đ@^ŠmĽ¤H@CŔ”Źş Ő?đ@^żCŘŁÜđ@CŇ=퉀?đ@^ԓ÷ěő@Cŕúçč›?đ@^ę~Q•É@Cę˝I÷Í?đ@_tf?v‘@C볛ßĐ/?đ@_–ŠD’¤@CůśŢ¤Hl?đ@_-ţRÄ3¨@CŘ]$Ę'?đ@_Fhž@ÇŹ]Ď?đ@_XÁďĘŽä@CšŒŰÚ'?đ@_Uƒ›Ž@C“b‡š\?đ@_Kň¸ŸÎ˜@CqVëß ?đ@_Vě#ă@C]ýbf} ?đ@_^Ź˜j2@CUŤTăĘ?đ@_DiűŸíƒ@CH˘?[›‰?đ@_9ŰČ2Űč@C"”–~Á[?đ@_7fň 6f@C űŠÔ?đ@_J‹J€@BůĎ* Äf?đ@_]Đb1÷@BçšőÓąA?đ@_r€g0@B÷}v8™?đ@_‰á~糕@BčoO'é?đ@_¤7BOŕg@BčBDź"{?đ@_¨ÔĆ @Bӄ0’ü´?đ@_Ż‘L:1@BĽĺ˘‹Ő=?đ@_łÉŮŚýA@B‹ qŤó?đ@_´ý_ŕ„ň@Btœ_?đ@_&=ů2@Bwçzńß?đ@_“ˆBŢĆá@B^6Ćóƨ?đ@_˘’z!„ß@B3ćâM?đ@_ĽÓPŽˇ@B/LÎql?đ@_ŻiMRĹc@Aó#˝D¸s?đ@_¤—]'l2@AËfŹqa`?đ@_™&ľ"ţz@A¨‹6‘ôŸ?đ@_–ě-é Ú@A†*¸gĺé?đ@_Ÿűő"K@Aeą(ĚĚÂ?đ@_›wÍN|@AL]S×ö?đ@_¨ôľ6$&@A2ÜÓ°ł˘?đ@_šŕ7\Ú'@ABK‘ Kż?đ@_Îń—M*@AOǗÎR?đ@_ÚäĄq ş@AI~U`őę?đ@_á“d7>°@A`ĽÚX¸ó?đ@_í§Š—&@Aq˘/í?đ@`˛ęr¸@A|‘ľ‘ŃŢ?đ@` Ažýێ@Az”ĂV)?đ@`ƒ™ç@AŽ×étŠ?đ@`!d ÎQ@AX‹ě t?đ@`* ţĺĆ`@AŠĐBís?đ@`-ý_˝ww@AÇn)?đ@`12ŒŔx @AîúИšI?đ@`.ŁYSż@B ĎQÉř?đ@`-W !m'@B1Dq…?đ@`.XßTŞĐ@BV%ź—‹Ç?đ@`-*Ĺř@B{šI”ő'?đ@`*iď@Bžá€˛’?đ@`%-‹ĆWć@BżŻ¤)ÖĐ?đ@``łQS@Bߞž‘Śţ?đ@`lU*@Bý—ščŐ?đ@`ĎľÜV@CÎ)sţ?đ@` ţĂóĆ*@C?•ůŚés?đ@`ŕ¤Ë"•@C^E˝“ŕ?đ@_ü˜3ňu@Cv);c„W?đ@_ë2‡A@CŽÝ ˛Pß?đ@_ÝşŕĎI@CŠ˛ĐŒŇä?đ@_â+ů!)@CÎuá8 ?đ@_ěŻ8źÍŻ@Cę_YĘ?đ@`˝§*@C˙<ůŸ7?đ@` ‰ăĚž§@DőF__?đ@`dx疍@D "†A˝˙?đ@`2Ái€@D6–Ó"Xđ?đ@`'rů,@@DRMgxČş?đ@`1s:sWy@Df}´Áď;?đ@`7S%‹6†@D™˛´ó?đ@`85ƒ“F@DŚIk§;í?đ@`6’ćłö@DÉ]>pÜ ?đ@`<-1Y@DęKŹ+ďű?đ@`Cj1Ŕőâ@E‘ŮRކ?đ@`LKrŽ#é@E!učő?đ@`W3~?Ý@E. €‘Đî?đ@`])ÓJaA@EOlŸ˜ű?đ@`iCƒĽÁď@E]ţŽT.?đ@`oX҆1á@EyDUƔF?đ@`vćĘÝ@p@E™3p˘×?đ@`}ĎŔ!Ěż@Eœ)Śóš??đ@`‚ő_c@E” Ż%đ?đ@`Š(殊ú@E–ŕddď?đ@`uGIm@EqísŘ?đ@`š†neÚ@EhţY˘ ?đ@`Ľ˜”u@E]W­őe„?đ@`ł‘Öx:j@Ej7“źý?đ@`žĆIĎ÷Y@Ev™i3ťw?đ@`É'ó%ź@E'zW˙?đ@`Ô"͖<=@E Ţ:qÔw?đ@`Ţ7čţŢ@EˇKŹË?ť?đ@`ç CÍ`@EÓPŞŤäÜ?đ@`ď EŹIW@Eî`$DK7?đ@`ôg”oF@F ý/Šoř?đ@`űp]đŸˆ@F+â¸Ő1œ?đ@a^Aؘ@FD7§ńe?đ@a rAăx@Fbě)Ę`Ş?đ@ažE @FϐŽĽn?đ@a„°´@FL X„˜?đ@a&EOy@FˇďťAr?đ@a.ŤžkgĆ@FÓĂí-Ůd?đ@a7N%Yę@FďŔ„„Ÿ—?đ@a?<÷žĽ@G ¸T‘Ŕ?đ@aEDœ˛Ę@G.F`ž?đ@aK‡şëĚ@GN|˅œą?đ@aOŸBĐÁz@GrĎRCG?đ@aV`Şlč“@G‘ŤöYaX?đ@a_AŃŤCD@GŽBi˜|?đ@ae+V‰Đ@GĎňV-oY?đ@akóąă’@Gđ,S"™Ú?đ@auoʇò@H ţaÜ5?đ@a~ÜjéZ%@H''̙đ?đ@a…ˇœYí÷@HF#Ť+)ś?đ@aˆľĘŘÓ@Hjü˝r›?đ@aŠI?Ń @Hˆfg žŘ?đ@a˛¸;jj@H­Ń°ć‡•?đ@aÔO“zy@HŐŇäÄ~{?đ@a•_´@HřňŚ2 Ĺ?đ@a’B)ŽÍC@IOtÔ Ţ?đ@aĽxIS­@I>tŐ]LV?đ@aná8Ą\@IbzNᆋ?đ@a•ˆH˘K\@I„ě\Ę°?đ@a˜ăř#…@IŤŃ˜Qť?đ@až^ŚU–@IËKuäz›?đ@a§‘ü”@IčÍnýIç?đ@a­O°$x@J UˆÉ9?đ@aŤ[šô€@J!ÔŃŁ)??đ@aŚ‡ńZg @J@>™[Xß?đ@a§4̛@JdÖ˙M?đ@ahżŢ˝5@Jő`n§?đ@a{ÚË|ľ@Jˆr/ČD?đ@aŞWěč@J<ÔI?đ@a§|DE‰@JŞČî"^;?đ@aTLâˆő@JŔ”Š@ž!?đ@acžLœ@JŰë$ú?đ@aˆ Qp @JücXe/K?đ@a|ŮľçŤV@K/ňr ?đ@aqŒŹrŁz@K)- )?đ@abZ‘îí^@KL)Ρ?đ@aWC¨˘ť@KĐqÜ)^?đ@aVjƒ=ř@JîWˇVł?đ@aPyÂUĹ@JĘä'… ?đ@aJŽ÷łÝ-@JÎ(ÚE?đ@aM!öíz€@Jě v!´?đ@a;ĖwtŽ@JĘŢBĘ.Ň?đ@a-¤´FŐŐ@JĐđÉ|E?đ@a4hĐV†@JůżŸ˜ś?đ@a.ă6‚&!@KÎó ?đ@a/ԇĹ@K$:‹Ř%?đ@a%ĂŰpě@K )L?đ@a úzn@JëOţŚćw?đ@a]Aílw@Jóuw;fN?đ@a4üŽÔ÷@KÔ8}ćb?đ@aâŠ5.ä@K=Š}OĎý?đ@aŤŞ•"g@KP^qV+?đ@a˘ŘIM@KL _ơ?đ@`ô)K'.@KQŃÖ#C!?đ@`ç”8Imw@Kh¸SţBs?đ@`đc:,Q‘@KŠÄŔM??đ@`ţ­żâ@KžY3oyŰ?đ@aţ™”J×@K¸˘V›_ö?đ@a‰5Ó!Ÿ@KŃÉ\”N?đ@a!;PĘň‰@KçÄđÔĎJ?đ@a-_§[4@K˙V׎5Đ?đ@a8Ý^ÉŢ@L~¨ Ř?đ@aCv” Á@L:ß_k9?đ@aJ€3Mť@LZdo˝Â?đ@aTŢ>çQ)@Ly¨Ls?đ@a`MŮ+é@LžžČ´?đ@amČîw@LŞžÖ đ?đ@az @yZg@LÄçÉü‰˛?đ@a†ŸjHA@LŢäVbču?đ@a‘ éâ@L÷űŢď6o?đ@a–réÔ=Z@MŠ‘Géť?đ@aĄôŁřÇX@M7“Ń6?đ@a°–‰!ćÁ@MMCśÉ\?đ@ať;4‚—@MjŘĆcmâ?đ@aĹFĚÉőş@MˆĄ}˛!?đ@aÔMÚP/@MžyŠ†Í?đ@aĺEĄčŔ@MŹNRßĆë?đ@aöĂŕýĐ.@M°‹*Č#?đ@b ÂçĽőŞ@MąÖŰî%Ł?đ@bB“Ë×%@M°Ęť#6–?đ@b-_ă…1—@M´’ąQÄ^?đ@b;pTˇÎ@M¨–œ^Č'?đ@bG_6—Z@Mœ‡l‡„’?đ@bR„)ąÄE@M´ďOw‡?đ@be5C;˛ @MŞŇv´h4?đ@bvÝ}‰@MŚ‡zj?đ@b‡ëQÖŔű@MŻ¸c–˝/?đ@b˜]>SĘe@M˘ŤŢĚ?đ@bńŕüŃ@Mź•“?đ@bŞý4›w@MÝ˝¨Yk?đ@bť:ĚÓ?đ@cKü{BR÷@M“mWOąă?đ@c^ÎŔ˙Ť@M˜I6Ybx?đ@c_Ů+&îK@Mś“A˜Ś?đ@cN~€Đ@Mž¨ő;ăŃ?đ@cF썠’@MˡŐ ?đ@cKS=G„÷@Mď"łş ?đ@cSĆńđ–˜@Nő˛â3ś?đ@c^ÔBŸ˜W@N-J—-m?đ@cm=ş>ˆŁ@NEŠ”jšż?đ@cz“S˙đA@N_Ďú­e?đ@cƒ)ÚňB@N<ĚŃ}?đ@c‘T˛ÚĚ@Nœ¤Ś?Ŕb?đ@c—Ý÷~5Ž@NżFä?đ@cŚç0żŒ@NهÉÄO0?đ@c¸ËŔ @@Nä[@SÚO?đ@cĘ}M=8ů@Nĺčj›”y?đ@cÜ Iƒ=@Nďim[Ł?đ@cíȕ*@NçáčlĆš?đ@cř˝ű!@NÝňP`q?đ@dĽG™N@Nç*Áź?đ@dÁńűă0@NšËĘ•?đ@cü˜Ś‘_#@NfO‚î?đ@d]Hj-°@N{Ëj*%ú?đ@d §<ÄŃ8@NZŘHŘ?đ@dăűŹĄ@No€•ƒ?đ@d)ŮÁźŠň@N‹œľE ę?đ@d6ŹŤv=b@NŚŕGĺ+đ?đ@dC`Ćć@Nž¤“r´9?đ@dV„ťŽ¸@NÓŤŞ§ăĹ?đ@dcžŘsĺ&@NÖAoëťŰ?đ@dbÎY ÁŹ@O5ÂČ`?đ@dftBnE@O'™Í°q5?đ@dkă[†%@ODú†[ŸĎ?đ@dËý™´˜@OR­RąÉ?đ@d’Ěç# ë@OS*ßA­N?đ@d¤äüˇŒ2@OAÂO\eý?đ@d¨ů÷Ţú+@O6 ˝găś?đ@d‘¨2b’Ü@O6‚•0˙6?đ@dƒť~Ć @Oăş)C?đ@d‚ RCČx@Nő]SëŮ?đ@d}yXA"@NŇžĘéÓ6?đ@d|Ü/˘l9@N˛G➐:?đ@dvW0ˆć§@N’z%1|f?đ@dqÄŐŕŇ@Ns“sîߜ?đ@dc xňőZ@Na‰€ž$!?đ@dOěa7L­@NLźôś?đ@d?Ť ÔQ@N4˝‚ág?đ@d8’Š!’@NÂ{…í?đ@d+Ë ‘•@MúŢ^č?đ@d ÂÁ|”@MÜţ6űčp?đ@dJ™ó+@MŸ…ă•?đ@d?C›˙Ÿ@M¨ov´S?đ@cú¸ F-Z@MŒÉ%~§î?đ@côŠP eÓ@Mj–œŽM?đ@cčŕőC@MHœ‚čÂk?đ@cŢ&Ž.÷n@M0ű8v]4?đ@cĐŚĹ°ć@Mƒ‘çcQ?đ@cĹąůݞ@McĄkQ¤?đ@cłk˘Rđ˙@L÷'—%˜˜?đ@c¤,ý––N@Lć81ł›?đ@c›ůőA‰=@LŘ4f§ĘŠ?đ@cěJ`,@LąüŸÉŃ?đ@c•w†tŢŁ@LŽ`G 1?đ@cŠŕ…w ŕ@LthšFÎŘ?đ@cŤ6Λ@L^\9ԛ?đ@c{j˜é™Ö@L4ăżuŰ?đ@cw›5ϛÚ@LŔV^?đ@ctŽFîhÍ@Kě ńшÜ?đ@cs ž „Ű@KÇŃŹš???đ@cqǧ ž@KŁâ˘\|?đ@crö´L @K~%Ô:ů¸?đ@cuśƒ4@KYyAĄ?đ@cw{)“ś1@K4m&Ëö?đ@czŮów1@KçĹYĎ°?đ@c}“Ż‘ú@Jë”7đ‚?đ@cx€JRĆ@JĆŁs”ő€?đ@cd-"aą@JĄĎşéŐ?đ@cƒ<âžď@J|˙Ÿu?đ@c…ä҉DÖ@JXĹ(![?đ@c‹sZŠ@J;Oř‰r?đ@cŽϗ<ƒ@JYIj^?đ@cÍ4ó*@Ií&A&Ía?đ@c‘hž¸w@IÇŔű ×?đ@c’óÔ2z%@IŁô]üň?đ@cštBLÄ@IƒyŽ?p?đ@cŞ–ůđŔ6@IĽ˝\¸Už?đ@cłăTp‹ŕ@IÁ TťR˙?đ@cż$ŠŕŃQ@IÚ­¨c(ë?đ@cÇŮĆMq@Iů×,Dd(?đ@cÍć=Ć͛@J•wă¸?đ@cĎÄŇŻ]@J=0đ ]}?đ@cёŔP\@J^ęÎ4˛‡?đ@cÔ,Rϐ@J|gR¤‚=?đ@cçł &‚@J’^‘X_…?đ@cöÄHsˇ1@Jbü{"?đ@c˙ Š™üÖ@JŸ'}y ?đ@cüPÔŰl0@JČË° š?đ@cűż_w@JíůZ?đ@dń˜ť @Kę­Ő@ƒ?đ@d íšŇ@K+8éśú[?đ@dX¸$Ă@KBŽ#őŁ?đ@d'9™E Ú@KEe×Üy?đ@d6Ȕ•×Ž@KE…ň!a—?đ@dB< 5ĆŔ@KcI˙i^ú?đ@d=š Úx @K…’xΚ ?đ@d7Ó Js@K§;˜‹Ů?đ@d8Qƒ˜O@KĚ#ćt™?đ@d>ô7ű™@Kîqv˝•A?đ@dEnP‘ľ:@L40ůÂ?đ@dOÓţ}M˘@L+>˛çYň?đ@dZe +•÷@L3°Šĺ a?đ@d]=ŒŔJč@L ţ< ?đ@diäZŇşI@Lř'¨-?đ@dgŘ+ďą"@LFtĚş§??đ@d_PŠ|m@L_ 1;UŹ?đ@dYĐy{”@L}Ó r?đ@dXšÚýç@L¤~zě x?đ@da Ńb”z@LÂ+\‘Jţ?đ@detŰI`&@LăչȈ?đ@dT[îj@LňŽ>™´?đ@dIe×Ö-@LäšlÁ0|?đ@d?!(@M3&Ži?đ@dBáž[D@M,Í(_?đ@dJŻĺ‰Č†@MN ` ?đ@dV§ÔčşĎ@Mkę/dz?đ@da­kj@M‰ŮŁř|?đ@dgޏFgJ@MŞ:á ?đ@dižŽÎ•.@MРǟç§?đ@dqΓ۹~@Mń ބv?đ@d˝ŞBł@Mü›Ő¸q2?đ@d‘Óˆy&@N@˝ŞV¸?đ@d é€Őw@MńíőÓÔŢ?đ@d§ZŔŇX\@NÝkE?đ@dş,éW%ţ@N(_“tš?đ@dĹäćÎĘ(@N1ŞnŚřđ?đ@dāĐŇsK@N Őšŕ?đ@dĘŠÖڒł@MńŕôO1?đ@d×XSÚŢV@N•Ŕ>6U?đ@dăˇŘĆ@N.YŞFóő?đ@dóNfęG{@N<Ľâ=t˙?đ@eđ(%Ć@NIj^ŤK?đ@eNWă‡d@NHRűŐ?đ@e)ÉMš‰@NFž1łG?đ@e9m+ÝXÝ@N%Śś¸„%?đ@e@.Z84@Nü;`Đř?đ@eL.ü#ňÎ@N™_ó'?đ@eRŐîÜ8@N.OH ď?đ@e^GEŃ'@NCx“—?đ@eoźš’Ü@N]H˜ź?đ@e~SńŻqľ@Np˛ ť?đ@eˆšĐj@N‰°4š6Ź?đ@e•f>‘GO@N şŐ€Îň?đ@eŸ…ż†d@NľMrŃGa?đ@e°œů%Đ5@NÓ$ŠhÓB?đ@eÁ_‡3z&@Náጽaí?đ@eÓţ!çÚ@Nň‚ÄI[?đ@eç-šăY3@O­J88 ?đ@eő=‚Hô@O{Ŕ7ˆ?đ@f"ČÓ;é@O)(ÄA ü?đ@f˜ŽÓő@O?ŕxi9ő?đ@f!ČŽ˛xJ@OS ‡Ą2Y?đ@f'ÚĎŇd˛@O`ćUl?đ@f2ĺÜjçÖ@OI5Ą7;?đ@fGZJĄ@O?´ÎÚ*í?đ@fYŁă*Œ@O0¤ž 3?đ@fešcĽ•@O5Îd?á-?đ@fpł †Ü‰@OTőŮ:Œô?đ@fk’—UČŽ@Oz}{ô˜„?đ@fg ڱќ@O›‡)ŁÚ˝?đ@f\…Ţü:@O˛2˘Úd•?đ@fT n‘}™@OĘV´_?đ@fQ*ädů}@O˙1â$Ź?đ@fKŁl“ńŠ@Pđň3‰|?đ@fAłY¤Ň@PDÓĎË}?đ@f-×ő^PŻ@Pł'ýćß?đ@f%Ýe S0@P,÷ózž3?đ@f úíË)Ź@P(č F?đ@f•5¨@P+@BŃf?đ@e˙Uß@P5~éß–?đ@eéKlź(@P/‘lPIL?đ@e݃¨­ů@P-ëń˜<ń?đ@eýó˛”D@@P7’iŃz?đ@fŚîš T@P62ď,ř9?đ@f\Tčw•@P:äŤTí?đ@fl5] ľ@PCwfG›?đ@f+eR›R@P9Ϝ~3?đ@f9ĐčÝ@P-Ɩí: ?đ@fPw zŤ@P)™Eł?đ@fbq€@P0+Ý\d§?đ@fsœĽ`*Ń@P9ó4Ža™Ŕf|:yĹC7@PG|0¤Ą€?đŔfqYqŁŽ@PVĎi;ŇY?đŔfmŁbăOß@PhXźő­Đ?đŔfxřľÄÉŕ@PyO?Ezď?đŔfq~îłżd@P‰yoŠŮ?đŔfb]ăţ//@P’|Ń™ć?đŔfRӊ'ł@P™ƒş**?đŔfZŚ‰‡ť@P}AƒŤŠ?đŔfQ"áT§@PjoA^ż„?đŔfEŇKœž@P^Ýč§aZ?đŔf/Ÿ-Ż™@P`Ă|âő?đŔfÓjÚÜ@Pe]9Źň ?đŔfqůu:í@P]üxu ?đŔeűrEdŤ™@PNŤ(˝?đŔeöŸOęř÷@P<¤•f?đŔeäÇMŃ@P3r.  ?đŔeΚoć¸G@P+X+‚?đŔeÁςŁˆ@Pߛ)×?đŔeŻ Ü SQ@P3l?đŔeŤmž:Ę@PŔöżĺ?đŔeÇ{ţ$)e@PĆ9_1Ôy?đŔeËŞ4VPŔ@PÁ‚¨*Ü?đŔeÁ^TşyŚ@PŽŮ$€V?đŔeŔK\>­Î@P °–ü˙?đŔeĂÂ+Řę@P–âsܢ?đŔeω3ŹöÍ@PœŹt#D4?đŔeÚpĆ{F@PŹň™`Y?đŔeŰš`@Pżß¤q‹4?đŔeÜb8Â@PÔ=k ?đŔeçđÜç@PŢźDďž?đŔeőźĄŤ @Pń~Ž"?đŔf ƐV‚f@PüGF!>&?đŔf„›‚W@QŘö­˛,?đŔf1Cˆť~›@QÜłđn?đŔfB2˛Wšƒ@QuÓf]7?đŔfUčoÍä‡@Q(+.לý?đŔfhúIjÓ@Q5ĘŞŞ?đŔfvŇň2Ä`@Q;Žě\´ą@eô\Yşěw@QCŠéť&ń?đ@eßííž8@QQ@Qˇ2҆ ë?đ@cŽů­O@QśŠ˘D?đ@býžDę@QŔą(>?đ@bđÍÔ­l(@QŇç&ćńö?đ@bŐ˝óËrr@Q՞Ź&$?đ@bČĂ]?@Qً5MŸ-?đ@b¸ńPŘťˆ@QčCžŇ/ó?đ@b§݅•@Qńč’._]?đ@bžkÂŃ+I@Qţ,äŹ}?đ@bŞÓ€Ww:@R XgQó?đ@bŽF‹Wd@Rő*ˇ’€?đ@bnĂËJĄ@R™f<;?đ@bYľL#,@R 5!ŹĽŤ?đ@bI˜7ěcn@QřţX‘ľí?đ@b1Ž•|šœ@Qí­wă˙Ó?đ@b#ÂqqŔ@Qő'ň Ňő?đ@b7,|R‡@Rż}ű%}?đ@b?´ŢĎ´˙@R㜣y?đ@bFé%†N1@Qýł„šĚ`?đ@bQ(?¤x@R6ŽŃÄ?đ@b+łbrŰ@R$WžÎ?đ@bő|Q>@RF,/5˙?đ@bGĚPď–~@Rí§Ę?đ@bNžŸ÷üŁ@R äΕ?đ@b/mOÚs@R"waűÎ-?đ@b”‡qęT@R'`ŻšŚ?đ@a󙫨ň@R+/ąh ?đ@aÔLՎœŁ@R,ŢžĐg?đ@aľčłkä4@R1$ĎÉë(?đ@aœku,o@R1pžű.Í?đ@a”÷Ë9ą‚@R!"ZC?đ@au­ Ů9Ž@R"?đ@alĄÓď@R žECîŽ?đ@a}tŔ—'Ď@Rö^6œ\?đ@asĹ T&•@Q÷‚7Íî{?đ@ax(F€ŚŰ@QŕúqÖđŠ?đ@aa٨){@QŕÇdĺ5,?đ@aKώӯł@QäŃ~=ÍJ?đ@aAćŽÂ@QÓË÷ů5`?đ@a5´Xâ0@QĎĆZ7)?đ@a'B*Âk@QŢŹôłŮ(?đ@aŐK0a@QçĽY˙W?đ@`ç‚˛ŕˆ˝@Q⩆ĺů?đ@`ŇX3 ŒZ@Q×PDj?đ@`˛ â4HË@QÝŁŐüŐř?đ@`žĐƄŠů@Q뤒őšc?đ@`šÔ&5@Qňţ:lšq?đ@`Ę~?đ@_ťČ˝\‚Ÿ@Qý ŠŇY?đ@_žCMtŐ@Ró“”1“?đ@_kGľĆÉ=@R4zՄ?đ@_=}â$Uƒ@R#ŠK­—E?đ@_hčšyű@R,|•€eÔ?đ@^̸i5Ü@R0‡Ş.:?đ@^rëFÄ6@R8htĘ?đ@^Y¸AŘÎľ@R=b ĺŚ?đ@^Es‡@R>Ýëć*?đ@]ů <˝|¨@R=úÄÄ›?đ@]Ľ@„“@RM€Ç͚?đ@]˘;ŕŽ&@R_Çźu?đ@]WurOČe@Re˙l5Ń?đ@]‰ÖŹĄˇ@RjfΝl6?đ@\Ő0j„˝@RktI"ä?đ@\–Œ‹t@Re_jÝ”7 ö@Rč~ 4?đ@\<9(ąs@Rďɏ4˙ş?đ@\l[ ś›Ď@RęÇšn˙i?đ@\dÚż?‹H@RýͤĽŠ?đ@\;üœÎŰ'@S sĆňßÁ?đ@\Çi$y@SŻúr‡?đ@[ÓŞGŻ4@S+ŻlŞ+?đ@[Šœ——Ť@S.S† ĽP?đ@[6ÇłŤ˘Č@S.Ž>úiÎ?đ@Z÷Ĺł”~@S'rˤ°N?đ@Z˛.óŽ@S&–ú`?đ@ZĂdzć)Ť@S=ŕpň?đ@ZpŹP§ň}@SC=?đ@Z: •0ńľ@SJӠҒÔ?đ@ZrJŃŢţ°@S^Zyü˝ź?đ@Zž¤ů@Sk¤Ŕťž&?đ@YÁ<ܜ‡>@Sel{2kŕ?đ@Y†WŇľÄB@SW Üľů?đ@YTł>‰¨@SFl͘/?đ@Y?ň_Č]@S6 ™~[?đ@YNĘ~¸Ú˝@S#;O”“Y?đ@Y`Őy´…ž@Sť/Ť?đ@Yeć€@Sr‘Ęr?đ@XËŤ4˘;u@S’Ź6×í?đ@Xő_@dď@SHbąŕ?đ@XáÄȝď>@Rň‡Ĺză?đ@X𝆩>z@RŘPł¤?đ@XÜ î4 Y@Râ? 5+Ŕ?đ@XŮé„T š@Rň˛=ł§?đ@XăE‹ ›@Sşô˜çĚ?đ@X¤gş;L@S JgşŽ?đ@X\ńĎ7p×@SQ˛ž˘?đ@XĆç~˝@Rűç㉉?đ@Wú'z>˝ř@S#˜ç\?đ@WĎło@A@S§w$šC?đ@W‰.[Ә@SęĂ\k?đ@WV¨úâŽö@Rýˆˆ?đ@W„@?@Rđ4 Z§‹?đ@VĎmó´7ý@RéĘř›?đ@V†Ţ;ÚĎÜ@Răű*1ô?đ@VHœ‰Hů9@RۄăüIB?đ@V†x@RÎ=x7?đ@UŮ9ĹÉ__@RÂÝzűxŇ?đ@UžŸçÁ@RŻÜŽœů?đ@UŸ ­Č¤@RŹůżc7Ö?đ@U†­Onß@RŞĄ…ë^~?đ@UşZ€~Ký@R›ją/)?đ@UŹňQüťé@R—•Šœ?đ@UŽ/‚Âc@R“ŕĘőů?đ@UĂš |Dä@Rƒ{6ugB?đ@UÚPňŒÎ@RsY°Tb‹?đ@UŻĐý„@Re‘”Ť„?đ@U~uá2đ@RZsfŠ$?đ@U¤v‚Žż”@RJOŞY6Ć?đ@UŁť8 YÓ@RG—É|1?đ@Uy7—Ň@RY䈰ă?đ@U™ćŔ￈@RhÇUŤ.M?đ@U§Bؘ´™@RvHě:W?đ@UToĺhĘ@RoؗĆYŠ?đ@UČâéIJ@Rn‹R#?đ@Tғ/ˇs[@RjkčŮ#w?đ@T˛ó5o”@Rj"?a?đ@TMÇÁTľ @Rfâeěo¸?đ@T!óLş@R]Ť}„Ź-?đ@T¸6Ž˝@RKÚ?ŞR5?đ@T2ˇUq@R;FúG?đ@T.1ëŹ5˛@R(U˜> ë?đ@TJ˙df`@Rč@:‹?đ@T…Kv ]@RÂ==N?đ@Tžý„iů˘@Q˙œ%§…~?đ@TĐžVqČ>@QôĘ~ŽŚ?đ@T⍨Ň*@Qăzw›&¤?đ@TĐËŤhŻI@QуßÉŽ…?đ@TÔŰź3Ë@QÁIžVî?đ@TçJY ƒ@Q­×g™ú!?đ@T鿨ŠŔ@Q›Šb#Ć5?đ@Tž‹şĆ@Qőe)÷Z?đ@TĹŃÍËA@Q­Ąanaý?đ@TŻ“ď*e @Q¸&îQz?đ@T“ čÝ@Q¤ľ –Š?đ@TŽ ƒůĚ@Q™ţDB--?đ@T”ˆŔ(ü@QľyL¸ďÍ?đ@T’Žsż@QČěĄĚ;?đ@T­œíIă?@Q×R‘6Ś??đ@TÉȸľŐ@QčN—§?đ@TĄIŠń@QďšU+ź?đ@TdÝöÜaý?đ@SAÁżLŇn@QÚ8Ě(<ä?đ@Ssëtá1@QÓą5Çm'?đ@S˜î ?úň@QĆ9ő ??đ@SŁFF• @Q˝Ü[Gs?đ@SI1Ó.ÎH@QÉt¤Ű-€?đ@S—ým@QÍt;oor?đ@Răáßľˇ@QÓj÷}¨ź?đ@RÚP2÷Č\@Qáéž Ë,?đ@RŇ;XԞP@QőP3'ćŐ?đ@RáÚÁrF@RIˆËş?đ@RéœF§¸˛@R';NÔţ?đ@RŕˆÉÔ)r@R*xˇşv?đ@Rż05 l@R06Pýąr?đ@RĆ7!­@R ÷c›˝?đ@Rš=˛bĺ@RW Ńôš?đ@RŠnbÂ% @Qü58wŹĐ?đ@RaÔÚߘ@QďíYyˇ!?đ@RLŕ~\W@QÜáK^÷Q?đ@Rf!Őűí@QĚ~ô_#?đ@Ryž'łI—@Qş€v•MŇ?đ@R‘Żąƒť@QŠ}n 0Ť?đ@R…ĺß˝@Q—ßÓĂđ?đ@Roœ ó˛@Q‡Ĺh{?đ@RfŐ]÷ëŹ@Qtdő^u?đ@Rp‘q¤ąg@Qb˙Îya?đ@Rtk8šŤę@QPíGŽJ„?đ@RŒşňýĚM@QGrGŰĺä?đ@RÂE–‹?ź@QH,žc’„?đ@Rň%öŃľ@QOlŢŕ0?đ@S$ ˘L6@QH@úçgż?đ@SNĽÔ^5@Q>ÓzŢ?đ@SmR§€ú@Q1ˇ{ľwu?đ@Sw–d­Öv@QÎ Ęv?đ@S{śś"M@Q K*j?đ@S`Ź2Âyą@P˙{!…?đ@Snf;ń{@Pďtč}šÓ?đ@S*@˜„Ś@Pé™ü r?đ@SŤj ‘OĚ@PĺHŠźp?đ@Spąižâ’@P價žq?đ@SMč€S†@PóÉăFú?đ@SPÔ­ľn˝@QnŁŒâ9?đ@SP!ă-ˇ@QË!ýž˙?đ@SCŠL•)'@Q'ó€˛ď?đ@S':ß ľ@Q85WÚL?đ@Rý0xéÜ@Q<ťFóz?đ@RĚÜč9œp@Q6Ňöƒ?đ@R˘9Vô8Z@Q,?Ę;§Ş?đ@R›c/2O"@Q˙fäߎ?đ@RŽ5˜šÁÁ@QŠ"`]}?đ@R˛ÍDĐ7l@PőF˜ĹúŰ?đ@Rž…b@Pĺ ŔÄy?đ@R€“íďęť@PÖEĎř؃?đ@Rw‘"9\¨@PĂĆçŔj7?đ@R[ůz\Ě@PľŠrćů?đ@R6Wöęr@PŞąé%xu?đ@RŞ Œ˘@Pžś*9“Ę?đ@R4óÝ÷@PŢ­‹ą-?đ@QŇ%6)ŕL@P–Źęž$?đ@QŁ;ľ¨Ç@P–N›î:?đ@Qwř ˜0@P›Áˆî×ç?đ@QOlěúý@PĽB÷Ŕ?đ@QVPxT@Pł—ŒüX?đ@Q…çäŘë@P°ô3Ëß?đ@QŤBu]Ž\@P¨Gţją˛?đ@QŰ]Ô^Ň+@P­ÚA(^,?đ@Qç¸Â—x@P˝rhß?đ@R|†4ýr@PÍ/‡KĘ?đ@RÖé'n.@PÝA„ě,?đ@RX˙GYä?đ@R#-ń´9@QQxž?đ@R%1ĺ§h¨@QbŤyÂÜ?đ@R(Ń>,Ô@Quč:ý0a?đ@R"€byž@Qˆ”KôIp?đ@R)ní‰Ö*@Q™Ě•ú›Ş?đ@R0[Çnc@QŤŽTë7‹?đ@R-Ě0Hů@Qž? o"Ŕ?đ@R‚ ŢCĘ@QÍ䊔×č?đ@Qű¨ Œ@QŢäsÄ"Y?đ@RĎ5›o@Qďö(…ô?đ@R&jżJc%@RbNs{I?đ@R3ć˘úç‰@Rgv´ľ?đ@R1¤:dš@R'ÜUąf?đ@RC1cĆ@R3DžÁP—?đ@QŇňŞä„@R9‡ËŐ°'?đ@Q’ąr‰@đ@R9#üŔĽÎ?đ@Q\ľdKÍË@R8Ä.ǧ!?đ@Q;Ł¨‡4t@R$ú<‹N?đ@Q1}_ő´S@R>áBÄ?đ@Q&Näp‘@Q˙˝žLŚd?đ@QO”9| @Qíőřzżƒ?đ@PňzŞĚă–@Qßź`ţ0?đ@PÄÜžá°6@QÓż"°ß?đ@P°zO€?L@QÂźœ~z7?đ@PźFż@ž0@Qł”Ťúý?đ@PФfŠ§@QĽ šł?đ@PĘySoĹä@Q’Î;YŚ?đ@PƞŠĺ@Q‚ąĽ\Ťč?đ@P˛źĆźQ*@Qoă Kő+?đ@PÄLŠřZf@QgĄ`›wľ?đ@Pţ-ěC5@Q_L趋´?đ@Q iyřČC@QM:¸O‹?đ@Q,9śt@Q=”˝Ôä?đ@QC–<źO@Q6Ţĺ~w?đ@Q3\“‹ŽN@Q"lĚ n?đ@QÎ)řě@Q;xGý?đ@PéÂżœ@Q$ Ä Đ?đ@PÄÇťŐâ@Q31óžIó?đ@P™HV?łĹ@Q=?żˆ?đ@Po]TŃŇ@QGŔ”j.?đ@PwăœoG?đ@M°´äĚ@Q3˔’ˇV?đ@L¸Q^ä;ł@Q(ŢÍ Ąœ?đ@LXš§ÍF @Q&#¨çé2?đ@KúŽy˛ű@Q'A‰O¨?đ@KœZ,G@Q &Í3„Ť?đ@K[0šŠX@Q€#ŞŮ‘?đ@KŃŠ_‹8@Q 뇙×?đ@JʑÉęv@Q]šVH?đ@J熾-ŤĎ@Q)4 'Q?đ@JőߏG@Q9xí?đ@K‡vć¨@Q?>ˆQœf?đ@J§t]ű(ˇ@Q8O…‡yČ?đ@JT ˝BÂť@Q-Ăšš?đ@JE°8,v@Q"¨!ŻŽ?đ@J4‡ë=ř@Qx z^‰?đ@Iśř†‹sY@Q0Ýdń?đ@IZ[=Ăaö@QÍÇQ<%?đ@IŐ`ăĹ@QĽšEťś?đ@H˝"žéő0@Pü(4‰˘R?đ@Hků°ň<„@Pń/žT}?đ@HÚ÷`{ľ@Pé)ŒĽ–Đ?đ@Gď Ýn@PÜřL7Óě?đ@Gß-9`Š@PĘšßěn?đ@GžG&Ž@PşČ ”s?đ@G_(ᄑŞ@P´˛6Żé?đ@G%<ş8@Pľcš”V~?đ@FبŇĺ.ľ@PĂ`Ń?đ@FŸżÇ6ăŞ@PĐV226Š?đ@Fƒá-ďR@Pß>eE/?đ@Fża*ř€ő@Pî I*]Ż?đ@G#ftĄńt@Póş -t?đ@GQčTؗ@Pü*f’N×[A?đ@F˘6ń¸@QÇ4ĎBÚ?đ@Fşţĺ‹W@Přx‹Ä9x?đ@Fćp?÷@Pć‚čż(;?đ@Eę îîK@PĐŽŰŽ Ů6N@P&•œŠď ?đ@Cqűj¨Ó´@P/<4HU?đ@C %@=ԓ@P1~e1.?đ@Bܡ“8ä@P@ Ľ˝?đ@Bˆ]ýkJŇ@PIĆĂč{†?đ@BKšóC]ß@P:v@ô)?đ@BbÇú—Pˆ@P*š\=ĄÓ?đ@Bšń”ŃÓ@@PźZNŤ?đ@Bě="ş@PݝÝ?đ@Býň3ŞL@P›čpτ?đ@Bł_?ˇŠ@OíĄ Ŕçł?đ@B_7tôßp@O÷Ą;‹*˘?đ@BűÎĚIĚ@PƒáŒ¤s?đ@AćRvŠ—Ÿ@P­Ă˛4´?đ@A–ŠÓŮÂC@PRnuÝĆ?đ@AnÇúpgÉ@P+h\ńŽ?đ@AhËăŔR•@P<ţ—řŁ¤?đ@ANVnn+@PM”řÚ-Ý?đ@AE/‹Î•”@P\܈I˝?đ@AgTÁŤÁ@PpS‹:?đ@AR7D ™€@P€J/+˘X?đ@A ĆV3¨_@Pźő0C?đ@@Ć抋“Î@P˜}CĹČ?đ@@•DÂěČ@PĽŠžŠm?đ@@W"_SśA@P´ŹĂeů?đ@@$™Bi@PÄڀ$?đ@@a \5@PÉRœŮ˜D?đ@@k´[âZ@PÂsrÝX?đ@@ş;Ş3=@P˛FŢA?đ@Afô´ŕ­@P­aJˆ–:?đ@AKü´4ů@PŚ&É'Q?đ@A§a¨–T3@PœžlşQm?đ@AýjrMŤ@P•˙ţÂďé?đ@BX_ß~%G@P’FÄ)W?đ@BŽ:ŒƒUĂ@PŒ°ĐŇŹ?đ@CŇqč>@P…Šăśî?đ@C[léĂÁT@P„¤Ţ‹?đ@CłđÇzô@P‰äNšŮ?đ@D)‰ßML@P’€ĺűĽ?đ@DJ-ôŔgš@PžŤlU ¨?đ@Dó=×ë@P­Ô )E?đ@D§&˝YjY@Pž­ëmŢź?đ@DœůɝF@PĎşäîÍ?đ@D…îrHî@Pâjş ?đ@DV[że j@PđšDä[š?đ@DG ÷_@PűßÉ^?đ@C×všÉl@Qˇ5\†ţ?đ@CxŞ˘a­4@Qă \:?đ@C9̢@Q~冗‚?đ@Bár69r\@Q*†_Ę?đ@B“A"fCG@Q6%u×R ?đ@B@]4‰4ë@QAŸ*¤i?đ@AěH š@QKÇí˜eŔ?đ@A‹°g*<¸@QNŻ‰?#ű?đ@A#ź˜Ę`‘@QSčĽŠ?đ@@χĘż”@QOÇÜJç2?đ@@ŁľÉK@QJĚ˙|?đ@@ó~˝ź@QZ\Z‰ú?đ@@(ŠsŹDi@Qa^¨kf?đ@@%ůLůH@Qj‘‰żnâ?đ@@ob9M@QnZ‡`,ä?đ@?ůiá6ҧ@Qv&XŔ ?đ@?býšáF@QlÍßOŁ?đ@>ÝŒžS@Qqˎs‰?đ@>Š?Đľ @QošŻ&U ?đ@=–Ä7ɂ @QuQpĺLG?đ@=9élüD@Q/Ú Ű?đ@<ńčwŽÚ@Qˆ VŽF?đ@> 'nœ@Q†nÜ͟?đ@>ŮcÔ_]@Q’˘[“;%?đ@>šOŠč@QŸ{ƒsaÂ?đ@=ůČs%ąó@Q¨éSł6\?đ@='<+ÉôP@Q˛5¤oď?đ@<ĐT;š˝@Q¨H‘q˝?đ@ޝ?đ@9ŚRcÇ^@QśńĆŐ?đ@8˙ČjR@Qš˜˘„k˘?đ@8yB;¨Á@QŽ˜căšő?đ@8 ¸ęż:@QŸÓx?đ@7k cßËŮ@QaŃŕuž?đ@7ŞŃ ž@Q‚+r9U?đ@6o4‰O~/@Q‹Ö]Ś?đ@5¨čżR @Q‹@KŽ?đ@5‹zᥜď@Q‡ĎŁî^?đ@5ű Ăş–@Q~i­ËŘĹ?đ@5ÖŚEĹŻ@QuĚđ>đľ?đ@5N†śjn@Qxťˆ”\d?đ@4˜č./ §@QlŸ9x8Ą?đ@4~œ‰_@Q^ä\ˇšq?đ@4#ń2a Ć@QZňŻĂ?đ@4^g…cü!@Qp Ľ'Őś?đ@4d5Ä3—@Qvˆ ­”č?đ@3Ö˙é”[@QdCĽa?đ@3¤Ř3-ü@Qaí!ÜŹ?đ@3_W‰ @QoH|Xڙ?đ@3 ľßu/@Q_ €_m?đ@38h˙j­ę@QU)íŹţ?đ@2ľ6ˇšç@QYeęŢýV?đ@2OÔ÷wZĐ@QT[Oʸ?đ@1Ľ^‰ÔÂz@QCpVH?đ@1‡ĹĚŤ@Q2<Ł2?đ@0Ëjôˆű@Q'ˇ ÍT`?đ@0Ţá§:›w@Q9œˆ„?đ@1yÁĚÊo@Qçů˙XŘ?đ@1&Tń~@QaE}?đ@0r€ Tœ@Q‚{Š›?đ@0qďЃĹ0@Q/ĘŞ?đ@0JUœ’ř@PýBľá|ş?đ@/w&.ƒ˙ @Q_×tT”?đ@/ŽSŠZź@Pý,•9(Ä?đ@.¤ƒ3yŒ@PđĺrĐ#}?đ@/fIÔ@PčŃk$͘?đ@.Œw‚Œ4@PÜ´#ř<)?đ@-niBi¸@PÚ&8ď×y?đ@-g™°=•@PĐ8“¤ňZ?đ@.JŽiĽđ@Pˆçů'?đ@,œ§ĂŻ@PĂyÇŕ¨?đ@+{ü˘@Pś NmłÉ?đ@*í%jŞ7Ŕ@P§~[žb?đ@*ĹTí]¤@P•BËIŹý?đ@+n‚"Äňů@PŞćOs ?đ@)áŸ}l M@PƒN`9?đ@)‘ďâ$6d@Pv~Á çű?đ@) öœ^ť„@Pd„}FT?đ@)"Č|ƒR @PQ@Ĺ} ?đ@(RŽŞűœ×@PC*äp9í?đ@'& ÝŻˇ%@P;؍ťŚŠ?đ@&ôcÉKÁ@P5§ü ď›?đ@'ŚH•7ŸF@P6ĎŹř€ł?đ@'x0uŃ@P$ŢĂË?đ@&;ÇÂtŸ@PĐ2˝[9?đ@%2üÎ}Í@Pm F ?đ@$\L¸łă@P ‹éEĽ?đ@#줏ętö@Oő%ź;,?đ@#š2üîSť@OÚÉ:Ë"?đ@$aeëmc@OÄđWÉ?đ@%K8¸5`@OŮÇ5›“i?đ@%ÎË …Çš@OňĽŁ'*(?đ@&˜’˙”,r@OűŞăJÚ?đ@&^ŒÜ¨Á@OŢ>h2L+?đ@%ŽbeŽZ‘@OĂHŻt'?đ@$Z$&A˘­@OŽěCčíc?đ@#źüđ˘N@Oş7:ąYő?đ@"ĺÚ~ńą @OǖćĄËě?đ@";Żë@OłŃćewď?đ@!âÎ"@O–žkĎQl?đ@ ŕ_ ěd5@OFG8yő?đ@ ÚtV7˙>@OtŽWG8g?đ@  SâM@O}ßp^#(?đ@ [ŔW×Ów@Oj38­)­?đ@˛Y-AŚœ@O{{-ăź?đ@ge˙â@OhÔâ?žÚ?đ@śąîôwë@O^Łý")?đ@lśÁwľ<@O[+YľQ?đ@€Í*‘S@OK>ţŽ”?đ@­h6#X@OMÂjĽˆŽ?đ@ďĄ qŽ˙@O>J 8ĺ@?đ@ú´7S@O+Ö01-p?đ@Kuíĺ@OäĹwŁ;?đ@“ç}jS@O+­QąT\?đ@™—%ý:F@O !čxÉ|?đ@<Œ_¤Œ@O°ś‡á˛?đ@ĘZá@O @iŻ;?đ@YžÓ@Ořň$ĽĘ?đ@ÔłÇä˙8@O3ąZÝN?đ@‘@Ó,?@Nőc19ľ?đ@˝6;ÄqZ@Nđž´9e?đ@!ZVZ„/@Néă'k"?đ@ÔüƒÇŻ!@Ní\}ű&?đ@˝h×Z;•@NŃT§?đ@;25ĆĘÔ@Ną‹]Ó¨?đ@á&˙šŮÚ@N“ź?đ@ƒ…Ó[Äm@N”Š՞€?đ@ÉG+É_§@N˜Ţ Ą?đ@2Ae”@NvF)@™?đ@ŤUůZ@N 2‘řpk?đ@Ö`s¸sĹ@N¤˙Ť„Ó?đ@ŠˆœMţ@NKjśZ?đ@ËÇQ^… @Nˆ˝Î¤Ý›?đ@1 aU@N‹Ť6ší?đ@ýSÚľĆ5@N†ŐßŐŇq?đ@Ău|e{?@Ns<*dŢŻ?đ@Oɏ$ÉŠ@NWjCË0?đ@ :3ŞĽ@N=šăÇ?đ@ýe?âmm@N$‰ ÜL?đ@$ĎÂĎ~N@N [Őv—?đ@žÔŒŮŮť@NňAyĆ?đ@oôŽ€ő@N[şsQŐ?đ@Š)ŠĂ´@N2×ńLţł?đ@,"Šŕţ“@N9ÄYFZŁ?đ@k•pĄ'|@Nđ§Ě?đ@lvŸ×ß@MřŇŚ…œs?đ@Š\ůZŃH@MçT­V,?đ@/§´ľd6@M⭛ŸŃ=?đ@#(ü˛ q@MĐ"A°?đ@NGžO˝@Mąîďo?đ@žš ąű@M° 0ˆ×ý?đ@& =uQ@MťŞpď)Q?đ@=EœŒ‡@MĂ €óe?đ@¤~xŐŔŠ@M˘ăÍ!ŮŮ?đ@S[Đó75@MŐHi?đ@“Ö•;C@My[bc?đ@ŸŮg؋@MvŰ#Lj ?đ@EwL€s‡@MQEžy÷?đ@Ě9‰…@M6ő1‘gĂ?đ@§ŻÉq@M$“ŹÔ?đ@T„˝"@MY÷řôC?đ@GşŰj@M ş]Ţ?đ@ŢŠÁâF@M¤•r ??đ@ j|—˙€ř@Mw+%¸?đ@!Wă0śŮ@M1mýœ‘Ř?đ@"("őŠ@MT€ŰĄŕâ?đ@"Čúímş@MlVčqŒ?đ@#†ťuAŸ@M‚ůáçŽ??đ@$Œ> †á@Möľ6Ú!?đ@$ŮmŃŮŁ@MłŒ‚Úŕ?đ@$ÔzŔţŤ@MЂsř0â?đ@%E$ŘĽÔ@Mă[) 8Ď?đ@%ZĂH$Ň @M˛?šĎů8?đ@%ř1Ź@M•Bůôu™?đ@&„ýŽĚŮ@Md˙ói?đ@&vÚ8ZŞű@MVj=Ě>Đ?đ@&מ @Ŕĺ@M0™í4?đ@'C&Ę!t@MŇ TŹK?đ@'{XÇG@LîÝőčť?đ@'ł'Ńyt@LϏ|Ţě>?đ@(6ëIXľ@L­¸˜|?đ@(€×?ř@ę@L‹MNau@LŹĚ¨wďX?đ@0œľíÁ—‚@Lφ^RƒŮ?đ@0šąÜž#@LńŇĐ#_˛?đ@0ş2’Y˙Ő@M§ˇ“#?đ@0´ă{ľ)0@M7xŸůN?đ@0zϤćń@MNýŹşž_?đ@0k˙‡—Œ@MRŹ˘ťr‡?đ@1 fSŚ— @MWřv'óŁ?đ@1|YČÓ @Ml™tíŒ?đ@1̚\~„Ĺ@M ’`Őŕ?đ@2Sŕ…_x†@M˜ôHí¸{?đ@2fŰ{5/|@M­Œh[ţŠ?đ@1˛“•řŚŃ@MĄÇ9eŮ0?đ@14Aăh@MŞT+(Š?đ@0˛¤CÄux@M¸čŠ˙@J?đ@0ct8mşĽ@MÁ 1‹˘?đ@1ĽĎˆ]ƒ@MĆî{i!?đ@1‰äĘÇ@MĆęš7oœ?đ@1›Č¤§…Ž@MŐŽN’?đ@2 ŔňŢa€@M˛ ăó6ž?đ@2m7ňÎl™@MżčéĹ.”?đ@2ÜEÓ#á@MŢŻ•ˇŚ?đ@2áúŰŮÜ@MýL/-w?đ@2xa%j‹@N Jj–D?đ@2ÝDOFš@N8a• g?đ@1Ş}Écç@NIÝöŸ ?đ@1H1ÖBŠ@N^ۅxŕĽ?đ@1/IŻE;@N„śŔ)Ö ?đ@1-ľ-çä@NŞ8fH¤×?đ@1:9¸ľ `@NЄMĹŘ1?đ@1bzĚjˇ‰@NéćSˆÝ?đ@1ƒ¨ěř^4@OĂSÖŘ?đ@1‚ČÇĂőP@O7Íôŕ‘ë?đ@1őĽą€@OPY)ŘŁ?đ@2Óšˇx@Onuě?đ@2~˛ âŔ-@O„šQxš0?đ@2ńџ§K5@Ož%ƒ^'?đ@3|ú*B°@OťŠŘs-m?đ@45ŹROj@Oϑu0 [?đ@4w´ÚńeU@Oŕőo™+?đ@4äÓ潆ő@P5¨Ô¨R?đ@5:L÷ĎG@PęŤ}˛ß?đ@5tS3+*é@P!Ň´ĹÍ?đ@508™“˘Ţ@P0â Ꜹ?đ@5y@šČ*@PBľHÝvń?đ@5+Ň@PU7qI˝?đ@5űŚIű5t@Pb}š.Ď?đ@6L†ćc@PhgŘ2ü?đ@6QoLîů@PkkK+ÄŘ?đ@6ŹÔľ’lr@Pt‡…Őž8?đ@7SŢ—x@Pr|óç…?đ@8văŻŇ@PrČłQ7*?đ@8Ľ€”ó@PpşÝmçă?đ@9<‡›ľ@P`›äjd?đ@9J&x!)@PMŸG‡č?đ@9BćĎ}ąu@P:ÉŤż{Í?đ@8 3ý_űÜ@P2g4@Äp?đ@8Gk”Ł´ń@P!€Ţfż?đ@7ć/Fü@P4?ŔŐď?đ@7„gr˘Ą@Půş|Ą”?đ@7Ÿ#}´Y@Oę€ő éŢ?đ@6Ź–ęÜy@OÓçŠ?đ@6QsĽ˘şĆ@Oľv%y?đ@5éĹ[…xt@O›Pż×b?đ@5ˆĆŻßť˘@OŠ¤‰;ő?đ@5:íěz@OgŻÖp??đ@5!~J›5@ODyĚó3ß?đ@5KĺĺY|@O%€›ég!?đ@5Ržś]ľ*@Nýă*8Řw?đ@5‰Ă3ƒžž@NŮ:ŹeAa?đ@5ŠŒĎđ˜@NťÍÔ'­o?đ@5qi۔L@N7ş´k?đ@5`Ő×?§}@Nn#Ö,K?đ@5•V‰j1@NJčp?‘?đ@6âĺ/ŒÉ@N;„§őŻ?đ@6“:ŰX“Ž@N%̏ĘvÄ?đ@6ýŁD–s~@NP3JŽ?đ@7,NŻ‰ŁZ@MřĄ€ÖĎM?đ@7%ŽHsŒC@Mě*ˇQöZ?đ@7–R ů$‹@MţąíZĺü?đ@8DM— ćU@N<…_ؙ?đ@8š{kp°@NĂlž>?đ@97˙}áßH@N1;-ą}?đ@9Ú5đwžW@N*sW,?đ@:PgŁľ‹ł@N7sÔGlz?đ@:Ŕ—K"Ő@N>™/t?đ@;eÝ ň]U@NA+ł7đ?đ@;í3GŁ&s@ND™UŢdł?đ@<’ 'Á'ú@NJ‡OéVŚ?đ@<ß űč@N%$cqźÎ?đ@=`­Ë+@NŻL,n?đ@=ä‡óž3ý@N Ö4BG9?đ@=ţ;Kf0@MöąäŰÎ?đ@=1Fƍw@Műa+î?đ@<şÜţ‚Ů_@MčĽÝëUś?đ@<5ĐŻéb@M܃ŕn1 ?đ@;ěéŠ?Z@Mź6“ç! ?đ@;X8h=@M¸‡ęw÷:?đ@:Č;œ„g@Mżř˛Ő%?đ@:FČ~ţ?đ@4ţ˙*;@L@š?đ@5O/ @KůŠCŇü?đ@5#}ßč@KŐĽ<$Ő?đ@5=QYöÖ@K°L­ŃÝ?đ@57u8Fř@KŽěnőĐ8?đ@5ëçç:@KuĎĺ ?đ@4˛NR]gÝ@K…Zqx¨đ?đ@5F[†o¤@Kޤů@ÔH?đ@5œł<Š@KÁĆڂť?đ@4¸ŞÓAĘă@KÍVG¨?đ@4Q(öĽ@KzďL?đ@3ó ŔÉv@Kkv!ů?đ@3ÄĽźŻm@KGŤC!í?đ@3`ő|ô88@K1JPé?đ@2áśŮÖ6Â@K.vT4ë?đ@2Œ#Ť,ü˝@KFK,Ď?đ@2‰-´DÎ@K^0yB}?đ@1Ď0^„4@KgT"Ţ?đ@1S5?ypA@K^2ŠŸ?đ@0á”qFÉ+@KML˙Sœ?đ@0rr’CĐ4@K=E­Ŕ˜Ü?đ@0( }×@K%˝nš š?đ@/9ľn ş@Kič@Š}?đ@.J)čbj@K Űt‘ƒ­?đ@-]â;6Q@KÄů°/?đ@,rAţB@Jú—ŘĺűL?đ@+â);׾l@Jţ'¤ŢŃO?đ@-ĺjn/@JćMxf?đ@,śf8‚<Ź@JŮ<”ˆ”?đ@+ŢšęÇńČ@Ję6Ś J?đ@+\.p;t|@K ćhm'?đ@*Œc!ăRK@K‡o2r2?đ@)šin)'@K1*uZüR?đ@)}Ůł@K/x0Ńh9?đ@( Œ˜_Ę@Kjđ 0ć?đ@'YťĘ’@K¤›ĚĄ?đ@&{'é~›@JűťĘ!ôś?đ@%ÔQ!`|@K ú+a?đ@%â{?Rť@K,Ú4.˙T?đ@$”“@] @K2yJ7?đ@#ůpT,{„@KIIPĚŹ?đ@#{ľÖL@KfHžF“I?đ@#5t¤ü8x@Kw ž$b?đ@#.óeďG@K Ÿâ ?đ@#W…úÚĂq@KÄmŰ~ż?đ@#˝;„Zą@KŕĎĂa?đ@$m7Ç_A@KúJŻ÷9k?đ@$ř/hIlČ@Lîˆ:?đ@%˝ţP‡0@L.ž9ŸčŠ?đ@%)WŞI¨r@LBOł˜‹?đ@$Řź,č@LQ#<Ľ˘Â?đ@$cbLfô7@LEŰ@şV?đ@%f CĎ\@LĄŒ=m?đ@$óΕO-5@LÇÉ7šÍ?đ@$̤˛čČb@LÔtbäěW?đ@#ÁÄÉ[` @LŔ—`EáŽ?đ@#%ĹÇÄŽ@L ]ŸHœq?đ@":÷A|Qž@L‘f‘żu#?đ@!4żäUڋ@Lˆ í{źŠ?đ@ ”*źfŤ@Le ¨1Éa?đ@! $ýZk4@LZţžxŸ?đ@!ÔNŽq"@Lň݃•?đ@"Š˘•˙G@L„ ‘cˇ?đ@#)Îďłü@L}KĽOĘ?đ@" nŹ˜§@LV›!ŚŤ?đ@"Y.V ÷>@LNâlžć?đ@!ż™É„Ěż@L[AFs§?đ@ ę‹-DĆv@LHĐfBdn?đ@ S_ćw‹@L7ÎT]Ţ?đ@ VHşű{@L 3˜Â0?đ@ mě<żD@KřąŢÎ.?đ@ QËźřŚŇ@Kν´?đ@ Ő˙Gři@K˝ űß9ń?đ@!.LPš@K’€cÂ0Ř?đ@!T‘ŹPđŽ@KouÍea?đ@!šW•Ž/@KNň쌼N?đ@!”?7‘,@K4Ä2@?đ@!˘ĎálÚY@K֍|҃?đ@!đÝTşv @J˙EŒ™?đ@"Á´œz@JćŘŘΙa?đ@# ďôÂÜ@JÔ¨XúZ6?đ@!ɨAľóŠ@JěŃ´•ú ?đ@!_“T6E@JâłŔj?đ@ Ěđź¨ĘŠ@JżŔ‰˙§-?đ@ *܃™D•@JÉFž; ?đ@Ŕă%ď9@JŮ<ű–Şž?đ@ĘŮÖwŒ@JÎOĚ;j‹?đ@ŤXńs1@J­TŞgő?đ@ ÚńĆűx@J¨Ĺ÷ ?đ@zΌ4řŽ@J¸ &íěž?đ@­E"iŢ@Jł×TŞ?đ@ľss\a)@J¨=ü Ö8?đ@iĄćčkž@JŽs‚)|Ň?đ@ś%2=Di@Jx–Ëž‘?đ@´…ˆ”#@JdĆÁ]˜­?đ@ZŻÄ˘e¤@J@ ŘÂĚ?đ@Ť# Śj@J"aXmŢ?đ@sť˝ĄB@IţďĚó;?đ@Nż[@IĺY/:Rk?đ@_cřî@IÓiVĺ ?đ@:SV~@IĹ{“1ăé?đ@ ˆ*ĂśžÇ@I˝Rúš?đ@LK`ĎZh@IŽ;Ÿ'?đ@ öúöŞľß@IŻúáx9?đ@—%Ăůő@IŸäąč¸~?đ@eq„řˇŻ@IŒÎˆ"űj?đ@â`jx¤@I‚ZĽ"}P?đ?úđvNîÍ@IrIĂł‚?đ?ů<~pkŽ‘@INP6ŤŽ‘?đ?ů]؍śY@I(šŮ Ÿ?đ?÷š~N¸™Œ@IߣËP>?đ?ńޤœ‘np@Hů[wP?đ?坴Ő"×@HîJ†nѝ?đ?ѕzvß@HÜ ËůÁ?đ?ÎvŹć†ľ2@HşĽIř–?đżĘžę‘nÓŁ@H§>J ?đżäŁŇś$ćp@HŹĂŁĎ˝Ŕ?đżń›‚ôÚA@H˛l˜Ďy?đżőÁfO,ň@Hҋ "?đżýcÓ˘WŸ@HĎNľ%Â|?đżúŔĽFŐţ@H¤kÉ;ľÂ?đżů4ĆHÎ@H‚qŃŚŤŤ?đżř‰c¨†ę@HX:ĹuŔ?đż˙ň<'4ż@HNá(tŻš?đŔ Ëm›:ü@HPmOň?đŔAý…6oá@HLż@ě?đŔî{x¤”Ű@Hh$ç@>Ť?đŔ iC铵@HamKPú!?đŔ†+$ž&r@HWďNT:?đŔœŃYĆzu@HQźŞió0?đŔ^řÇšŇ@H6ŇëĂÁg?đŔŚx$D„@Hż—Cż?đŔ,ZFČ<@G˙ëčÝć?đŔŽ~ŔĹşV@Gí}cëp7?đŔ őcž‘Ĺ@GćÖ šŸ7?đŔ 7äşcé@GŰ$ŐÇh?đŔâšdżœx@Gʡ¤8ƒ7?đŔ*+HMŠ—@GĂĹž’Ÿv?đŔ c(@G¨Ě‘i4?đż˙ţ%ţŤ˛Ë@G›ľvąu?đŔ‘łFî˛ř@Gqw’ ˛%?đżýţ[ş: @GOÍšwŕG?đżú‰ĆScB@G8ž,Î٘?đżó–/Jăr(@G#>đj;¤?đżńŒŹű„3@Fţ“ÍÓĚ?đżńܾهŔ@F݇ˆ-/?đżę–ÍM@Fž_°ś1@Fm˛c×?đżó\,fĹ@FRČׄzŰ?đżôž.Š\´<@F$#´ĄKŕ?đżőľg ˇ;í@E˙ş*$ČĂ?đżöőĹćÁPé@EŰÎŐŘg"?đżůú-Â3_t@Eşqš’ĺĚ?đż˙ťqpÇSă@EŹ`ěŽi?đŔďtďŚtˆ@EŹI…_-á?đŔů?ŽJă@EˇI&m×Ĺ?đŔňšŔ‚I?@EąáłĆĚ˝?đŔ +ąź‰zN@E˝~Źé"P?đŔts@EŔ2e Y|?đŔëU3şŠœ@EÇÔT°×?đŔ‚ăĚd`@EĎŁŠ+ţ?đŔ/ yDĎ@EË*…Ö˝Q?đŔ˝¤ěî@EĘj+ě?đŔN$ť§Ąš@EČ"ĹýXƒ?đŔŢřO-7.@EŮ.ŕD_>?đŔAe'%mň@EŢ&#Âş?đŔ VÝ°đ$'@EĎó!ŢŠr?đŔ œŞVBgs@EľIš­pA?đŔ!łBëĚÉ˝@EŚX˙N—‹?đŔ"NńJSnB@E“\ťÖpö?đŔ"hŽň6[p@EuđąŮh?đŔ!ď8áfˆ¤@EXj"ýQ#?đŔ!™vžríƒ@E?-]3?đŔ!ŠąźRĺt@E Sń?h?đŔ!Ż€ć*—ë@DöÚ*đDK?đŔ!Ÿ“ĺ. š@DŐf€j4F?đŔ!ˆqë@@DŻçÎcӁ?đŔ!XĽŠ´hŠ@DŒŃŐťT“?đŔ!h šmi@DgiL I?đŔ!it:‹Ý­@DV/[T?đŔ!ľŃ'Iů@DO^F?đŔ!ŕŕ‡-Î\@Cű żźÔ?đŔ"#źDîó@C؟ŇBŇ?đŔ"}$OnZ‰@C¸FłŹę?đŔ"Ŕě•"‹@CĂŃŽĂ?đŔ"äŰúůÇë@Cx=œ&Ł?đŔ"˝~éu@C[¸ßę?đŔ"%Œ[xH˘@Ck“†óĄ?đŔ!ŢaÎň˛0@CwňXçŒs?đŔ"dMł•ň)@CNâE1đĐ?đŔ"ÉZę@C;@+ŕ‘V?đŔ!“LœEâz@C8~üŞ—?đŔ!Ź4…\é@C˝§&Ć?đŔ!›Jwzń˙@BăGzVľß?đŔ!˘68ţ}@BŔ°Ąź’?đŔ!Î A}@@Bœ¸lB?đŔ!­Ô;ůpk@B‡fÓ~0t?đŔ Ţymžf @BŒňĚc?đŔ 㖠Ý@B„6“r?đŔôFűÂbV@B†_+śM?đŔ˘+RĐ!:@B–ŕ]%¤?đŔ ° @@BšŰŁG=÷?đŔL•ĘÁŕ@B”üă5ŒK?đŔGŇL¤i@Bz“BÍ­Í?đŔUYqź7ů@Bf*Í LŁ?đŔđěűĘÇ=@B=`˙D?đŔŹ<=­@Bv2Ĺó>?đŔŮVVŃöŸ@Bńü™?đŔ§ĐkŔl†@BĄÁšň?đŔŘ@pĘRŽ@B/ž@€ĂŮ?đŔŠž ĆÇp@B>Ű.Ŕ˜?đŔ?DýΞô@BJ˘ÓŁE?đŔˆ€‹ŠÍ@B[ͨŐű‰?đŔTúm>ĎÍ@B_— ?đŔ pˆp6@B\˘}ś¨m?đŔ Ÿiî؜@B`°ŻH?đŔľö—} @B\˛ÚX#?đŔ-<ý&n@Bg#Ë­?đŔ#eç&”ô@Beňkč˜?đżţQw;ďÔň@B‚äˇä ‹?đżűĆXr˛gŁ@BĽI_vN§?đż÷sÔ÷+z0@B˝8Ÿ ?đżň Ůʅƞ@BČ {‡h ?đżéÜŤRvÉ@BÓn|Ż"?đżćďq9ç@B÷ŽŘ ?đżâƒ„’Źż@CěĂÚ¤k?đż×ô<Ľ˘¸@C7_|::?đżĽDšŚŹ4Z@CKĘĆ҅?đ?ťšçMŠƒŔ@Cf˝ľŇLŞ?đżČŕĽCO@C†¸ž\_ë?đżÓ­rŔ\=@CŠÇýđú?đżŃ"›š;@CĚá22TN?đżśJWśnV@Cí7xFú™?đ?Ŕ•wîNj@D ‘ád?đ?×>^ĺ6“6@D(š˝éˆ?đ?â.˜Bžj.@DHAó“$?đ?čn#>@@D[†-ȓK?đ?﬊ĽŇhĽ@D‚Ąƒô ?đ?őLéíWŽY@D[Ő.ś´?đ?űLŇaŸ,z@DšóÍúíí?đ@™E-Ć­@DĽ‹Š€<.?đ@ä4ú}B‰@Džy…Ŕ?đ@˘p3pV@DĐxúşî ?đ@:šxŰqđ@DăĐăLlÝ?đ@ ŇÂ܆@Eeőuđ?đ@ ďäwÜ@E%ĺ.š?đ@ĺ2ż.c@EKmúĘO”?đ@ˆ*čŒâŸ@Ep¤tş2„?đ@ Wabj@E\ź/ž?đ@ ńŤdŽ@E§ u ŕ?đ@÷—-@EžŞ‡Ŕއ?đ@btĐG@EĆ=J6 ?đ@íłŇd@Eśi/ƒj?đ@TŠďÜ@E¸ÄŠ–łř?đ@Š&4¤@Eśą–S|?đ@ŇŻ)]}6@Ež5ł@?-?đ@cVv㿘@EŽŠ]DŤd?đ@ÝĂ˙ŻćS@EŒĆá}ň'?đ@qŚ"-´@EžŮ§őĎŮ?đ@gŹŸ+@EšĘr4Ÿ?đ@­đŽěéS@EŃ™: ?đ@WVU5ę@EáŢ2ŹFÉ?đ@Ÿ†ČŤŞ@EěCnČi!?đ@ dF'7űő@FŠp0`=?đ@ âÝZ"÷°@F nFĄČ?đ@!•ÄÁ@F3÷÷î5–?đ@"^ŠâjM"@F+HQĎÓ?đ@# Š4ň@FěpˆčŽ?đ@#˝°,Lě@FălÍFŠ?đ@$cc¨î]Á@EôŁ~Rœ”?đ@$’L0]ń@EŃőoŠŠ?đ@$ŰlĘĺV@EŻŚR‡§Ó?đ@% de>´ć@EŒŠsÝ4?đ@%YŽŽŠ}î@EręŮMg?đ@%íç2ü@EYţ@œ]?đ@&_̋™~@E9ńžĂ?đ@'ljŔb2@E*us”s?đ@'™¨\s\Ě@E ŃÄ.L?đ@(3Eüq@DöÉÚuc?đ@(Šć[’r@DŮS˝˝?đ@)=zs…—@DžIžöh?đ@)âËvçzf@DŤZʡLź?đ@*ŸH Ö@D˘/ÜT=°?đ@+@9ÖĎT@D_rÚ/x?đ@+Ôě|ŕ_ @D†śâĂz?đ@,Hy!Şkw@Djřž1”?đ@,äŁw´ˆ@DSšfbĚâ?đ@-Ź§…çé@DK×Ĺy ?đ@-ě€wJ8&@D&UŚˆ\k?đ@.j…ËçČĆ@D ‚Ö”?đ@1&KŠ=×@CŠ%Ľ zb?đ@1íü6Š@C°¸ŠŃ r?đ@0ĎŻ˝ă>S@CÉgą9?đ@0ˆôWAd@CßňcuCâ?đ@0ŸÍ¤ä/˙@D)a/yP?đ@0ĘŚa*~@D&0ĚŮH?đ@1 ÍżäĽ@D>ž­-a?đ@1Q?űĘĚ|@D3č”ěO?đ@1ˇćW|s¤@D%…Ҥëł?đ@1řD;Y™@DŮ1÷?đ@2#—ŇŔĽ˛@Cń×v× ?đ@2fâ€ŢV/@Côę[a,?đ@2ulŞąÖě@DˇU˜ëÉ?đ@29뻚e1@D8ġMś˛?đ@1ôăÖݒ_@DRĹŘÍ?đ@1mîĚř}@DdX ˛ŕĆ?đ@1NłžkB,@DyWŤéÝ?đ@0úˆđě‰S@DŒTJĚ˙?đ@0 ĺĄ@˝ž@Dš=ä™.?đ@0HÝÎbÇ@DŞ uXăˇ?đ@/ěM‡uYi@DĂŽ•Ži?đ@0Ľ šˇ@D쟹,\?đ@/G^y}ž)@DőqtŞĄ?đ@.‚ ľ%@DőĘĽIĄG?đ@-ÍśËmš@EHHf"?đ@-:e%aü@E â?¤^?đ@,Ľ:Žź@E3Ńé˙?đ@,!cbSˆ;@EO]WjŢ&?đ@+Ň̚ô@Eqvô’ö?đ@+ž)khđ@E”ĘřŽM ?đ@+U"5!#@Eˇ­ ĺ[7?đ@*ގFęJy@EĐŹ+oŮł?đ@*3ÇěŮh@Eć‘ŠÂ?đ@)ŁF˜Ř)@Eű˙Ş2"?đ@(ň9Źˇš@Fp›|?đ@(Rd5@F4ŒŔŠg)?đ@(‡Ü˜!‹4@FYْ*Nú?đ@(Ói v–™@Fya˜.Č?đ@(xĐđá @FĄńŢĹ ?đ@(čĆ8Łyf@FżŃ_EË>?đ@)ŠyŽž&–@FĘH â-,?đ@*VćůÓä@FÜ* řú?đ@+%%Ţ`“@FŰËŐŔÓ?đ@+C ĂŠ<@FĂmśĺ Ô?đ@+0‹`4XÝ@FŸ'iŤ?đ@+uš)ňQD@FĄWœg˘?đ@+ţyzę§@Fs h'äÉ?đ@,iřňş;H@F‘>ŚđÜ?đ@,ôqŁ(y@FĽŞ?áő?đ@-žWƒĹ @FŒ2l$_Ô?đ@-ɞŮŐíš@Fiť_Qm2?đ@. A=~sl@FHŽ˜~_@?đ@.Ÿjtď†V@F.]ÚęČ?đ@.Ž[ }0@F¤lżĂb?đ@/Ľ•X+@Eó"%Ÿœ?đ@/Ť.§iŠ@EÚĂŞœě–?đ@0]”€r@EÂ<’°Öö?đ@0|sÉßßT@EŔ´‡ź?đ@0ŢôÖ8@E°v¨,D?đ@1,&Ub9p@E˜$Ş]Ó?đ@1}œߍ@EbAß;?đ@1ŒiĆëą@Et›ď˝Ű…?đ@1;p&Ű@E{”.ăűB?đ@1݄h!ˇ@Ef1ž ů?đ@2Ę ­)@ES­ČIú[?đ@2oĹ"’Ń/@E;u :J?đ@2°Ľő5˛3@E/äUŘ+?đ@3E\ĆÔ@EÎĘŇfˇ?đ@3A˘Ž´c’@DőˆRŢŹo?đ@3‘ĘąĐřt@DÜVt$ź?đ@3váäŤs@DźĚDş—?đ@3xž;C:I@D˜€´Ć„3?đ@3qÄ“ŃU@DtŃ78ł?đ@3cŐĽ–P@DIĹůZż‹?đ@3hŽ˘`s@D,|0,?đ@3ľqÇľŽá@D  ͟›?đ@3ň÷Ą] ť@CóŚOď8˝?đ@4˛Ż@CҎĽ)Ż?đ@4Aš& šĎ_q@D-Ş[ŤĄâ?đ@:V‘BŽ°i@Dk3R{?đ@:šŔčŕ[@D:Mę8A?đ@;…ŠlŁv@DLş¤úL?đ@;ZÇĹÚš4@DcC{¸Ş?đ@;›nlÇ@D}ÁÉ[|ť?đ@;ýANɗ@D‚NjT5?đ@<]ýÎr@D…Öeöm?đ@<ŤaŁ–€h@D€$Œę?đ@=ś—ŕ˘@D”ŁĺGk?đ@<Żë Â@DŤMa›Č?đ@ΞU?đ@=˙Ź’H‰@Fá@űtl?đ@>l0A}ˆ@GÇQą9?đ@>ŠpÁ~9Ö@G$OHF?đ@>ŮzŽÎ”@GC~*ÚřY?đ@?D^œ ţ@GO%@Űj?đ@?’#Ÿbf)@GZ2ňŽţ?đ@?č/Z@GcQ~Rý?đ@?á€RëĘ@Gƒo ˙ˇ/?đ@?ŰŮÇ ´T@GŒÉŹ˘4J?đ@?řÁ˛ž4'@Gd*΢¨?đ@@HĹў@GKHż[ ?đ@@2OĹE2@GEŚű@˝?đ@?ËŤťb{Z@GD6Ŕ•r?đ@?˛/ĆBŠ@G?SœĚŞ|?đ@?ó é ĐÔ@G(8čÇţe?đ@@+×-‘ëč@GqKƒŻj?đ@@aâOÜ Œ@GŞMůż?đ@@˜ë“ĐŢ@GCZű|?đ@@É{Ş@G˜Lvâü?đ@@ÍT6ńA×@FďWý/)?đ@@™-qČţ@Fߍ0í?đ@@kÜc‡@FĚr"ŽýA?đ@@T yŽ+@F°ď–9?đ@@’?ëăZ[@Fœő­†:‚?đ@@żîU8˝q@FÔjyúK?đ@@Éáĺk@FjŠœ{ŚÄ?đ@@Ŕ¤癛@FFž:˘§ ?đ@@đVÎ= @F2…Ţué6?đ@ACŇŇú@FAąş‰÷?đ@AB˝L"v@F\ľ§ÂĄ?đ@At9ů›NÖ@Fh:aDŤ?đ@AŸW $]@Fv2;œŹ?đ@AČ°–[ó@F‰‘ľbA^?đ@BGjŤô`@FŽlÎF?đ@B0 Ź—Jo@FŒĂ’AźŃ?đ@B9ň˛LęÂ@F˛YŹŠ 8?đ@A÷Dŕé2Î@F´Ý.Ľ?đ@AÇĺđŰßş@FŠ­Ń,?đ@AeĘ;@FźK§Ť'?đ@A¨źwS@FŰ°c˖2?đ@An!逗@Fţ:Ó¨v?đ@Ay1!˘ƒ“@GŰpčž?đ@Aœ°RIZâ@G$ř{áœ~?đ@A×+:ţHž@GD|3>í?đ@B ‡ěB@GR˙ŔŽ–˝?đ@B4ö8ôô˘@GYÔŹćZÓ?đ@Bhn79Şž@G^Ś° :Œ?đ@BŸ¨} 3@Gt8ë¨W?đ@BĘţQp—@G†é˘f°?đ@Cůő%ńë@G‰}cn&?đ@C6@߈Œł@G”$džBş?đ@C[ý1°=@G™Z–ęç?đ@C *F„V@G•őG?đ@CŠŢâ@GźWS9?đ@CX´PzĘń@Gp‡; ?đ@C4J\Ä@G[ŤxÁ”?đ@BřŢúç€Ă@GRLˆŘ?đ@BçvlŠL@GD¨Œ?đ@C *ľ!@G-íí°ĺ?đ@C6?ăČř>@GvÜ˝ŕ.?đ@C0"Î cm@G żŘJˆˆ?đ@CÜmœ8@Fú÷ăZK?đ@Bú˘,h@Fôkűëܗ?đ@BÓÔ?žđ@FĹd_­?đ@BËĽmÂ'Ł@Fޞç%?đ@B”fnľcň@FŚ¤č`5[?đ@BfĚ.šŽĎ@FŠ††gZ?đ@B^Śś¨ąţ@FŸL'Ě&?đ@B–x!FD@F|ĹĽÇSO?đ@B´Bu~|§@F_FQé*8?đ@BĺţÖŐX@FTi5´o)?đ@C _y†Ď;@F>pBÜ?đ@C8ͧ€Ěî@F,Ĺ}ËŻů?đ@Cfwő,ŠŇ@F]ţҧ?đ@CBŕ;@FF-č?đ@CąÔi–č%@EëH*s`?đ@CÔOíH@EĎŽŃEĐô?đ@CůoüĽ(@EśršŽ?đ@D"~¨ô´Ń@EžMD`?đ@DKôXčC@En tc?đ@Dz?”°´Ö@E ščŠť?đ@D1ˆJŻš@Eeő"Ř?đ@DżŰÍóB@EM›VG ;?đ@DĚfë2“ˆ@E)›œ‘šD?đ@DŰ`tűą@E÷áŐâ÷?đ@DÝJýv$@Dŕϑ-?đ@DÂfřƒ/@DÂU:?đ@DŸ}KXU`@DŠčBzđœ?đ@Ds”4@D™Săvv?đ@DH 9Ön@D‡ŒoONĚ?đ@DÚ_č[#@Dy–łĽo?đ@Cç}–@D~‹W-?đ@CˇŢÝňí@Dˆŕ–‘E ?đ@C‡˘zo @D†8rVŞŠ?đ@CVźňç-@D{‚`ăîŒ?đ@C'đNŽš@Dwž<×0?đ@BöO(Š÷@D€nŽl#Ú?đ@BÍěÔ*Čş@DŠy˜g?đ@Bœě÷T h@D‘ˇl‡Ľ?đ@Bv÷sř@DŚ}‡…?đ@BG”Ö ć+@D§mŮúáZ?đ@B°úV @DŻˆqZ†U?đ@BĐ1ţŞl@DÔŁ…˝B#?đ@AÔŚ)ťx@Dӂó!N?đ@AŚS KĘ@Dݖçőbĺ?đ@AŽĚŞ2NŽ@DţŃoO?đ@A;†bŠKR@DůÍ_–ź?đ@A đÔń]ď@Dü Ú7&?đ@@×Čő îj@DţPŽeĘ?đ@@Ś?˘Z[­@D˙ ¸Źv?đ@@vßţďqĹ@Dň˝ęűH?đ@@G($…“X@Dć΀Žţ?đ@@ą•FľÓ@DŐÄ0ɚş?đ@?ç'sŇQ™@DÁ‚( Ëń?đ@?‘•KŻÉq@DŻs1ßv?đ@?Sg„Ă{e@D•ÁžŃ#?đ@>ňœĚžâ@DŠA´9?đ@>“2A‡ľ@D‘W%áEŁ?đ@>5Ż•••@D•’W7'?đ@=Ńa´Z\h@D“Ĺ)ąŐ ?đ@=q¤ÇW˜×@D™Śql&?đ@=J“MŘK@D’Őôˇ÷?đ@=,„Ž/ş@DrĎ#ë¸f?đ@=vÇršIí@DcŚhg5í?đ@=Ż§ €âŘ@D\ŒŠnŢ6?đ@=#´f}@DSq1öDć?đ@<ń6@D6”ČĽqj?đ@:ť!—}í@D.t‘Žš_?đ@:q.Ýôůü@DČIŠ z?đ@:4@˜ľsO@Ců˜œ˙?đ@:#Na&‡Ŕ@CԘNÉ0(?đ@:<Β 2@C˝&Q á†?đ@:˘…żž œ@CĹŁĺR ?đ@:×-YN÷@Cş[>Ť]?đ@:šÝ×ËR´@Cœ{”ł€?đ@:íŤPW9É@Ctxđ}‚ĺ?đ@:ŃátdR˛@CQfˇLe?đ@:Ó츌ř@C6vńăÎä?đ@:o‚˙ž@CBdJ}?đ@:oϙ*ˆ@C-Ť—>”?đ@:Ţ.ΞşČ@C śT>w?đ@;2–šíL9@Bů.Jś?Š?đ@;&ˇî¸@BÔl!ćEŢ?đ@;I›ůw%@B˛zLb…?đ@;vcśâJ<@B—ĚŠŠç9?đ@;`ź•˛í;@BÔźŹ?đ@;ÁöŰ+ž@B€xwŽ¨JŇňAú@B":KŔÁ?đ@>€łÍňď@B2şóë•~?đ@>’[35ŠP@BVý‡¨e?đ@>Äëvö@BmŒƒŮX?đ@?"O*ĄW2@Bj„SňÁS?đ@?v黅eÉ@B_)ŰKa?đ@?ʒbí'ƒ@BMѤdĂW?đ@@ Z!Z4@B;Ń$wĆ'?đ@@(â8ń@B#%?đ@@MŞš#Oé@B !pCî?đ@@záWT Ľ@B ‚Q,{]?đ@@Ś!‰ňL]@B|ÖÎ7?đ@@Ňt.ŕń@B‘;¨.?đ@@űi‰=@B%ZG‹ěT?đ@AžŽ”Œ@BB˘×śV†?đ@A>­ ďú@B[;ĺć'‚?đ@Ahԑż:ć@Bcő×wŒ?đ@A‘“Ë{ĹĽ@BRLlbbi?đ@A˝őęČÎŘ@BK ח{?đ@AÖčx\vr@B\d*mHş?đ@B ´x@Ž@Bkľţ1ÖL?đ@BŹżŠ @BHďŇÝG?đ@AíB›‹Ú@B,!˘Ýq?đ@A÷š˘˘q>@Bϛ­bŹ?đ@Aę Sýş@AäumÇjŢ?đ@Aç´ŮĽâ”@AÂ[ŠUJ?đ@Aö'`˘@AĘŕU?đ@Ań¨h‹îŕ@Ayń%‡›?đ@Aűˇ5@AUŠČ˙@J?đ@Aęç.Nf8@A8Hś‡J”?đ@AÓŤřßCe@Aíč›1?đ@AƒĆ8Ť5@@öévä ?đ@Aľ AĘ˝@@ŐSôěľä?đ@A˘E왁@@´EŽ„˘?đ@A“+š @@’Ü#!:$?đ@AƒdŻĘ …@@n‚×XXV?đ@AtΊíŔ@@MY÷ůüů?đ@AkĎSomÖ@@)"^Ád?đ@A_pżš9?@@›+şH?đ@ANÇŹ˛ľ@?ÇĹ?˛ęť?đ@A8ţ;P@?‰1Ľdu?đ@AŘÉŔţ‘@?SXm-YŠ?đ@@ő§Ńîi–@?.żő6‘?đ@@ˀUˆ?đ@@|POľt@?ýÜ$P ?đ@@]yÇö@?ŹŇӇ?đ@@+5ÇÎU@?!ą3v÷ ?đ@@*/c˝Ô@>Â?.˛b?đ@@)ýśřÔ|@>ƒq/ю?đ@@ ßťö@?)4<ēŔ`ŒoX{@J_)´‡T?đŔ`ąR?[D@J4ňßĘkä?đŔ`š@J?î]@?đŔ_ű/ƒHĆ#@J2kďź-K?đŔ_簕oĺ@J*Ů0”œT?đŔ_ÄÝŠľ;Î@JWGísÎ?đŔ_ĘÔy5Ś@J>uĎ#”?đŔ_´ÄdšűÖ@J†žĹQ?đŔ_ż &ŁŐ]@JWŞi?đŔ_ݢaśĹv@JőA˘ůÓ?đŔ_íZ!Ă4@Iţg‡ęŕî?đŔ_ě­ŐŻx:@IĎKĆÝeÔ?đŔ_ĂQÇFa¤@IŰTÚÓ0a?đŔ_Ňd4FŽ@IÓ î“tt?đŔ_čÎĄâě@Iś~ +ŢĘ?đŔ_Őjp9uŸ@IŞ] Đ .?đŔ_䇀v @Iœ3Ír?đŔ_Ďáá0#@IvŤW@?đŔ_ťÂęŻC@ItÖĐp¸?đŔ_›Â‘ŐĄ @Iu°˘r-T?đŔ_‡:!Ľm'@I` Žx?đŔ_h)ú-ľĄ@Isŕ3؃'?đŔ_jjYŐG8@IaÜů#ëM?đŔ_‡Uz-@IMŐżYů?đŔ_zmx ¨F@I>ŕúZ€ä?đŔ_`Ănř@IF:ŮŘÁ0?đŔ_G {Ś]w@I@•ds?đŔ_9ĘÓ˘ýq@IfirĂRW?đŔ_6­€ĘŻŮ@Iaý„óü?đŔ_>E0ĐlŸ@I5^ąđs?đŔ_#&ĹśW @I7m™) ?đŔ_%54đë@I-çgâ)?đŔ_-Ď ÜĆ@IgčŽÁÇ?đŔ_!˙,,Çb@Hëb]E?đŔ_<íŮdŒ@HéÓÍäâ>?đŔ^ű,ś7߸@I LߛĚU?đŔ^öÔjGô•@I÷qx’?đŔ^đxE‰ćN@HÚó´xˇ?đŔ^öó÷éZ@HĐӗ 7š?đŔ^÷ęš ­@Hż垏?đŔ^֊s ń@Hş’ÚÎě?đŔ^Âă:HáČ@HŻ {eßA?đŔ^Č7:F@H™Ź(žĘ?đŔ^şĺHˇˇ@H%•‹˙?đŔ^¨ĆˆĘšë@Hc”j€?đŔ^ŁÄĆ^ť@H@Šî~ب?đŔ^›Ű9`;ˇ@Hx0qy?đŔ^’ZŰ2ö@GţlK)\É?đŔ^—°…Ń@GŐ§źž8Ö?đŔ^™ŸmOę@GŻJ­ ~V?đŔ^ˇ”É N7@G’ĺŸEş?đŔ^ŻŞîŤÄ$@G§ÍXÝH?đŔ^Ľl°qP@GĂÍ3śßf?đŔ^ŁLWÖbR@G垆]Iš?đŔ^ŤŁ Çt@G㣲@?đŔ^żš†PG@GšźęăúG?đŔ^Ŕ‚IÍĹ@GȄŘ_Eœ?đŔ^ąďŠ°@Gĺ‡1úp?đŔ^´7łé{@HZ_ş?đŔ^̉n@@HÇI‚č`?đŔ^çóäŒń@H…—s`?đŔ_ŸŢ|#@HV!jˆ¤?đŔ_#gî=6@H+ rj# ?đŔ_+{ç7@H šá­?đŔ_ >"„nY@GëôÖBP?đŔ_şg=Ö@GÉRÖŔÁĽ?đŔ_H›@GŚq *Ÿ?đŔ_mŕ‹Ł@G|‘ďŁ|1?đŔ^ü˛>gŽ@GNůŞ2Î?đŔ_$ f—@G2–žŮ?đŔ^ߓ0üX¤@G?Öž[7?đŔ^ňá_ë´@GŤ›|ž™?đŔ^ű˝ř ť@GcqQ7M?đŔ^űôYĂ@FÜKťłI?đŔ^úЂđQÝ@Fş=şřË!?đŔ^ýĂÖđ†E@F“g VÄ?đŔ_˛ţ´ż@Fnöä_=?đŔ_ şTŻƒ@FGxPŤd?đŔ_×uÝz@F%ˇÚ5Z?đŔ_˛0Š a@F…t~ň?đŔ_ •řĚa@EÜ7?qÓ?đŔ_IžO9@EłęůďŽ?đŔ_”2ňiŞ@E”‰Îá?đŔ_ÖŰž…@Eo=TT?đŔ_ć=žŠ @EKËË­•Œ?đŔ_F[$äš@E&Ÿ'ٓ$?đŔ_Ý![`@EPMΚ?đŔ_ ÁE5Śx@DŕÄěo€Ă?đŔ_ĘhZďL@Dźô˘NĆx?đŔ_KŽŻ@D–Ş™Â÷?đŔ_Đ=fn§@Dm÷&ŕ?đŔ_9ż{Ö@DUj°AÜe?đŔ_Q{ë:@D,ŇW;vÇ?đŔ_crĽő@Dy؈cE?đŔ^řl°€°@Cńˇ:Pe;?đŔ^đ÷´×áŚ@CÎnęĺ`ß?đŔ^ńLI&­@C¨Îg\L?đŔ^ěnŕĘ@C„­9œJ?đŔ^áŃŘô•ł@Ceë€?đŔ^ŇI!ţgJ@CHŚ[#×?đŔ^źŰ–ĄW@C ZżŽ(`?đŔ^şą"?@Cyű/sŽ?đŔ^§yöp’@Bňf:íćů?đŔ^šÝĂ…@C˝ţX÷?đŔ^áÜO !@C Jy˙ą#?đŔ^hÔičNI@C c™8&?đŔ^kJ<#Ąg@CŮţ.ÚŤ?đŔ^ƒÖĺ—%9@CđĘŤ?đŔ^”[›k‹5@BöžćůyÁ?đŔ^‡ü˙O}>@BÍ D ÷?đŔ^—“÷ąĐ@BŐqüŔn?đŔ^š€čŹ+@Bś1˙Á—ó?đŔ^“ôLaŚ@B’Ňx{T4?đŔ^c›.D@B|܏ءI?đŔ^r-MË}Q@Bf3o˜/‘?đŔ^y(ne’l@BFp/€\“?đŔ^rNŤSľ˝@B!k?”Š?đŔ^b^ńܒE@BG-W?đŔ^V˜ŕn@Aćoh„f?đŔ^G:˜@AĚLDşj{?đŔ^7˜@7hŹ@AŽŃëéuŤ?đŔ^+Ň%…-@A‘qŽ˝y?đŔ^'ˇľg^@Am{L-/?đŔ^##ńÓ@AH.‹ß8 ?đŔ^ě Ő›y@AĐźđśÚ˜?đŔ]Ďkť@>{[P7lż?đŔ\őÂ%ľ‚Ž@>N>ĚnŢ?đŔ\ńk%ÓB#@>"ÝF1R?đŔ\č›ů(úk@=žöű?đŔ\ء‰€q@=‡™×?đŔ\Ĺçĺ[)@=jČěÁ]?đŔ\´qf…Oô@=@:ęĎkâ?đŔ\Śm.˘@=~\Ç?đŔ\˜.|ƒ!š@<Ô05xáÍ?đŔ\Š>ЎŸ6@<ŸË­ fý?đŔ\‡űŃ÷ţ@w>@;ӖJQ3ý?đŔ\šŒ›xŘj@;Ž+š";Ň?đŔ\Št<‹ß@;ŠŞ™m?đŔ\œČ‘‹@;Cć^AŠ0?đŔ\‹p7ńk@; ug¸ˇ>?đŔ\yÔ؛0Ü@:úŻś€-?đŔ\fÉ嘃p@:Ě ĆŕÓn?đŔ\Onƒ_Ú@:Óą‹đK?đŔ\CŽQý¤@:ž ^ťĆĹ?đŔ\2cë8@:mgéÝ\?đŔ\ ƒ°c@ř@:KžË°Aˆ?đŔ\˜ĂĹ<Ž@:`Żw 4?đŔ\†xČň @9ľŒś‚/Ř?đŔ\{כş@9}{ŕ­?đŔ\důdž`@9GńŹŁ‘?đŔ\-ŽÖˇŽ@8ř–h\U?đŔ\Cn^â@8ĘÄPűÝ?đŔ[ďÇĂ˗@8J¸X—ě?đŔ[ŢDOů#@8\3 & †?đŔ[ψ"”wÓ@87˘üH+?đŔ[żmá~}@8 Ńâčţ˜?đŔ[°{xŠľ@7ہRĚŤŐ?đŔ[ ű÷i0š@7ŹfŹŽN?đŔ[’+&’Q@7~.X<[?đŔ[‰Oě‚@7<ŁĂěâ?đŔ[‚Hrű¸@6ň¨äP_?đŔ[pĐڐę$@6öq%§Œ?đŔ[a*ď@0@7&ŃȌUÇ?đŔ[[Sh 4@7k‹8žÖ5?đŔ[gvxŹ@7ĽŁAä^6?đŔ[qĄ-ą :@7ĺŠúý×?đŔ[|N ÷Iˆ@8ůŇ:š?đŔ[‘˝işC@8:b3š\?đŔ[˘NcÖúŘ@8A:ݟ’á?đŔ[­6zxa@8z7ěŽŰM?đŔ[ŹZ?pţ¨@8ĂZx "u?đŔ[ąÝ}—ž@9Ś\˛?đŔ[źM‹<„@9D>{çv?đŔ[Ĺ#°­ĐĚ@9†ÔHf^?đŔ[Ńl;(ś™@9Ä 5ŚŒ?đŔ[ŐäF Ÿ@: ĽHţ?đŔ[Ú՘XW@:Rŕ7?đŔ[áSťŒĄŞ@:“Ůű9Łm?đŔ[ńTw*%@:şűÉK ?đŔ[űžLř˘@:Ů*ů›¨;?đŔ\eT8z@;ĆqÍh?đŔ\łŠR”H@;R÷7ţ?đŔ\Îşî’e@;“ŞçrÓ?đŔ\+e{!ű,@;Ă&2e?đŔ\0ťXvPH@<ż}ɐ?đŔ\6Úď˛Cş@ Úé0íC?đŔ\¨űMC™@>Q‹2fŞ?đŔ\ŞŚţz’ř@>šŁ—ŕi!?đŔ\ŽŽ(HŸ˙@>ĺD:N?đŔ\ˇÁÜĚb@?%¤Ż/2?đŔ\śŮ3s@?płăĄ.˛?đŔ\šŽŢn—Ĺ@?Ň<ńëM…?đŔ\­żŒË¤@?Ë6g'•…?đŔ\›+ë˜f\@?Ľď(f.(?đŔ\ƒžŇM˙B@?Îˆ˘ă8?đŔ\rľŇşh@?B4…ćf?đŔ\do0´Ď@?ZľfCçÎ?đŔ\N^0 ¸$@?>Őůˆ;h?đŔ\DťÖl˛H@?‹S]Ż[?đŔ\E卋tœ@>ÉËţ-Rî?đŔ\=6łĎšž@>‡9~)Ř?đŔ\3úâˇëj@>F—ssNĘ?đŔ\.]<Ąż@=űŔ^HŽ?đŔ\$ÔląœĎ@=ť#ˇî3?đŔ\2˝+ŃÓ@=zŒÝšÝ?đŔ\3ô.\Ţ@=Dü¤,ę?đŔ\°źœ›A@<ú×űř4Ľ?đŔ[ůˇŠÇ2@<Â}§łđ ?đŔ[í@yüěj@<ƒlĎfŁ?đŔ[Üă(‹At@?đŔ[Sćr‰78@9­nˇXŘŕ?đŔ[>^VŞĚY@9­r(˛ˇ?đŔYšSŮĄď@2!(TeS?đŔYŚŢoçń @2 ™Vˇ/?đŔY”;mR¨€@1řQœ7Ă?đŔY‡jĎ@1ön/Đsä?đŔYpł /đ@1Ő°:?đŔYbŰrĄ?>@1 @¨1Wä?đŔYS)˘˘=@1włŤR>Ľ?đŔYC3[ü@1M&WX(Š?đŔY1ŃGx%@1-ů:?đŔY ŞŃ‰@1ăY ^đ?đŔY •>Á{@0ůŐďYŸ?đŔXúœŽ÷¸#@0Ű ţNx?đŔXëFˇ­@0śŢf9÷Ń?đŔXŘ ęgŸ@0Š Ţ[™?đŔXĹ„Šš @0™ÓuŇ2;?đŔX˛ŠŠžc@0…UŮ5 ?đŔXŁ\đ¸:@0Uüó.?đŔXŒ™2Ťů@08^‘ĽŢ?đŔX}ĹDYô@0裘48?đŔXnŒḾż@/ďĂ ńĽ?đŔX[9ěşŔś@/Ţníśy?đŔXHbtĆU@/ÂŇLľƒ1?đŔX6ňJoĐ@/Ń9Ÿ.Ó?đŔX#ş4ň´@/W%Ľf˜2?đŔXŰ5ÝüÍ@/`Oƒđ•Š?đŔW˙Ný˝k@/•/ě |?đŔWí^‹šđ­@/ĚCQůź?đŔWŰćzJă@/˙×ú'ţ7?đŔWĘđv—h*@0(–§÷=­?đŔWşö—ťp@0E*jň Â?đŔWŹť›†6z@0H°2žŚ‰?đŔWœÜHí´S@0,Ť´ƒ˜?đŔW†ŔÔ Đ@0ŁXŒ?đŔW’gýV@0.?ťdď?đŔW‡M”#@0,DŹ@Ńš?đŔWxk}ÝÇ@0†Öžł?đŔWh芷Úü@/¤vŒTUä?đŔWYň´5ňî@/G÷Îôę3?đŔWK…mQŮ@.čvódO?đŔW7<ĽâgŚ@.fÎ!Q'T?đŔW0EdKĄ/@.č%-1?đŔW#P0`SŘ@-˛ CÍ?đŔWŕq@-IléŸŇ?đŔWÚoc=@,čBŢË?đŔVřűj Á@,‹Dčr=?đŔVéB¸| I@,9ďĽě?đŔVŘPÔC ß@+ř^Š˛š?đŔVĹć,˝őŃ@+Ö÷w˛§G?đŔV˛Â ˛H@+Ú*ĆŞG§?đŔVŸüĺ­Em@+ËÝáQ6?đŔVŽZsőĽ*@+–ľFˇĽ‹?đŔV}<Ä:W|@+W3\%g?đŔVmŚLĎ+o@+şX†MŃ?đŔVYęîKa@*ű…Á9&@?đŔVGőŐTĘ@*ĎpżyŚ?đŔV*<Ťo@*xřŽqŘ?đŔV!0Ŕň73@*{ŕ“-S%?đŔVşZV@*[ßčŠú?đŔU†¤˙ KÇ@&â÷ĎwK*?đŔUx’_2*î@&- ´b?đŔUrVuo‰@%ěĚ÷ôČ?đŔUlS˜u‚˝@%mUăÚ(?đŔUq×g˝@$˙šűŸ(?đŔUu–J z@$}Ť4¨?đŔUl™4ŢZÉ@#ň´Ü{—Ž?đŔU\ĹÂŕuŁ@#´0Ąt ?đŔUK%‡@6_@#SňM3N%?đŔU<łŢǜY@#š\­3ƒ??đŔUKÚJUIă@$73řňúm?đŔUBw9Ú;@$9+O@rB?đŔU2V"ż‰ö@#čžÖ×ů^?đŔU) ’@#eĚ#W?đŔU™ŁoŒÝ@# ~ÎĹh˙?đŔU Fœ÷ŽT@"ŰŘ CPO?đŔTű˝J˙jé@"”}ŔÓX?đŔTí=cŰß@"9c=`˛?đŔTç3Đ<˛@!ŽşÁôî+?đŔTęř)Ůşƒ@!(4n˘Gř?đŔTŘ˝Nƒąd@ Ô*WG¨Ľ?đŔT؞ÇXúç@!?d?đŔTÍ. )!ß@!;śQýÎ?đŔTĆşů @ ĆPzç˙?đŔTťŽzœş%@ Fď@-k?đŔTś§Ň€6¨@ ]Ąű0Í?đŔT¨Pc~!ľ@ šňŻYěä?đŔT—^'ŇĄŠ@ ŸĚdœX¸?đŔTˆ5^l@ sn­‘*ż?đŔTr‹BŒ@ H졑Dç?đŔThVâr@ÄTŽ=Ž?đŔT^ăŠN?@݊?wâý?đŔTIČÉŔq@°’…]”?đŔT=ŽÇ•IĂ@'ý!gĂ?đŔT6ďĹÝ@ ď%8FF?đŔT#ĄŽ™A@ô#bňěŐ?đŔTŻXUâú@†Áđ@ä?đŔTvń  @ ?ńů}?đŔT ĐŹX@.[|ľ?đŔT×řU‡@ ǞŐkś?đŔT"ęE.š@ ‚,BXą=?đŔT(•wx3@ ˇŸŃg?đŔSőäÁ?đŔT;Ëf§źŽŔ`jŞ^?đŔTH,`ď‰Ŕťƒ*Ň?đŔTRŠńœSŤŔ|úśŘĹ?đŔTTKí^/Ŕ§7Lŕu?đŔTIޟˇnëŔњ9 ˆč?đŔTJ ŐY9ŔâŠv[űş?đŔT= Tđs&ŔĚ"y_pé?đŔT8ŔlPŞĐŔç"M?đŔTFá.{ Ŕ0ľüţ?đŔTBĄÁîąpŔę^1?đŔT2Ĺ^4ćŔ1"Ŕ;•?đŔT"' Ý$ŢŔş÷AÜŋ?đŔTĽŻ ,ŔDł Až?đŔT3ňˆŔčƒV´7?đŔS÷$ÄřáŔ҉Ť-Ź[?đŔSëî˘LŔžÝˇ*B,?đŔS䀝ŔĎ%ŽÉ’N?đŔSÜO*ž bŔَҒ„Ć?đŔSŃááĘtŔĚOĺ—0'?đŔSÄu*MŠŒŔ Jň”˘I¤?đŔSť7Pu#ŐŔ ËI´ŤI?đŔSą%HžĎŔ!JŇzÇéŽ?đŔSŤÔ0~xŘŔ!ÚIęÍĂńîÉ Ŕ,äKg†ŕ?đŔR÷ܒň…2Ŕ-^Žy•D ?đŔRč §ŔŔ-´‹žé?đŔRÚörĺ’Ŕ.Ő4ă3.?đŔRÎ “Ýŕ´Ŕ.ŽNL+4`?đŔRÁe/ˆŠˇŔ.íxjű7Ú?đŔR°lw–Ŕ/2¸ěd/?đŔRŸŤÂu9‘Ŕ/zÇoč Ý?đŔRbç“ÉoŔ0jËfáÂ?đŔR:Éä{ Ŕ0Œ|r"&?đŔR)IěŰŔ0¨Śrš˛×?đŔRš@ßŔ0Ç3˜ĘĄ?đŔR ‚aŃýŔ0řM5 §x?đŔQůR+SŔ1 Žý(q?đŔQç†ÉxĐŔ1@s°Ôď?đŔQŮ˙oŢTŔ1pČŤ˛?đŔQÓsHi\ Ŕ1´AJ¤ś?đŔQÂČ7yÓçŔ1ŕŕbž9?đŔQłÉ~žHŹŔ2Ž,’|í?đŔQ¤E *oŔ2;‚Äƞˇ?đŔQ–L8Œ¤Ŕ2p} Ŕrü?đŔQ•ő™‘ďnŔ2ź>:X'?đŔQ“IýŞ žŔ3!ďÁ™?đŔQť:Ž+FŔ3O&E,›e?đŔQŒ[­…4+Ŕ3—JŤ”çN?đŔQ‰3Ŕ¤ÎíŔ3ßwyupâ?đŔQ‰ňŻI3Ŕ4)Ö˝#Ó?đŔQ‹ŒÖQŔ4qÖ v+ ?đŔQŒ)•‡{“Ŕ4ž‹şnź'?đŔQˆř𑲠Ŕ5ĚPě4?đŔQ…ýgĐŔ5Oł(!őP?đŔQ‡ŕ§ęČŔ5–Řsš?đŔQŠšôźŸaŔ5ßŢW)?đŔQĹŤĐŔ6'í[ZÓR?đŔQ.CÂ_gŔ6r–˘Ęö?đŔQ’‘4“¤Ŕ6ť‚žŔ?đŔQ™ô§îńŔ7Č'PŇ?đŔQ¤ŹĚm=Ŕ7-(:Š?đŔQ˘n "t¤Ŕ7v°šKĚ?đŔQœÁť8,Ŕ7ąöó/œŠ?đŔQ †\gxMŔ7÷íA¤,?đŔQĄđ îO•Ŕ8CuÉb¤?đŔQ¤ő]œ„Ŕ8Œů§ 1Ż?đŔQ˘ÉT&áŔ8ՐĄ Kř?đŔQĐWŹŻ|Ŕ9Ë*ƒ"ť?đŔQŸę‹Ľč›Ŕ9e^˝ľ˝ő?đŔQŞT٤mĚŔ9 ůńôćl?đŔQŤ8Ĺ‚łŔ9ëM˜ó?đŔQŞ ĘË$Ŕ:6I„.WŹ?đŔQŹ^üřGóŔ:{¤Űa÷?đŔQąm[)#ňŔ:ÄáÇ>~?đŔQśÚC!šĐŔ;ˆÝŽ X?đŔQź%/ěü}Ŕ;NÍĄ?đŔQźŇ $ÎuŔ;š]1JÓk?đŔQĆCŰPSŰŔ;ŮŠe€ĺ?đŔQÉ˙üKGmŔŔ<­AcôŇs?đŔQßpăč={Ŕ<ńĘáÇcŕ?đŔQŰíÖ"ę‚Ŕ=9őĹU}˛?đŔQÔrŕ¤oŔ=€)˙óÓĽ?đŔQÓéMvŔ=É8có?đŔQ؎OYNHŔ>šXO݉?đŔQĺT˛ľ,Ŕ>G*ś<ôŽ?đŔQěŚ6•7Ŕ>Š3ąXgő?đŔQë˙ä ŒďŔ>ԝďć{´?đŔQéŰTâ,Ŕ?Ëü?đŔQć‘BMŔ?há$”S?đŔQâÂB§ňâŔ?˛‘k†qĘ?đŔQá4‘Ł˙eŔ?ůdÜԎ¨?đŔQßF¨ŇŘŮŔ@""˝Ĺ›?đŔQܥۍöŔ@DŹ›-ż?đŔQáPת[Ŕ@gĂ4Kq?đŔQëEf<ž,Ŕ@Š#“ěő|?đŔQěÁdŚAŔ@ŽŤĄě†Ë?đŔQęţ0%üŔ@ÓUG&Ţ??đŔQöű:ďŁŔ@óä^?đŔQ˙O‚ŹZŔA‚xş‘œ?đŔR´ř08ŔA9ƒx%%Ń?đŔRP˛ŐnŃŔA^=’”ş?đŔR -› őZŔA`ŹżŠą?đŔRxxX„ŔA (Iš?đŔR$Űý] ŔAŔć…pÓ?đŔR'řąâŐŔAäôV ?đŔR2ÂĚ[WŔBJçҖĆ?đŔR6ľäôJŔB*@S$ľ?đŔRAŽĺ UšŔBO[žhą?đŔRIč_[ ÔŔBhFľĺ?đŔRMŹ$ÝrĆŔBnFÎ?đŔRcx?˘é¨ŔBœŹň͊?đŔRhĽ™aPŔBžŐówl?đŔRgUÎT ŔBâFb”îw?đŔR^}‡rŔCnřܛ?đŔR`˙X•ŹŔC)ýĹM_?đŔR]éĽč„)ŔCTĹ:•á?đŔRW~t H ŔCq˛Es@?đŔROâiFŘWŔC–żg~ˆE?đŔRPôXaŔŔCšŠH—äŐ?đŔRWěíĄŒjŔCÜĆůžBŮ?đŔRc$Ł}á^ŔCőŽÜ f?đŔRmČb~^ŔD˛XU÷?đŔRq|1"źÓŔD> aál?đŔRxřÖ ďŔDaśŘ+´?đŔR}ă¸Ŕ%ŔD„ź‰]g?đŔRxLL…dŔDŞ<Ć°?đŔRl)ƒ&<ŔDÇě!ě_?đŔRhn]~$%ŔD×`Č8ľŕ?đŔRSĄ@Ć3ŔDăă–%¤„?đŔRCôŮ[Ť”ŔDĚĚΞz™?đŔR1řˆĽ•"ŔDÇ÷z˛M?đŔRBĎ{őÎŔDĹÉý/ôR?đŔRÚŹá#ýŔDÖŔ[šo?đŔR2™d”ßMŔDîçf5ór?đŔR#&‹Í’,ŔE¸“/Ôß?đŔRŹÖ\ؕŔE(D/üUŹ?đŔR(Ş‘hiÖŔE$U^ßQ?đŔR+C~‚ŚŔE:54E ‚?đŔR0ąPů3.ŔEHŠÝ"Y4?đŔR3ˆN(v<ŔEmú’é?đŔR6`–YP˛ŔE‹Ú˛‰>!?đŔRDB*) óŔEŻ=§Č D?đŔR;óČÍu(ŔEŘ°On\˙?đŔRBÝŤ ­<ŔEＺeţ?đŔRJÔ˘ŤŔF3ĺĆh×?đŔR1*+°ŔF4kB<*?đŔR(˙­ÝîŔF@w$UB˙?đŔR2˙í—ŹŔFa–X"zm?đŔRHÍ‹‚ŇŔFvú¨5/§?đŔRWĚ(P†ÄŔFÂéwú?đŔRF'ÉäddŔFŽ`Űg:?đŔRT8ĄŔF°j9N?đŔR[‹|ÔŔFŐmdĄ ?đŔRdp!‚ž¸ŔFđĆuŠß?đŔRiˍ˝BŔGŻŸ?đŔR_חäŔG,żc9z?đŔR`|čŘŔG†%Đ?đŔRs/sá hŔG>"择F?đŔRzÚ čÜlŔG"Éq$Ů?đŔR“l NUŔG5î ?đŔR‰ŽWsmîŔGP‰/ő˘?đŔR‰+rýnÉŔFôţśňÄ4?đŔRŸăÄjŻŔFńĽä$O?đŔRąnm.–ŔG mß p?đŔR 2óœŔG!ƒžďkn?đŔRÔßĘ3ŔG5š÷Ŕ?đŔRâvm‡˘„ŔGaơT`?đŔRŢÉűBđ6ŔGW}Ÿ“P?đŔRŤ.JGŔGFŽ¸T@p?đŔRÁƤ{ŔGOăX›Ű??đŔR¨ŘoBn%ŔGiVóĄÂť?đŔR’%fűßŔGh €í?đŔR„­ţ֞ŔG“öŰ­^ş?đŔR˜š楟ŔGŠyu—Q8?đŔRŽîWB,:ŔGÎÎ#‡Ž?đŔR FϟÄ7ŔGŃ:\ †@?đŔR eÝtnŔGáŤânąF?đŔR†ĺçá”ŔG果H÷Ý?đŔRpŚƒËNůŔGŐVVFKË?đŔRjŻ1zLŔGŢNÓYÔ?đŔR[’IäŰŔGř“€Ŕ'€?đŔR^Ď¨ňŔGúÖNł Č?đŔR\uäoßŔH˝´5?đŔRpkk>ˇśŔH äɛ)?đŔR‹ž+GGpŔH ;~Óă^?đŔRœ.XüŐńŔH’=°‚?đŔRžČÉUŚđŔHĹՑťé?đŔR‡6…r[šŔH-ťBŒú?đŔRŒHśaI¸ŔHMuŻ4tś?đŔR•úkŐ6ŔHf<<7Yn?đŔRššú0 ŔHŠĎ°Ÿ˜?đŔR•uĚ==ŔH´ö×j]?đŔR‚Œ~UČŔH“őž–?đŔR€ň”ü@éŔHŤvA@çž?đŔRtôÁL9ŔHŇ!W'9?đŔR}oą/œ§ŔHÍiôŠŻ=?đŔRŽ`54ĎľŔHŮÂčYˆŽ?đŔR„ĆłŤŞ3ŔHô…ęź H?đŔR†ŮŸ¤i;ŔIż9˘JÂ?đŔRó[Î1ŘŔIOő2”2?đŔRž>󭂯ŔI$ůSŠP?đŔRˆS’›0ĐŔI<°‚ -§?đŔR†ĺÇ$)ŔI^ˇSü‘Ö?đŔRkţxWŒjŔIJuI?đŔRnƒ^’.ŔI^ţ„ŞÍ?đŔRƒěŇëŔIyąI~Ż?đŔRw¨˜ˇľŔI—ţPĚt_?đŔRnďWfăŔIťŤQŐPą?đŔRl / NŔIŘQ7Ct˙?đŔR^ú]ɸˇŔIüY?źĎ‡?đŔRU”Ě#şŔIç2`BŻ1?đŔRPn¤ă@ŔIúw?đŔRFřś ŽŔIäŃťś?đŔR2_2:“ŔIâ<“ő“¨?đŔRAU$,ÚŔIĹcŒřą?đŔR2+€ľSÎŔIĘ(âÎ?đŔR"žěpŔIíşă)\?đŔR%:Lî‡ ŔJ lŞWŕ?đŔR)ÉŰ óŔJ2Űęp¨¤?đŔR)şbźČ˝ŔJ(Ź_•?đŔR,@1ďŢUŔJb^‹Q?đŔR6ń KvqŔJS‹ŁVŘ?đŔRCöŁßĹŔJLovĹ!?đŔRc”ÂŞnŔJńß>Hî?đŔRgˇ5ŮżŔJ mćy?đŔReŘćWŽ6ŔJJőů9;E?đŔRL\$ĽÁoŔJFĺ€ o?đŔRHÜś0ąŔJMćĺĺ?đŔRVxśîĎÉŔJn”GDú÷?đŔRM'ŽAAŔJˆá\„?đŔR=`ŸG0ŻŔJslĂW‘ť?đŔR5œ Q6ŔJQ>Hąě‹?đŔRĄżťŔJGá˛Ŕ†?đŔQđ䃛…ŔJJń'§đĆ?đŔRJ7„U?ŔJURŞě?đŔR$|hËΌŔJfscBœ•?đŔR9űĄOŔJspň@ƒă?đŔR:~…XĂŔJ˜đ˛Aq?đŔR(K5ŞŞ^ŔJˇC׏Ý?đŔR(íäÖŔJ—¸ťnx?đŔR ŐXü‰ŔJ‰í­˙Ł?đŔQňý˜%”ŔJ{ YŻh.?đŔQעŽźJmŔJfßůX?đŔQÎ4(/ŽŔJ|ujĺŻ{?đŔQăč„~qŔJ•×ÜŢ?đŔQőăx}ąŔJşKśsţ??đŔQő6WTŔJąŽŃYt?đŔRó“ŁižŔJŠţ.uS?đŔRd§łŔJľ Ű˝E?đŔRڎ¸×°ŔJՑj5w~?đŔQëÁý[1ŔJ執Q?đŔQËí3_ŔJëö~pš€?đŔQ˝VeţÝKŔJÍÖ´žšŰ?đŔQ˝ěżĘS×ŔJ¨Ô˛¨|č?đŔQś™ąCíŔJƒaŮj˜s?đŔQ­S—ë¸éŔJ^ŽrąqÖ?đŔQ’ň§üa/ŔJQ×!ő$Ľ?đŔQvăýAĆŔJB–j¸w?đŔQa&qcPˇŔJ/ŹXš ?đŔQJÁ׉œŔJáńň˛%?đŔQ$; ŮŔJ&bŽ´Ď?đŔQ*‡QhzŔJkĂyp?đŔQ7žĘókSŔIăc#~E?đŔQSďÚYšKŔIϲ˜ƒ›6?đŔQJŸ\,ČŚŔIÉĆútäŞ?đŔQ@÷ĐhŔIłű% ďŹ?đŔQMtçK•ŠŔI‰čÇӅŻ?đŔQNâÉô‡ŔIxWAŮú?đŔQG•Ćj2ŔITö;řN5?đŔQ<@÷/MyŔI3j’Î}#?đŔQ!ĆGۂYŔIîTP?đŔQ1ŰB› ŔI1ŃOX?đŔQ,łPƒŔHń`‡| 1?đŔQ%’ŰwęôŔHîť`ôCČ?đŔQŐYĹ=°ŔI ¨¨Ç˜?đŔPř˝ŠE@°ŔHűű:}ő?đŔPîá¤j6RŔHÚ?AON?đŔPěˇÜ'— ŔHŽĽ˛źgi?đŔPčPˇÇü1ŔH’y€Jƒ?đŔPŮo*€ŔHsŻ!.űˆ?đŔPÇfޝŔHWź\ÂFÜ?đŔPąú|ř,ŔHAţĺŤXs?đŔPš'éQÇŔH,’hW?đŔP„déĹůŔHž'ˇľG?đŔPƒĚ@žŔGń­hÖ*??đŔP|łeœ?zŔGßÜÚś„p?đŔPpƒćx ŔGżŮt+Ź?đŔPsęŐ†ŔG›66‘?đŔPˆA2ěWćŔGŠ‡Ć-xs?đŔPŁY’JÝŔG†Š„` ?đŔPšÇ)XüŔGtSeDáZ?đŔPĚ.§:řŔGZâԐ?đŔPŢozŞ›ŔG>ÎQů ?đŔPćeŁYÜ/ŔGćL|Ý&?đŔPáëLĚ)śŔFřápí ?đŔPŐ^íÍqFŔFŘög&}Đ?đŔPÇĜÖÁgŔF¸č ěž?đŔPś| 5BŔFž˘¨5Ű?đŔP k—NŽŔFÖ6Y˜Ę?đŔP†ĘU$TŔF~b¨?đŔPl€’‹ÇŔFAŃf]Ű?đŔPi°5ĎŔFaĽ˜š.q?đŔPXW’Ż}ŔF@ęţF'Ć?đŔPQqůhÖŔFĺ1˜9?đŔPP,ŐŔEűYJ“ü?đŔPSZSx(ŔEÖr*_Œě?đŔPF3Żbs`ŔEś5×ew?đŔP6őÓōŽŔE™Á*ŮŽ?đŔPŸţ!ƲŔDg3:KŇű?đŔP3îBŠ”ŔDeŻăÂM?đŔPšUçĺăŔDtk䮌§?đŔPďŢlôĐŔD‚ďnďF?đŔOŕĹňČWŔD“:ků§Ś?đŔOŻűýńŔD”l‰gę?đŔOČąp“ŔDř%ˆ’ł?đŔOSH>‚źŔD€c‰Śh?đŔO%ŔąXLäŔDaĎZt5?đŔO*ŹöůőŔDEóeKIô?đŔO5˙ RŔDŤœ(:?đŔO* z¤ŔCúşqżŸ ?đŔOšÁĚŔCâŃ( ƒ?đŔOšw1~ŔC˛ć{ĎѢ?đŔO$V9yFůŔCœˆFc5.?đŔO&ýVŔCr`¸Ţ4“?đŔNţEoh]'ŔCx'yUeš?đŔNÎiőűŔC€ÄŽ>W?đŔNžp€ÝëŔC~ČŠÔ:?đŔNo¤"qĽ6ŔC|aOő­?đŔN@'§|&ŔCvŹ6řE0?đŔN–Ľ\łÚŔCp!â˝Ć?đŔMâcÇ6ݡŔCimŔůş?đŔM´}Ňe"ŐŔC`$ÄGűă?đŔM†ĄýúîŔCW˘gB™Đ?đŔMYóĎáî_ŔCK hć?đŔM-+çűâŔC?*“ľ?đŔMŘCDŔC/HÁnźĂ?đŔLŰ3^ÉŔC?Xv†?đŔLĂÖqŚŔBţŮ^fŤş?đŔLą^0Ź˜ŔBÝšMoŰŘ?đŔL’‡Š‘ĂŔBÁĄxůR?đŔLz;ăá~ŔBĄővn Ă?đŔLa­ éŤďŔB‚J›Ż?đŔLUŠçšAŔB`$ŒŽăť?đŔL\lqÜečŔB5Âőó0@?đŔL~Čk†÷§ŔB)čRŻ?đŔL˘h 9hÁŔB]FĚ(?đŔLŻőę岈ŔAí‚z%#Ü?đŔL”‡•m¸ŔAËŔ€Ś+ŔAf¤Đh’r?đŔM'“§Đj0ŔATnRł?đŔM?ŸŠ:ľUŔA63Ë$ŁŃ?đŔM7V˝LřŞŔAQők?đŔM:Ü>ŚfŔ@ö×Bż?đŔME r5UŔ@Ň,N€Ę{?đŔM;ˇ¤ö…Ŕ@­'ŽA“†?đŔM)šź2ÚŔ@ŽĚ´Ĺť?đŔMUös0´Ŕ@sťQCÄĹ?đŔMŔgbŔŔ@KĄ"ĐC?đŔMţŕ§Ŕ@OľĄŰ5ś?đŔM >W#IđŔ@t §+ž?đŔM ë•gÝĽŔ@>7šÍ?đŔM1'"N¨Ŕ@°(ֺȲ?đŔM7:ą~ŔŔ@ÓďÖTŻ?đŔM/ Ť]a'Ŕ@÷ÍŐľľŠ?đŔMăó{4ÉŔAË÷ši ?đŔLôěŚđăAŔA0ϙŔĄ?đŔLŃ˙EÔ ŽŔA:őş‡8?đŔLĽůę(c?ŔA9| ÉyŐ?đŔL€F'˜AžŔAHŒş”W?đŔL[fr1ŔA\'äŁF?đŔL2áŁ÷DŔAjÁœ€UŽ?đŔL ÖVt JŔAqčÖ×J7?đŔKŰ÷ź“‹rŔAe`sáűb?đŔKŽť&TŔAkm쇬?đŔK‚ŰřfŕŔAv m |ë?đŔKY6ĎR_ŔAoOţ"l+?đŔK)ÍŁćMŔAU‘Ä/Ţy?đŔK Ú0÷oŔALmůđc?đŔJéˆ)Ÿ9şŔA1ěk’­?đŔJŃĂ3šqcŔAŻŹŘ."?đŔJž?֐Í2Ŕ@ňQ']bĆ?đŔJ˘ßäU<Ŕ@ÖIŹŔƒ?đŔJ‚ľGŢť§Ŕ@˝ îgĆą?đŔJc3nŔ@ŁL˘ľÚĆ?đŔJKŒ9ÁëWŔ@„”•ĐF?đŔJ; %ešŠŔ@bDÉá?đŔJ.;;é7Ŕ@>Ňi}ré?đŔJäďsŔ@ÎU@TŽ?đŔJ;ŒŮˇŔ?ü$ †ä,?đŔJ Ÿţj9Ŕ?§ŹQŚG?đŔIűۊÎ2Ŕ?kn{•ëş?đŔIۤﰝˆŔ?>¸ţż?đŔIż‚ČsŹcŔ?cř @Ł?đŔIŞe&‘&ËŔ>žěśË—?đŔIœŸ$3Ŕ>y0ŮŠ:?đŔIŸ Y|Ŕ>4€×:Ž?đŔIq”čŔ>=1cp\J?đŔI\ˇ!‡gŔ>WšŽvŠ?đŔIWÎFŔ>ŒaDáé?đŔIdUŽô*žŔ>ĐXÖv?đŔI€ŽÝFÎŔ? ÄSŠłY?đŔI•D1YńdŔ??Sk”¨î?đŔIŞ…1˛6gŔ?}ó†é†=?đŔIÄؒěýäŔ?§Ž"W`Í?đŔIűѤ Í}Ŕ?ńîB†?đŔIăä_Šł1Ŕ?ăƒúÝ̧?đŔIżF™űŔ?ťÓřâÄÁ?đŔIžI‰űŔ?‹‰C×?đŔI€z8Ŕ?VËŮ'č{?đŔIdvč_Ŕ?ße?đŔILîâ,ź†Ŕ>ŕxŠń”Č?đŔI6¸oFýľŔ>Ąl•ÂŐN?đŔI"Ě škaŔ>`GÚëžR?đŔIŕW ۅŔ>Œ§Ÿ’ß?đŔIC•Î“Ŕ=ŐKl?đŔHň=”@’nŔ=“!ŁP›š?đŔHŰvŒN:Ŕ=T÷~y‰ť?đŔHÂEúe#˘Ŕ=uMB.?đŔHĽa•,™ÓŔ<ä[ňş~?đŔH„ĄŠöývŔ<śˇ!áśR?đŔHgЀˇ ÍŔB\"rgŔ9ajé#Ś?đŔH 33ŔVŔ9UÝÁ‚?đŔGý†ĺ‡őŔ9&ւ_Ť?đŔGö'§)Ŕ8ü’t˛Ş?đŔGÓýáćŔ8ƙNlˆÎ?đŔGŻĐ†Ł^Ŕ8¤łjŒA5?đŔGŒi¤x;Ŕ8wyĹżąĄ?đŔGs 9äđŔ8C`*ěöž?đŔGOřôOjœŔ8AÎrýŢ?đŔG&GňšŠ´Ŕ7óĽ›IçA?đŔGԒŽ‡FŔ7՚-Wšź?đŔFáz ĹääŔ7ĆŔÁ}?đŔFšĚY<îŔ7Áx‚ý Ü?đŔFš—Ş1՟Ŕ7Œ†Üć7á?đŔF| †ŻQŔ7itA„a?đŔFRA3΍çŔ7WĚîƒq?đŔFR*gm—Ŕ77X5:í?đŔFBÇ.'<Ŕ7Ĺënd7?đŔF"|ENUŔ6ţď­§u?đŔEîP&ęRŔ7žœÓ#?đŔEÎŚN§T¸Ŕ7 ÄŹš#?đŔE¤T6 Ŕ6˙5W˙i?đŔE—Ť]j$űŔ6ČG˝RÎ?đŔEˆ˛މFŔ6ݔ]pK?đŔEgqkDy:Ŕ6řŢHČ?đŔE?۝6ýŔ6ń4ż–Ř?đŔEť‚’ťjŔ6óE.żô?đŔDůäţÁ°›Ŕ6Ä ?czů?đŔDóÁ]ŚŔ6~Ó3ç=?đŔDŐý‘ĄšŔ6KWćV›?đŔD°źÇí)‡Ŕ6.ÔzeîĽ?đŔDŒIč"ÉňŔ6PœŻP˛?đŔDr°KúŔ5×âË×Çv?đŔD„d‰fÍŔ5<2™?đŔDz6Œ‘=VŔ5EźZŠăň?đŔDiŻş‘ČƒŔ5}ql?đŔDQe`§ËŔ4Í3÷ ń›?đŔD62F÷z˙Ŕ4˜U:˜NŮ?đŔD'YczŔ4MÇ*Y‚?đŔDfłÎ”Ŕ4RUš}}?đŔD€V‡Ŕ3Κ÷‰đ?đŔCçę42‹%Ŕ3›xWŁ)?đŔCŮňÄuŔ3Uó‡dt’?đŔCÜü5NŔ3 ŕ‰xřB?đŔCß@r7OŔ2Á…ĺ‚{?đŔCŰz?7IŔ2xŔáî^Ô?đŔCÎ˙⊍Ŕ22)Š#´4?đŔCˇŐ¸­ßKŔ1ő{ą Ľ?đŔCšjĽŔ1Â{rŃó?đŔC˜ňŹ{Ą„Ŕ1{V=<šś?đŔC™˜őó;Ŕ10€ŰZš¤?đŔC‘ýůđxŔ0čëĹv‡??đŔC‹S<‡¤?Ŕ0Ÿj .b?đŔCďEĄŠŔ0Ws~ďÖ?đŔCwl&„/ŘŔ0žË˜Ů-?đŔCríćiœŔ/ƒŚĄ?đŔCz㌭ˇŹŔ.üž”Ţ|3?đŔC˝˙×ĹčŔ.i­í×<Í?đŔC‚ÍxňËŔ-ÍíDoÝ?đŔC†Śx4óŐŔ-C6Ź*''?đŔCěéwťŔ,ŽÖFŁY?đŔC~ÎľÚ°Ŕ,yÂű”Ë?đŔC…éÉÖÇŔ+’‰Ö4u+?đŔC†ë‚y@žŔ+ŹKŒřé?đŔCw,Ts]eŔ*„˙A&Ie?đŔCjĺ÷‹˝ŚŔ)´Gž`?đŔCXUńRěŔ)a@mď?đŔC>JDŻ+<Ŕ)Đf>éQ?đŔC!Z’-(Ŕ)ź”D˘ţ?đŔCd¨´”Ŕ)KősM?đŔBóŇiú|Ŕ(Ńť$Ý!ł?đŔBŢ1eeŔ(X—ßԌó?đŔBË˙†ÎÓńŔ'Öš™QA?đŔB¸ˇ*œEŔ'(Ţ#fsŢ?đŔBŽ.^đ†Ŕ&Ş.pťRČ?đŔB˜ľ˝"ćŔ&;t‘G-“?đŔBßöž>Ŕ%ŢżâlŔq?đŔBi.7@tnŔ%p_uśco?đŔBI4(¸)Ŕ% żhبŽ?đŔB+Xl)ĚÝŔ$ĎSÍÍn?đŔB='ńŔŔ$Z]Ům]?đŔAü9÷śŹŔ#íĂşű€‹?đŔAę7Ý*0›Ŕ#_ŏ§vÔ?đŔAËVÄ"Ŕ# Œ ÄŐ?đŔAłBŞÄ˘Ŕ"›yőE˘.?đŔAăÚČ!Ŕ"!ŠŁ¤g?đŔAŽĽŢá%ŽŔ!›˙]¤äZ?đŔA˛4C'ˆŔ!•Bi'ě?đŔAvžďâMŔ †%˙/ďž?đŔAm‡•ŹŽŔóèyŠt?đŔAn+W%2‘ŔŹ$’ěŃ?đŔAi+65ELŔŃ ÷•:*?đŔAl­gbw)Ŕbrđ]`?đŔAs]U‚Ŕy‡G7?đŔAzýšĺcŔT‡)4?đŔAˆTˇƒ1ŔŇscŰŰ?đŔAŽťyŃVŔŘ{ŔAů?đŔA˜ źô’ŔŸAeŰą?đŔAŁ‰đŚh‰ŔĺĆž3)ö?đŔAˇcÖP%ŔćfŰžg?đŔAŘ3@ ŔhĹ(ÔÁ“?đŔAý_qŻ¤œŔCf~jt?đŔB"aČxăŔdŔŞqú}?đŔBGďÄn’Ŕbׂ8W+?đŔBii‰‹˝=Ŕ lcĹżd?đŔBŒżŽfĘŔŽM›ňpB?đŔB¨Ü şuŔďČF‹ ?đŔBÉiqěŢ@ŔrFe Źg?đŔBäňÜo˘żŔąëŒ›„¨?đŔC%Ú<:WŔ÷ąa4ąľ?đŔCZýď)_ŔvŚ $?đŔC5ěöRééŔ]Ó QՒ?đŔCT ďD92Ŕ OW*t1|?đŔCqý eŮöŔ ö`*l ?đŔClȐłâŔ ą Kô á?đŔC°Yw:ďŔ ‡‰´Ňé-?đŔCÓ>šóĐęŔihܲűů?đŔCń˝îQZŔK%˛ý?đŔDÖ|€jgŔ§Ľik?đŔD9‰zŔx 9'4¸?đŔD^ÖS˛jŹŔŇĹoސ?đŔD„#ŒQpžŔ’ď]úY?đŔDŚË9‘އŔ~…^Ť?đŔDĚ #ž=gŔł’‹ă?đŔDň˘MÓňŔ-—Oq?đŔEžHĐ?VŔx&ôľăé?đŔE9W˙ƒm ŔÓ}Iü‘?đŔEYLéŚŔĹz›Ő+,?đŔEzW/lÉŔҢ‚Ź?đŔEžśÎ_°Ŕ„nîaô?đŔEŔžco˘Ŕ֛ Ç ?đŔEă ƗŞŇŔ_• l$?đŔF9 Őt~Ŕ c˛şŔ¸?đŔF ŚĽíZŔ ڍ?đŔF!‡wk˛Ŕ „4 Î?đŔF0ńŢÜŔ…'ô¨‡â?đŔF;ÎEö¨`ŔČÉsÇv-?đŔFY9CŸ@žŔ Ś§˘žýw?đŔFZC¤Ä:lŔ ÂvÇš?đŔFTčŁř?Ŕńd~o<?đŔFKf§îUřŔŞ4Łf ?đŔF9ďÂx\ŃŔ‰ç,ŸAć?đŔFV¨4.ň˜ŔşƒĎ%Ţ?đŔFT•Ě[fŔŞš88$?đŔFF”š˘pBż˙,ä—"Öb?đŔF_ŞPđâ$żű°wXżÁ?đŔFz¤ěh‚ćżřšŹĽďç?đŔFŁtŁ# Íżůœgú•°f?đŔF¸¸Ť7„żöva‡Ž?đŔF؉äV@żôR°ę†ű6?đŔFô2uđŒ.żó@°F/űœ?đŔGËô|´żń[ ŤĂ†B?đŔG02aŃjťżđŻ~JőŁr?đŔGVŞĘRżí”ďnł^‰?đŔGv;*ćr˝żéŤi\C$Ŕ?đŔG˜yء0Äżć/…ވfŁ?đŔGš˛a 5Kżćž ěÄ[?đŔGá&oA=żć?%]9‡@?đŔHśFXčČżçő/Őě§?đŔH˝?*}&żđ˜ €Ą?đŔH,%}Š…żóôłíŸ?đŔH8[k8îżř<7Č´žX?đŔHRƒZűůĐżřS SÁÓ?đŔHp_á•ÇAżű;:ʼnĎpšś?đŔJCŢŤ„zż÷ý›ÎŠ?đŔJ ós5ފżö HçYůF?đŔIý näĹżőMď-H”?đŔIćŠL;Jżń‚˝ěI¨?đŔIڗźąĐżęŸŚ°?đŔIÇë$ĐYżâu^ýžS?đŔI˛NËËšż×ś{űţÁ?đŔI ĺú$‰ćżťa(WĹ?đŔI‚ [ŰTŠ?ŽP&š­•?đŔIbŰ<ĐWľ?Ëa<­ş]?đŔIIą ÄďR?ۀ¨Ź#´P?đŔI58˜Ö•.?ĺƒbœĚŠ?đŔInLL?ěL=W6K˘?đŔIm8'?ń$Ĺ>Çĺg?đŔHňÚ\<ô?ôöŐżíć?đŔH÷˛vdď?ů}áďň ?đŔIĄ¤‘KW?üE2łęŘ?đŔI8MgÍĹĺ?ýfžŐúœT?đŔIX9†ŘÎ@ĂĆŐŠM?đŔI\ßL)ů!@ŔŤjĄÉ€?đŔIił2BAÍ@Á~ÔS ?đŔIuáŕĂ@üňŽ&?đŔI‚™\}H‡@ @͗¨ňś?đŔIˆ—Só]@ Œ­­SM?đŔIXŤî.Ţ@&ËvÝ?đŔI˜ËđH@ YËťsR?đŔIš$?fć'@"×ăčü?đŔI˝n‰žď@?OĎ­á?đŔIÉ-@…8Ž@h”ŮżŻş?đŔIŘ0ňd•f@,‹/:Bý?đŔIóQZ ě@řĎĆVŸ?đŔJĚŘTŔ@Đ_¸]œç?đŔJ&xä>‡}@itE×N?đŔJAbÜ×ŇĄ@9ŤšDC?đŔJ^ ľ&J•@ü|‚ă?đŔJzhđÖZ@ÂxŚŕÓ??đŔJžüTŸ@á“S}?đŔJÁď€ Z@aĄn?Ź-?đŔJäpúĚjM@ë\ސ?đŔKţ4ĚÇé@ Ŕ‡ź?đŔKěҺی@ Tśüé#?đŔKÂĘĄK˝@jÉś2—h?đŔK7˛•5c]@Šśtdc?đŔK\Lť/c@ŢΏ…ţ?đŔK„ C%ŮŐ@đ’Tty?đŔKë‡Đ¸Ś@ŠG+˝ŢŢ?đŔK„Ą‹Ĺ L@nËŁ˜¤u?đŔK¤í‡œÄş@ˇ†v%ց?đŔKĘ$ÉvLĄ@äť´ťú?đŔKďţ¸“>ö@QNŢK2Ť?đŔL v#ܜ@USˆyĆs?đŔL/>]6Żš@§˝ŢHx.?đŔLS”bŽr6@Ó)$WĚ?đŔLzM‹ąňE@互VţĄ?đŔL”ÂËŤÜ@’Şüüű?đŔL•UZr†ž@I BT^?đŔL–#°ůąŢ@?OÇ/ýÂ?đŔL˛ćƒ]U@#zó&J?đŔLˁ,3°•@eԟeî?đŔLć2Hčtř@l í ˖?đŔMýŸÉ”@)FĘ˙t™?đŔM(ׅlĆ@uĎkxćŃ?đŔMJÔyěÓ\@3 ´nó‰?đŔMM 4öřT@ć ň ;Ä?đŔMA0Ęţ}@˙݆3?đŔM=w¤â† @'‰”bä?đŔMRţcĆ~ĺ@9´~Ľ?đŔMj3ČÁŘ@ůaXb?đŔM…'M67@Ć[ni‚Ć?đŔM˘ <\,@ = ÂżL?đŔMĘíö††›@ ‰Aˆ˙ů?đŔMĺş=ZĂđ@ ľ‰P¤ˇ]?đŔN…wČG^@!sż*áî?đŔN(Zˆ¸@!=žŢďţ?đŔNJ=ămH@!rX‡˝ç?đŔNqܓ¤…@!$E×l[`?đŔNÔ…šV^@ ěďF3Ă+?đŔNŔéÓĘ@!|çľĺ?đŔNŠˇíž}Ź@!3"ě&ž?đŔN“Č'yŹc@!Œ5’ţL?đŔN„̸/H@"+€űN}?đŔNmŞlŕ @"ŽœČáŮ\?đŔNxWŰӁ@#˙Łv?đŔN™Äu_@#/+’(?đŔN†0*ł@#WnŃęˇ?đŔN␉Ăi @#x•A÷2E?đŔOpsŹě™@#ť éř÷?đŔO%Á7(Á@#ľ~|„?đŔO=ŮŰ<ÍT@$6EÁpw„?đŔOižV÷)@$%RIřřÎ?đŔOWđP°-ß@$OóňËwŔ?đŔOtROkö0@$Í&†b…?đŔObEŹťyÉ@%¸*Ű.ă?đŔO<’¨,D@%Äf’j¨?đŔOăVX[@%UrTÝŁn?đŔO’ň4ňy@%fr:˜•?đŔOEô|#.Q@%wIÂÁŚč?đŔOjĘç)\¨@%rCÇd[?đŔO‘˝.‰ęĺ@%je 5žŞ?đŔOľ­ˆľX@%To=đŒ\?đŔOŢHbă{@%Qz\p÷č?đŔP GeÎż=@%8ś”ТÁ?đŔOîŐĄs0o@% č ÓŻo?đŔPyé@$é ‡ƒô?đŔP”U]@$šc÷e?đŔP$€a`ý @$xÇtÉ2U?đŔP2•DfM"@$Aj [>?đŔPG, v9{@$$=w•VŃ?đŔPY#ś6Žž@$F€áI0?đŔPoySUŐ7@${ÇŠZö?đŔP{<1*,@$Łu^<ĺ?đŔP†ďŻĆ—ň@%ĎŤ­ž?đŔP—Ą~­8@%@ ¤Ń?đŔPŞÉB‰FZ@%>‘_nęœ?đŔP˝ŒQC„ý@%5šœ]â‘?đŔPĐěĹJ—@%ÓW+D‰?đŔPâám‰BU@% í.k1Ÿ?đŔPö/FÍż@$ôý°+"ú?đŔQ —ƒÝ5@%ý;v~?đŔQů†DÖm@%„UĚhoo?đŔQ‡*ÉF—@%îČ8gq?đŔQ cčGJ@&q[DŸjî?đŔQ/č$ei.@&Ă$;ęUŹ?đŔQAűHë Đ@&ęůń-7?đŔQTE.˜Őň@'ƒŞĚ7?đŔQgťC‹í@'ćŔ͢?đŔQr?rŘ ń@'ĚńÁ0–?đŔQv™Ż†@(~— r?đŔQ„–˝ 6´@(NŔcú<?đŔQŁ.WPş@'揼Ęhn?đŔQŒ,ýíÓ @'`Ţ}ňĘ?đŔQuŞćŸŔž@'/éËz5?đŔQƒ)ťU6ß@&üČyOŞ?đŔQľľ’%@&ťH9ĘN?đŔQĄz(ňÍ@@&‡]$œÜ?đŔQ´†ßti1@&iKńNřQ?đŔQĹIŤž2š@&)zYÉXć?đŔQŮM:@%ĺČ A/?đŔQáiÎhßń@%sg)A L?đŔQÝÖם˧@$ŕ1žĆ_•?đŔQÔ9Q™@$`ے]z?đŔQɅ Ŕ—@#Ჸ1iŰ?đŔQĂŃ`¸ @#ZÍ7ÎÎ?đŔQĹŘ/TlŠ@"ż+§Pľc?đŔQŃâ"žy@"LH}ş(?đŔQ㞂ţÎ@"œ> °?đŔQđ:SZŻy@"oÎĽ•ä?đŔQ÷ĚJĂűů@"Üöżö&p?đŔQ˙}o *í@#*EC]Ł?đŔR“KOAo@#ÂJsR¨?đŔQúȨÄ|@$Düs›dó?đŔQďI˜qň;@$ť\ú ýö?đŔQćĂ7CĘn@%6œ'MŻ ?đŔQěFÔox¨@%ÜĚĄUp?đŔQńH™Xˇ@&:ŒP†K?đŔQű&ćF˛@&ľ4îÉ?đŔQř‡<.‚ˇ@'6Ę56ĽÇ?đŔQĺYîšMŰ@'dŽ_ś÷?đŔQŐś‹)Ťq@'¨ÂDXM-?đŔQÉëĆę*(@(#ł~ßü?đŔQҙŒÜ\@(Š˝ÝMŇ?đŔQčţóÁiĘ@(ŮĆŽš?đŔQř”*őŻ5@(,¸=c?đŔR…ˆzÓ@(bËcAlŹ?đŔR7gXŽA@'׾g˝2N?đŔR lH-Čł@'ŽžĘŰĽd?đŔR2q žČ@'Uâ5Žú?đŔRAm"pÖÜ@'­l“?đŔRP–ôęIŔ@&¨$H“™Q?đŔRbŢ.„ů@&‹OžÁÉ?đŔRuÄ|Žˆ@&”AŊF’?đŔRˆ5O‚í@&ĄHŽyS”?đŔRŢ̊_@&™ƒ;(ž?đŔRžtJw—a@%›4)}gŘ?đŔRœ×rMć@%Ýńc•"?đŔRđçבÖ@%ý˛ćż?đŔR°źpË t@&+šmžcă?đŔRżÎBĂ+@%ôĘń…ţ?đŔRÎŕˆd|@%Pœ‘ŻM?đŔRŢiÓĚ>@%Ęć´´Í?đŔRĺ¤KŠűš@$Ž‹:;™-?đŔRĺDWúZ—@$Löľë ‚@%˙ŻWŤž?đŔTöáś)˙ď@&‘HşŮˇŔ?đŔTďBśbgë@'ŐcdĹś?đŔTîž t:@'˜Đˇ!Uq?đŔTîťfqŚ@(°äŔÁ?đŔTë˝$ B@(œťÁ’Ţş?đŔTé*ĂC{6@)MÝՁOQ?đŔT查Юá@)™%ă¨?đŔTá;cڜ@(űťś<Ř?đŔTáďe†@) &ĺr 0?đŔT⿝”Ó@*1¸Ďú)?đŔTă‡Ú$u"@*Ĺ=zŚŻś?đŔTŕ4@+U<œך?đŔTÚîëÇ ă@+ä#Ły¤?đŔTЖ+ÜŘ@,_&ëç“?đŔTÍČcŽ2@,čaźőĐő?đŔTŐzÎě@-}ĺ¨?đŔTŃŚÁeůj@-ÁĄ÷TŃ?đŔTПdcÂÜ@.%Ćť'$?đŔTăúIöÜ@.ŠM“îƒ?đŔTöˆƒń]Ĺ@.™€ł0ˆ?đŔU4kwíÔ@.ćdz Ăó?đŔUk̀w@/GٌÇÜZ?đŔUě űŹŠ@/¨iA ť?đŔU%ĘđjňĄ@/§u›ŔŁ?đŔU86b*@/ęs”ÓN?đŔUJa¤˙L[@/Ů:źE÷K?đŔU]ŹřYT>@/ĚúMšsź?đŔUoJőŠ-ę@/ó‘â˘ěy?đŔU^ţCŚ×@/éŠ^,ÂM?đŔU“lş)é@/ŸC´˙Ńł?đŔUŚŔž Ÿ@/–GđE!É?đŔUš!§ˆKe@/‹‘'J?đŔUĚNcÁˆń@/ž)ögf?đŔUáB$i @/˛yó‚Č?đŔUóě*X–@/Ĺň˞l.?đŔVč—,”@/}°ăi{‚?đŔV‡N2,J@/’$cĎŢ@12ŽyvŐ?đŔVTű´D@1ěPšŠ?đŔV"Ô'°œ@1şKÓ;?đŔVéÍ*Œ@2 ”k~Ł?đŔV ĐřŤ‚@2R ­d=?đŔV‹w[ëd@2kÂźŻ?đŔV ^ć’§@2ťżÖő°h?đŔV_–Ťđ´@2—™ÄÚ?đŔUů*0h.,@2Rᢠ?đŔUňĐÓ)ć'@2]Ý8DŒ0?đŔUíÍ~ř_î@2Ś%ż>?đŔUç›N’Ú@2îüBšL×?đŔUäŘŽ5@3AťBnĹë?đŔUăgâľn@3ŠXˇČ^?đŔUŕëňƒ˜%@3ŇćÝdď?đŔUÝ>|"œ_@3ű}ş Î?đŔUŮ,Źí†/@4BV@茾?đŔUÎv˝_¨@4~ÔŰuŁŕ?đŔUŔ…ća@4ł'çWC?đŔUľą…ŔJ<@4ňT7šZ:?đŔU˛Ö]:(Ä@55~Ŕ Ń?đŔUşżÄ@5wœÎŚŁS?đŔUĎߚUř@5Š‡űh8?đŔUÜцh@5xłě¸ŃĎ?đŔUďi•“p@5†ĆĽ´ü?đŔV ”)ąĄ@5—ěSĄ?đŔV%›ŻJ@5BŚ™a?đŔV* ëo@5|ŕ8oĺŰ?đŔV<§á’–@5e+ĚV.L?đŔVP•ĐšO@5X…=Cde?đŔVcËŐ}š@5O-G3ő4?đŔVw42Wľ@5@lR­!P?đŔV‰ .Fę@5")ľ ­?đŔV—Ń~>ƒÂ@4ćä`m˜?đŔV#TŮß@4ŤE#>í?đŔVžÇ5šËČ@4a%fŒ n?đŔVžúžŇŠ@4~Kc—ä?đŔVĽ#ď @3׍eQü?đŔV­jwŻ˘p@3—Eé l?đŔV˛cĘę˘@3P7=ď*ą?đŔVŔó.'\@3‰Ą É?đŔVÖ]™yĘ@2ç4ĄŤđŹ?đŔVŇÚÜǑá@2˛i’.ßý?đŔVߊ ö@2}UüŃlĺ?đŔVőMüX3Ź@2|@‰`ţÚ?đŔVţMŽ˛eĚ@2žÖwîQ|?đŔW]ćąŘź@2Žô7ńTH?đŔW(–Ă4É@2äÂWéŠ?đŔW6RŮSţž@2}Ü‚Ö?đŔWHĐ"q˘@2hŔéĽLq?đŔWh"íYď¤@2bƒ´Ţ'`?đŔWp‹Ę@2Ms)÷c?đŔW^ŠŘˆ@2?˛|Čľ?đŔW”ě!NÇ@2+ƒ­XŻ ?đŔWĽvőaě@29Ó‚ţN?đŔW˛ó͛Ľ@2vœĆöÚŐ?đŔWÂÖŃːI@2™˛Węi?đŔWÔ%ĺ/‡@2ľ_k†T?đŔWé1›íD@2šĂĽ‡ĺO?đŔWöŕ- ÂP@2Ď{-@Aô?đŔXą¤á™%@3X~ş?đŔXP gě)@3N4= ů™?đŔXţŔŠ„´@3€űY?đŔXüHu•@3Ů3~˜ł@?đŔX(rs“fž@4™ąg?đŔX4ţمđ3@4NV…Š n?đŔXBţÍöä@4…–†ݧ?đŔXLnĂ?đŔXt;a;Ž@6ee jD?đŔXv) ă+V@6Ť9X˙ă?đŔXp˛Üd@6đ0Ź˘Zś?đŔXpŮžŞŠŁ@7B+‹˘?đŔXoŠ3¨›Ľ@7ŸÎĄÓtü?đŔXoávęż@7Ńô1ä/?đŔXmjĆJ-ü@8 Wž÷?đŔXjăR˜P@8jˆűKĚ?đŔXf“ţŚ˘@8ł ۧŁÇ?đŔXaśĂ 4w@8ű`­dŐ?đŔXZ1—šDÓ@9?˙Đô,˝?đŔXPŽ{•Ř5@9ôQŞš9?đŔXJˆ+O@9É •Amß?đŔXMŕíeS@: aĄŚď-?đŔXWXŕýťu@:Qˇ‚)Ŕ?đŔX\{>tvÖ@:źĄ|š?đŔXa˘†T@@:݃%L˙ť?đŔX^*ÍŒß @;Ú#1é?đŔXka~p‹e@;Q‡}Çٗ?đŔXbˇ`ʸ@;VkŐÚŐý?đŔXV5’ô’Ľ@;~­×lwl?đŔXXŠĂ ˝@;ĆîȎ*Ç?đŔXSJś}@;ŰS;Ž?đŔXG2ç÷“E@<P=&¸?đŔX;wƒŤŽ(@?đŔWťŰ¤I/Ś@=Tń!ô†)?đŔWż›Ü0č–@=•ŕ3 ?đŔWˇK–D``@=š 9ů_?đŔWŞ“NŠ“™@=”RaűH,?đŔWŞb[ĂŢ@=w7-ÔŽú?đŔWŠ ™áőń@=qÔwł8?đŔW•Őű‚Ž@=’GTę -?đŔW€śŐŒ˝@=Ź0Č"?đŔWy‹BčüD@=ޚOvŒÂ?đŔWry´#âY@=Î}łäÝ­?đŔWZŐ Q@=Ć~‹î*?đŔWEč.ŔąŤ@=Ŕ;§ďE?đŔW2e7!¤c@=Łxýłě?đŔWuGÔ}@=nź“ź?đŔWĺ.átB@=¨͉UŠ?đŔVůľXĐĂ@=ČŽ9°›?đŔVç°vÔ N@=Š^Qó?đŔVÖF˝ÎťJ@=ŠťJä׋?đŔVÍŮO ™ľ@=\×­´(?đŔVČkB_@=8㸊ą?đŔVľ žWÍű@=%îčô$ ?đŔV˘œąŸđ>@=BńGt0ŕ?đŔVD#B>@=0Œä`y?đŔV† űčR˜@=lUˇť1?đŔVt뭑dR@=gňr .Ś?đŔVcű‡ Y@=Cw¸Œ\?đŔVSŹëvS@=˙Őyˇ"W{lÚ?đŔV}âĎů\Ÿ@>ţ—•"?đŔV•ŸÍF@>ęlœLŰ?đŔVVeĚP@>Vos}…ş?đŔV{1[ˇĹ†@>F QĆ ý?đŔVgiÂŢH@>.Ał˜tOź:ĺX?đŔV=Š„ŕ@>eĹ~ůŕ­?đŔV+G“Řœ@>]ů †×?đŔVâ[&L@>]R3ŽG?đŔVę'@>Ž"O%áV?đŔUřQEë@>S q$Ť0?đŔUój#7h@><`ÝŠ?đŔUŢţ;wd@>YGˆuŃe?đŔUÍo!đ@>r)ÝLŠ}?đŔUÂw9Ę@>vÎ-lƒă?đŔU­Ô[Ý-@>jţd˘ˆR?đŔU”Ëä窢@>omśŘĆ?đŔU…Ś™kđ˝@>Mnąf‚?đŔUi{UÎ@>-9×X?đŔUašéˇýż@>y‹ ¤l?đŔTóŤ)ł@=űgŐŇ:b?đŔTävPHކ@=ČĎvöúŞ?đŔTŘ›„d,@=ŽŻŒ+…5?đŔTĘ:}c_@=TäÓ0ˆő?đŔTšz¨LŽ@=(¸°äOŒ?đŔTŹĺĎ*7B@<ňđ˝ˇáů?đŔTŠ\îđüc@<łü;$?đŔTŹ~ Šá@?đŔT}]IRń@:Ľ´ą˜)?đŔTzRźËĄ@:v(Â5M?đŔTsfúńŃĚ@:)߉¸šr?đŔTiŰwWÂ@9ď‘ýďeŢ?đŔTVĐA˘‰š@9ÇP.{•Ű?đŔTM!$Út@9ˆrĆđě{?đŔTD%/H‹@9B°}‚ÍE?đŔT7Đŕ?Ę@9&[ßnü?đŔT!íXŁŽŰ@94ŕüp+?đŔT5žŽÁN@9XBdmˇF?đŔT+!…Ĺ@9 Y>šáÉ?đŔTďœ4{ƒ@9܈#颠?đŔTQNÁ$ź@:)ŕĂ܏?đŔT‹Wk@:vžç’\?đŔT‡Ĺ‰ř›@:žŐˇžód?đŔTÔ]żă@;“šî4ű?đŔTřĐď´ä@;?N@še–?đŔT•tĘvv@;(—ůň`?đŔT욚)@;Ô> âRź?đŔT&~1ë@<(FT›˛?đŔT.Šƒ3l@<[çu?đŔT4 ě@<§ş5N5?đŔT.j.m3Ň@<§!PqŤĽ?đŔT&Şyăv@éIÖŇô?đŔTX×)˝ě@>PÉő°˜?đŔT]’nŔĆ@>—ÂĘŁůá?đŔT_&˝Sœ@>ńŇkŢÚ_?đŔTYČąŕ@?&;˛›6Š?đŔTSă휒@?j#o—°ő?đŔTLF•´Ö@?Şb–ş?đŔTA"–Xš@?ăoV’.?đŔT3͔h @@`樸-?đŔT2ču-ˆ§@@2r媄č?đŔT,bÍęwT@@0ü`7s‚?đŔT"2’>Ő@@6řW—?đŔTĺ‰3‘O@@E?šRá?đŔSü\Ę†Ř @@]]]xz€?đŔSëiđ´§u@@n„§ö%?đŔSŰbáŽ>@@…}›Âł}?đŔSθť @@˘˙öŹ°?đŔSĂmVŽÂ^@@ŔěLŹQ?đŔS´ćŮTÔĺ@@ÜЈ&˜?đŔS ţ–cw+@@đŚWx Š?đŔS‹´0nJš@@ó÷ťď‘g?đŔS{}ý’w@AŔźťo?đŔSpćhžžR@A#;Ą[Đů?đŔS^‡ÎU 3@A?č?đp?đŔSTqFî@AT(YŘ Ą?đŔS?oKďM[@A[Œ˘9ÂÝ?đŔS ;Śâ€@Ap ř_B?đŔS7tŽů8ë@A°Lv&Ü?đŔS,Ľ ÔK÷@A„k^׿?đŔS%aöTŢ@Ažíˇ%ćÝ?đŔS:ČD.@A¸{>‡q˛?đŔS8@6ؔ@Ať,.Ář_?đŔS šţ™ŕŔ@A¸~Ľ‡â?đŔS :¨ýd@A°řĆýr?đŔRř 4Ď@AȲΠ˘?đŔRń.óŽý@Aé4ý'3?đŔR˙AŠá6‚@AĺBůC?đŔSK…÷×@AîYa†Ś>?đŔSíBlŽ„@Aú°ôN?đŔS$ŞQü @BŃőIf#?đŔS+ţUbEŠ@B Ă48/K?đŔS(E ^|@B@9Ä?đŔRűźĘŽ-Č@B5ÚúÇ?đŔRůżFK§˝@B)űŮqÓ?đŔRţO×Ńˡ@BFŠł[ŇĘ?đŔRřB” ]@BEĺč&ŻŤ?đŔRňÄh°R@B"DŁß?;?đŔRčĄ9ß5:@Ař“rçyë?đŔRé şî8@BalɘI?đŔRńťœ<űě@B#Šěß?đŔR÷ Î }@BGVKľď?đŔR˙cx}@Bl4Pď0)?đŔSe”ŕ@BsŸÖja?đŔS(ĽÂŞe@BŠçœ;%N?đŔSCóÎů Ż@BŁ*ÍťO8?đŔS9ńę™@BĄíÂ÷ú?đŔSH´mˆ@BŒ ŸŚ#F?đŔS'7ۙ,@BŽr]N4?đŔSëL\ăw@BŤĹŚ{&?đŔSdŃ9HG@BżtG=ˆ4?đŔS#T%3R@BÖÍęđú?đŔS;Ę[xx@C!Çş7?đŔS1’)`ě@Bóő5Xç€?đŔSÇĘĆě@BŘżÝCş ?đŔS TDń@Bî#Ë Œ=?đŔS$ś;E7@C Żń¨‡?đŔS:ććęŕc@Ce{V˘?đŔSN\ŕŞA@C1€§„ą?đŔSG7óŮĚ*@C\ížÜÍ?đŔSIű°œđ@C@-űăĘ´?đŔS6Ńáҙ@C)Î8Dd?đŔS܄Gő*@C°´Á?đŔS"Œ˘l@C7…LÝę?đŔS [5Ó7Ý@CLůFéŽĚ?đŔS J ~Q@Cw`] ^Ú?đŔSydď~8@C’ąŔdW?đŔSɚZfQ@CŞ ,Kl?đŔR˙1!˛K@CÁ"NŐ?đŔRţ‘Ů@<@CąŤe6?đŔS @$(‰‰@C‘ s?đŔSťçـ@Cn@}Ö;%?đŔSZţU›”@CV÷Óżç>?đŔS ˘ąNóÎ@CAŃŕ3nń?đŔS7Pś>Y@C(€AŃv0?đŔRöľ–Ď{@CUŧ ?đŔRđ}ŀ@Bůœâ†Îö?đŔRôôn˙OŇ@BŮ"˙^?đŔRüDĽ!ńČ@B§Ćp0´ą?đŔRđvĹ\BN@BşžLĹ>?đŔRäŹMVŘm@BÓ#,ßčŹ?đŔRŰBŸ ô‰@Bő㞎Ü?đŔRĎŹ a~ę@COÎ3e?đŔRĹTÉb@C7ţ}đƒJ?đŔRÇßx;˛)@CVîstPP?đŔRÔșҏ@C|Šwt¸=?đŔRŰ:ÔÖŕ@C 1űQ&ą?đŔRä)—‚ g@CĂýGHź–?đŔRÚžI›*Œ@Cá™ĐqW ?đŔRĎ"›dœ@Cđ%ý=x[?đŔRŕrş˜Ŕ@CŔM˜áDÂ?đŔRĎř#Ţä@C˘ŰâPČ?đŔR¸ÍƒUý@Cˆ€˘´?đŔRĽÉë'@C˘ćVÄr}?đŔR˜ć—䤞@Cź0ťř†Ř?đŔR‡œE^Œ-@Cí_­Élƒ?đŔR‚Ě;żi:@Cú VŠ?đŔR~ý~Éu@DÍÉLť3?đŔR†œ@ta@D9†?ز[?đŔR‡’}'Œ@DVÂęâĽ?đŔR{]×Óů‚@DŒr‘/‚?đŔR| D ‹q@Dmh’nIĄ?đŔRsl’œ;@Do7% s—?đŔRa zś:@D…ĽX˙˛Œ?đŔRIżĎ­sě@D•ßĂJŘŹ?đŔR4=!Χ@D˘ řŸĎ?đŔRkQŹľ@DŚ$ĽĎ—?đŔR9Ďüřž@DŠ™"Óo?đŔQčpö5R@D­›Á&?đŔQŘ^˙żU@DÔobËš9?đŔQĆčV•ľ§@D͟ňĽŃ?đŔQ­"ő”@DŃÂDlż0?đŔQ•i?ĂK™@DϖÖŁ‚?đŔQ…Eü ş@DćSoĎ.Ú?đŔQƒ0“By@Dô)Śę[c?đŔQš4~ëÔi@DâĘRâ‰]?đŔQ¨°6Ků/@EšDŘć?đŔQť=hIŁ@E'ŕG[˝?đŔQŻ‚]Gť>@EKË]59?đŔQł,x%Q@Efpő;?đŔQŤ““AJž@EŒŠ‘R}š?đŔQí]>@EŻ ÉQ…?đŔQŹť ޲@EÍTžŹ ź?đŔQ|ýS=éb@EçÂA"é?đŔQt$Ô…“@Eó,;Œ3?đŔQižWP7”@EőÎ5$…?đŔQRÔŻ zy@FËÍn?đŔQC¨MŞ@FDÝŕ„?đŔQ8P׀Ý@F;) 5t?đŔQ,ąăK}@F0ÜÓú€Ą?đŔQ̤´t‹@Fř-3ţů?đŔP é3Jş@FëÁ5WÂď?đŔPě$H@Fá¤2Ž/4?đŔP1×΂˜€@Fˇ%Í; ?đŔP@^!@FąěŘ4?đŔPđ˛v @F˛,žj?Ŕ?đŔOĘŞ=Q@FŻžœnM?đŔOآŽďÍ^@F§]L\?đŔPéś=.-@FdɜVC?đŔP5ě~Hî@FœIř¤?đŔP,÷Rטm@F—]œĐb=?đŔPCŔ%&:@F…3–Ř q?đŔPb oď6@Fd§q!H?đŔPl#uÇŠÂ@FU#–×Ôt?đŔP`¨;„Ž@F@§pąĂ?đŔPˆýQ3ě@F *(ˇ•}?đŔPŠÄĂűo@Eý2ąš?đŔP,[eD@EâY爑ş?đŔPk—Qp@EČAŔ‰8D?đŔPU‘eGdÝ@EÓ†NĂ?đŔP@=Űâ@Eă”ćߍ?đŔP.ĘŰtz-@EüŚÜďˆî?đŔP[9řä?@FVŮV;…?đŔPŽ:#6R@F0Ĺ”†?đŔP ‚Ç`!@FIœ&ĄSë?đŔOćžc‘BĆ@F@öƒIÉ?đŔOÁ‚eú7/@FN™|¸ě?đŔOÔťTWD@F\—é…?đŔOXđÔńđ0@FdĚŽh…ő?đŔO/WK ą@FsNJÁ?đŔNú}˙CK@Fƒ<"e?đŔNĐRD|-@FŠ3m Ď?đŔN’⊏b˜@FŸÖ×3Í?đŔN§– yÇf@FłŽłŰą?đŔNÄĐaŁÉz@FŃYÔԂ?đŔNđ1řJo@FŕdbËv?đŔO âŽMĎ@Fä5vÝáq?đŔO=úŻ˙`@FÔ9Nžťď?đŔOaabcű@FŰŹŕtçď?đŔOĽ~l Ů@FäĐŇŠ–T?đŔOÔ@՗Ř@FîjÂ}6?đŔO÷˛Ĺ¸ý@GW{ˇĄ=?đŔP šţdŁ@GT‘ă§?đŔP%v<Łś˛@G)Éź“ˆ?đŔP0FśŽH@GQĂE.?đŔP7-5źżi@GpwĹťŃ?đŔPG%6í@G!Ż^ź@?đŔP:ţšÜ]@Głňœ§â?đŔP2Y>fŕZ@Gٓ*Ô`[?đŔPB~ôœ9ľ@GčŽÜë?đŔP_ŽĹd&[@GŮŔn˛?đŔPo4-\K@@GçÄđž;G?đŔP…—u¨Ž.@GúŁĆ–ű?đŔPĽŁđé7€@H˛iÂR?đŔP ăĹs@H Ă …Ű?đŔP…˛ Rśc@H[]ÉÖ?đŔPmŠřf7A@H I9v”?đŔPS1ą9•d@Hq”pZ?đŔP9ČŢŐݜ@Hň !Áz?đŔP%ˇě…ŰZ@H-ś])“?đŔPŢg—ž@HFˆT@ż?đŔPvŹo\@Hiš^ë?đŔP 5uĂŐ@Hˆ5ç,Â?đŔP9ł´G|“@H˜Ů&°yŐ?đŔPUˆöęĂ(@HŸˇod:?đŔPq}Čy@Hž 9áĘM?đŔP—Je:@H™Täł?đŔP¨tÜÁ@HŽf˝ł6?đŔPÁĺó‹ @H~Wyvé?đŔPÜ Ľb g@HpR°íâ0?đŔPő*ąâIT@H_ü¨JÜR?đŔQ'Ôxű@HOQëŇ}?đŔQ$Î~ŽM@H9ňSxŠ?đŔQ;ŸÜˇZ1@H%Ą–°‘?đŔQOÓĽ˛@H řÔ??đŔQbyuEřO@GđDěĝA?đŔQr(Ǐ@GŇąĺ{Z?đŔQƒbujżń@Gľşƒ†r?đŔQ“­Ĺ/Žý@G˜7|"áí?đŔQ§ńŽ0@G~dYGË?đŔQĆ­ Á`@Gj@ ąJ}?đŔQ•ňL@Gz^5ÚGŇ?đŔQ­@ÓÄ@G‘ž?N Ź?đŔQžUBěYç@G˛fĺzâ?đŔQŠú˝÷†/@G˓(>¤ ?đŔQyţ Ńi(@G阪w‰?đŔQtnéhŔ…@H vś<×?đŔQ‹Œ>ד@H"7˝Ô“?đŔQł“íĄú@H2rŕ’%?đŔQ¤ÇćYW>@H1míxfN?đŔQŠ({‘ @H&Ţ@â?đŔQo1č˛Öč@HŔ ˘/?đŔQXšč KR@H/ĽŮ°9?đŔQJXÎ{-@HO.]´’?đŔQ9E ™7Ý@Hk`ľ”lĂ?đŔQ œeKÄ@H‡ńÖꊠ?đŔQ ›ű-_É@H—Œ@NPh?đŔPó˙lŮé@HĽď˛žK?đŔP×huŔ@Ç@H°5áŽDŁ?đŔPĚňľ3Ç@HŇŹíě?đŔPÁ~>őe(@Hń–g_;—?đŔP§á"Ův@I„çsې?đŔP”]…dž¸@IĄ)??đŔPyúÁX›o@I!Ém5?đŔPZŹçÓżŐ@I%ŮOů'Ÿ?đŔP>?MžŠ@I$•“oą?đŔP äšĘŔŽ@I%‡í¤?đŔP ĹĚ…@I$śSôÉc?đŔOÎń7~3Z@I"‹>uě?đŔO—†“q÷š@I"3÷Q8?đŔO_6Zm@I%Ęgşî?đŔO(ŢĽŇ@I!“îÝÜ?đŔNâzŚŁuŹ@IBˇç&m?đŔNźH@UŤ‘@IŚL?đŔN~•RA„ĺ@I´Lfi’?đŔNIˆ(~&@I´żtW?đŔN†ŹŤöl@I ?ƒ.˘Ť?đŔMĺřĺAdU@I1őËäűˆ?đŔMš\Ďe? @IMžńăS9?đŔM‹­l†›@IfÄŽ>?đŔMpś’TD!@IƒÚžŻw?đŔMFŮ"ÁŤ@IŸy´”•?đŔMČ.áɋ@I¨łżšć?đŔLÓóîvs@I¸(ěŃa?đŔL›ˇř`@Işéˆ~?đŔLiE=^ó@IÂ<Ü[!Ţ?đŔL;DjĘů@IŰ~äëľ ?đŔL @‰ü  @IîˇR]˜?đŔKâTÂMú@Jq°óU?đŔKî":đȘ@J1V˜üś?đŔL ŕ3PóI@JFuU!•ć?đŔL{‰Ú@}@JNš€T˜?đŔKüćo3ß@JmfMńß?đŔKů†T3á@JˆÜąfeŻ?đŔKďÁt…@J§„ů˝h?đŔLcšäN@JĆĆčżu?đŔLLU-^|@Jڇ´0şó?đŔLĄ4V"›˙@JĘÁżZaW?đŔL•ŽůŇeĄ@Jçœ`c?đŔLŠ-ű<ž˙@K˛ś}iq?đŔLÖĘěĽÂ@Kh–XűC?đŔMŐ!ÄŤ`@KŸ—KH‚?đŔMÉ[,jW@K xTŽĂ[?đŔMŇނžE@K Ú73?đŔMRץU@Jý„w›o‚?đŔM€Đ,Ď€@Jĺ.OŸ2?đŔMŞů9°ÁÂ@JŃÔlš…’?đŔMçť&Ĺ@Jż&Ąˇ8$?đŔNô‚Ăx@J§Cs‚Ć?đŔNП!¸Ř@J°ônĎ?đŔNPPĆzX@JŘßBĐž?đŔN9˝DœŻ@JÓRĚý‹?đŔMć7cÍy@Jč.ńíK?đŔM¨ţ Ĺ@JńXĺšţ?đŔMZTjŞĺŽ@K ;ȑ?đŔMŸ6˜Â–@KłX–”ý?đŔM{!|ƒp@KżăNé?đŔM?żd.ţ@Kś|á?đŔM4Ůž§Ň@K+Š•O?đŔLĂ5”ŁH@K?é”t(?đŔLę°ęä•á@KY(EŤ?đŔM)cşŐŮ@KbU™%^?đŔMfF#A U@Kmľăq™‰?đŔM”SmîĹ@KŒ‰Q)ăö?đŔM؂§;@KsůĐÎľÍ?đŔMÇ}žŚ@KˆZ×ĺ¸7?đŔMäň¤ŢĺÜ@K™Gő_ÔÎ?đŔN*ż;Ԙ@K”ŃÂÁů?đŔN.!Č7ńÜ@K¸fHĆÜf?đŔNDšr%b@KŮMĄ22?đŔNzËŹ<Ş@Kꯒâ?đŔN­¤?zý`@LD@Í?đŔNáxS+E˛@L!Ěáďđ_?đŔNůÍĺhŹˇ@LBp`ŞQ?đŔO'Éł˘Š$@LcíhW?đŔONę)Ń@L[ †T6Œ?đŔNĺucä0€@L\(ŻEm?đŔNˇ>‹;k@L€ęň<ß?đŔN嗳#řĺ@LT“Gx?đŔO zČqT;@Lšérˆň{?đŔO#´l„}@L̓Ľ‚Ě?đŔOŽ*5L¸@Lńís].2?đŔOîĚ!1@MŽžB„˛Ž?đŔPhŠ•mT@MBĂ_ú?đŔP|[8&Óę@Mn'Lć˙2?đŔP~łŃj×@M@IŮ Š?đŔPÖä’@MLtFLô?đŔP›)Ű=!o@M_Ćh“°ď?đŔPł3˘WˆĆ@M>úyŹ*?đŔPϲŢ3ho@M+řÜC?đŔPéŚi+Ť@M !)Zfů?đŔPőWsegG@MłgUŁú?đŔPüŕ(uö@M:ŕQya?đŔQ t%Ń@M0ü‚řš?đŔQ'ŠĆé@M |ÓŽX´?đŔQCí NŒ@LńŞĘźęR?đŔQ4Č*~ő@LýVŞŇ?đŔQŞ|Ňâ˝@MJąÚŢ?đŔQ/‡0Ľ@M8ŘĎÍs?đŔQď×EEŃ@MYžrëŠö?đŔQ0ó~öËb@MqQ;ňĐŔ?đŔQSm‘áă@MnrÁ}?đŔQyWÇ蚊@M[Vťß_?đŔQrîíî°Ę@MszŠéÜ?đŔQ]•„‡4ƒ@M‚7ÔŰ F?đŔQ]­W˜V@MŁćĽ>hö?đŔQi$űî‡@MÇKuŔ¸˘?đŔQi_Âľ.@M끁Äé?đŔQ„ńͧJ @MűF{?˘Í?đŔQŻ~Ň0ŹÔ@N ™?đŔQ¨‰>`ü@Něd^?đŔQ…HŠˇ¤M@NćäéSĆ?đŔQl đ0Fo@NdŢhé ?đŔQp!čŒ*ň@N7› śöą?đŔQeëĚě‘@NYńë“lţ?đŔQ\—ýfxÁ@N{Sĺ'J?đŔQv'Ő*ëŔ@Nsœ+˛c?đŔQ•…=ą@N…u˝ĚoZ?đŔQšß’+3@N‹@KSćě?đŔQßo3hZť@N˜­Ŕ´čO?đŔQď>–Gů@N¸œ3Ţü8?đŔQţ猪rň@NŃoł*ôA?đŔRîŐCf7@Nëœ˙‡Œm?đŔR,óƈ@Nýô拁y?đŔRBŁB@1 @OÍ­łć ?đŔRaS¨ŚÚ@O2ôĆL´2?đŔRƒ,=ň@O/ÂHYÉ?đŔRŠ&=‹2@O˙ƒ H?đŔRËĘî߅@O#2Î_x?đŔRńD1u•&@O ĘďI‡?đŔSƒ–`„đ@O5ĎŹóąH?đŔS>m[˘@OCŽcŘ?đŔScN#rß{@OCďĄ|(?đŔSƒ‰‰¨˝e@O*š”ه¸?đŔSˆ7ČI’@OńÂŻÔ ?đŔS}BZŠß@NŕŐ<,Ń˙?đŔSiAęć@NŽ‰9€?đŔSoëëŮÖ?@Nœděôm?đŔS„Ěj(@N{¸ŕů p?đŔSsţŒ|ş@Nc‡Óřß?đŔSh ;Ś’í@N@îbŁ"Œ?đŔSb¸™FcŻ@NŠş…Ÿ'?đŔSUĎú~Ľë@MýÄBpŔž?đŔSaÜáŕÜ @MÖQŠ‘ź?đŔSrř‘/ßŰ@M¸Ę5Âoä?đŔSËďZf@M,ŢC‹ů?đŔS–‰4ó3j@M}ţ ŢŹ*?đŔSĄ[Ů2(@M^ŐŽ˝ł˜?đŔS•ZLˆÝ@MFĆ,K'ü?đŔSygď@@M-Žpuň•?đŔS\ŔŻŽ‘A@MŽÁߍ?đŔSF 'ąË@LúZ9Xju?đŔS6ŠtœJ^@LكBˇŢt?đŔS+ĚgŻR@Lś•˝š{?đŔS#ŕď|„<@L’@ÁŽü˙?đŔS!wč˝ ƒ@Lm*ť~j?đŔS![TDŞ@LH( §>Ż?đŔS$!qŢÔr@L#_ž;F?đŔS/˘k3V@LŮ*>‚Š?đŔSDĘŇ+C­@Kßn‹şpœ?đŔSUH \­@KÄnJXhP?đŔSma“U@KŞgč?đŔS†”J!‡t@K“gť#’Í?đŔSĄMşÁ@KdPŢę?đŔSžř‹c@KnČhwOç?đŔSä9’w$N@KZ~lΑ?đŔSâX ńł@KAeĂs ?đŔSŇvß{O=@KH.€5?đŔSĆ=y Ź@Kę1~YC?đŔSÁî dę@JÝŰzź7[?đŔSŔ/ťcąô@J˝*8×?đŔSťŁ,Âşd@J“+š˛|˜?đŔSł„bwĘ@Jp˘mIŚ´?đŔSŹë…‹ů@JL“QFC?đŔS q‚Ďť@J(‘ˇE ç?đŔSŠśC§˘đ@J_=l˙€?đŔSşčlŤťČ@Ię Ťú Ä?đŔSˇŠpl@I˛Ä>„?đŔSĘ xĘc@IĂLq{T]?đŔSÝÁÜí!@IÇÍůí‘q?đŔSěh|ŢŠ@I§îBUiŕ?đŔSߨح@ItL@^ž?đŔS銥)G@I„˝­Ş%ň?đŔSţüě̈@Iç„ůld?đŔTHđßg@IĽâŞâVÝ?đŔT6yÂI5_@I‹’ć? V?đŔT5š DËó@I’p^==°?đŔT Z˙\w?@I°p|Íé?đŔT%~?­ř‹@IÔxPTyx?đŔT6ÜěUř@Ińň=ŇQc?đŔTLśzJÂ^@JAEÎ~?đŔTkĄ=)Őw@Jě‚C’T?đŔTgQoŽÓˆ@J-Ä˝Šľ}?đŔTvOv•íÚ@JRˆĘşvU?đŔTˆ…GŠ:@JpÍŻů?đŔTX ś-^@J’ wôš7?đŔT‰žÉb@JłÜq Źu?đŔT‹%ĺAŔ×@JŘ cÔ`?đŔTŒôźşÁU@Jü}/‰Űí?đŔT™˝s@$@K%Šçţ?đŔT–btúůR@KBžŕ‘BI?đŔT2;Ën@Khˆ°Ř?đŔT— ôD @KŒşžş˙?đŔT¸xRŽ@K•ÖžÜâÖ?đŔTŢGě6LŚ@KœĂšř|?đŔTď't*@KŸ´čŮ­¤?đŔU‰sĘ!@K¤ňÜuĎ?đŔU/Ő›ďo@KĄˆłijF?đŔUR]ה@K‘ągÁ‰Ő?đŔUO*Ě?eŢ@KŁ@)°ŽO?đŔUa…|Ě°z@KŔÉç+@?đŔU{sŠz@KÖOđĹÍ?đŔUšąmd@KăĆÜ ž?đŔU¸¤˝U‚V@Kňôů–ů?đŔUÚđu +Ž@K˙gź?đŔUí@Nˆ„Eć?đŔWŠ•tć @N>MŒ=Wń?đŔWšbŠ üŰ@N^÷Î@OÜG•Ĺ?đŔVÂCŁ}ź3@OÍČw„C?đŔVœę#čúZ@OŇ`‹ta?đŔVƒÁ˝“<@OňˇE€ M?đŔVzŻžcEŽ@P!şĹ?đŔV[$+Ń.@PĚ;šąÉ?đŔV8 >&úH@PZB5Ąá?đŔVŐćžň@Pˇß:a?đŔUűű2p@@PQ›Z^?đŔUč.|BŐ@P%2ńZ; ?đŔUԃČá‹@P3¤§8J?đŔUÁ3CE Ć@PFFl8ă?đŔUÜ ‚ąśo@PQERďz!?đŔVq%nŔ@PQš˛c*?đŔV3•rJ@PTOĤł?đŔVTjœ°W@P_é;s?đŔVoŠŸśo@PmačĽD?đŔV–ś>•Ž @PvszŒ¸†?đŔVČś)\%ű@PxşSyŸ?đŔVÁ§Ě˝Šů@P{äĽĹAÚ?đŔVˆűÔĆö@PxÄöxş?đŔVgu ß@PyŹs]˛ů?đŔV4㝲Ę@Pl˙îٓ?đŔV!-é(@Pc•qęFg?đŔU˙ŮĐ/ú‡@PW+ă?đŔUŃłÂëć@PWâ 0Ä ?đŔU´~ÝdÉF@PeĽ>ß?đŔU›Œ%Š×˙@PtŻćę#?đŔUúYi|Ł@P…śőź|?đŔUĄ­nśOŘ@P›>ęŇç?đŔUs8ÍT y@PĄë*Ď%?đŔURÎJ5ń<@P˜Ź^]p?đŔU'ôśŒ’Ą@P‘błžé"?đŔUăĚHAš@PY4ý.ż?đŔTó˝o+"@P“á˜ZÄZ?đŔU fv]Źh@PŚuńú?đŔU/Ξ%]@Pşx~dF”?đŔUɲöŻ)@P´tn†G?đŔTűşk@PŤšÉÓÂ?đŔTĺ¤{ŻÁ@P›!éŇś?đŔTÂß΃t÷@PŸƒš8Ů?đŔTœ~Âăäá@PŠć¸Ćí?đŔTƒź§1\ë@Pˇâ÷Š?đŔTb,§ą¨ě@PĂc‰ďŁń?đŔTSˆgEž„@PÖۑ¨“Ë?đŔT_5˝ąT›@P灑dv?đŔT|çDë@PöXëp?đŔT‰9eŹú@QźYľś}?đŔTžćĺ|rĂ@QgB÷:y?đŔTŠŸ'#@Qží§łD?đŔT_)$-eh@Q% ×}?đŔTh1qEN\@Q7U {qŮ?đŔT]u“é”H@QFœđ4w`?đŔTˆ™ŃĹ,Ů@QSgLGý?đŔT¸o˛O8w@Q_č×y˜?đŔT§l3“÷@QdxÔ(-?đŔTŹČńrŔü@QkLš78;?đŔTázHN@Qlä2nY?đŔU>ôń@QtşË݅Š?đŔUOÇRÎφ@Qs認ćŽ?đŔU^šfW–T@Qg?u›?đŔU[‚3dŻť@QVotA?đŔU;Őx4&c@QDş¸÷†%?đŔUF‚Lé\@Q4`ŞŮ‰ź?đŔUj  …Vě@Q)Ń Đo?đŔUqc­á\–@Q‡dśv?đŔU~Śœň @Qâ|ÚŹ?đŔU–.O|@Pôl7†Ţ[?đŔUŁ2 w˜I@PݖYź˙?đŔUÍ& Uh4@Pρ`‰´?đŔUč|‘@PŰ S>?đŔVĎŮ[Ÿ~@PęX[5Š?đŔV—UԌŚ@PűÚřÜm‹?đŔV Ž úÖí@Qăůł[?đŔUő¨uÖ÷{@Qlř?đŔUţMNœź@Q.6ň+i´?đŔVÉý(y:@Q=ż^˛“?đŔVCmŠe8@QL Č^Ď?đŔVhnúť´˝@QB6ZčŤ?đŔVpƒEV@Q. ›žs?đŔVˆ˘€Q@QÉՔ?đŔVĄŔˇ#5ß@Q"š tʟ?đŔV Řo†X@Q5tA u?đŔVŔŃűÖs@QN÷ŏ?đŔVŚ=“CőP@QZY/fDs?đŔVČÉť°y@@QckaŢř?đŔV쓇I„@Qd„§ x?đŔW Հ… Z@QjŮ^F`Ě?đŔWüpj’@Qvt|ëw?đŔWÜ Áś@Q‹3–0ůú?đŔW0ŁťÝv@Qš5ې:ň?đŔWrď˜]@QŠ}2źÜÓ?đŔW:lŃ|2@Qš.jřâ#?đŔW:p˘×ţÖ@Qͧ[ Č?đŔWRĺːÖ@QÝŔé ¤?đŔW€’GđF@QíÉÚ, b?đŔWŸ×#Š¸€@QöOÂý?đŔWżZ}i@Qř1.tV?đŔWč lŁ‡O@QćĂ㏹f?đŔWî ĺ1˝ö@Q×Ë$Œdň?đŔXGÂi{@QĚP˜ž,?đŔX!ŘŁLĚî@Qź=v ?đŔX<˘Śě@Q¨EU Ţş?đŔX­lś‰@Q™Ď8•?đŔXw°vQj@Q‡8ňšŒÎ?đŔW˙ĂĂöp@Quؖş<ě?đŔWÖ­ëâ @Qk°*=˘?đŔWŠ™¨˘+‰@Qe÷™Ż°ć?đŔWszÖż$Ô@Q^/3*šŔ?đŔWduz Ě@QS˛m2Ő?đŔWp,şŇ˜@QSJ›Š?đŔW|W†ij$@QWG:}\÷?đŔW­.K̤@QHÉ֝>A?đŔWĄźrírz@Q7Yaęš?đŔWyĚb†jh@Q9ŐLu{?đŔWfś2 Xy@Q)ăǎ{?đŔW€”¤9Ć,@Q˛„•?đŔW›řxVż@Q Ÿ›˛?đŔWÉ)_úF–@Q˜ŞňĎ?đŔWă/<"bź@P÷›‚“áV?đŔWŢŞ‰Žm@Pç1pLČ?đŔWŇŇ_&@PÔíڎ-Ľ?đŔWÓĚ_ @PÁźŘNă‹?đŔWîiţ˜+@PťŘĹPv?đŔWó|<Ďń@PŽ6×KbŁ?đŔX;-<'@PźŞ*ČĽ?đŔWŢjj6—Ü@PĂf,Ááż?đŔWôš[´ąß@Pщ@aäÇ?đŔXQbH@Pá?Ň7î ?đŔX 7G\S”@Pń:/•%”?đŔX •ť´@Q Ś4—äŠ?đŔX!5&m4@Q¨‹GB?đŔX, ZËé1@QCP6‚0?đŔXcţžű|@Qü!4?đŔXŠ¸Ö:&Œ@QɔŔ?đŔX Kœç;@Q&ţŞW°?đŔXˆ—Ú}@PüaůN¨˝?đŔXbőĆä!@PüDŰ°ćŇ?đŔXP;˘¤‘@Pěk8"Ň?đŔX{y_¤˝D@Pî§Îw?đŔXœÜqújĘ@P˙œXŔQŐ?đŔXĽÚ\ëŸx@Pö"¤ÂD?đŔXĚď'WÓś@Pď˘oJ“w?đŔXűĹ|*Ж@PôUœßE ?đŔY1RœMŻ“@PókÔćó"?đŔY]2ř}Ÿ§@Pî)śůć?đŔYŒ?FˆÍ@PďéœN ?đŔYşŹJ§üç@PřeHŽi”?đŔYáŞí Ž@QW–$•?đŔZÇŇzň\@Qđŕq?đŔZ:QIh+@Qu˝:0c?đŔZZoúŠîW@Q¨Žň‚y?đŔZe6ƒbńc@Q/Ňw´,n?đŔZŒ™D˝7_@Q9^†–7?đŔZťĐ Oc@Q1ęďŎ?đŔZꋌ‰LŸ@Q*Ž–.—?đŔ[ӃóLŇ@Q##1ú{ű?đŔ[łuÓ"@Qöh"fC?đŔZó1uÍ|@Qه÷­Ů?đŔZĆhúEˆ@QC=páß?đŔZŒÎ}ĹGo@QŐ˛ŤAá?đŔZ”Ďë \@Q `‹ť?đŔZąşţ™O”@Q l‡ëéË?đŔZěQaČ´@Qážęü?đŔZúó#˝ąy@PńĽV.?đŔZęŸLJćş@PÝĆ] >?đŔZŮý_í@PĘâ֨ޒ?đŔZŢË"ř'Ď@Pť8äĚÍ?đŔZޏ=AĐ@P˘ňfĆď?đŔZđ â7UL@PŠůÂÝ4?đŔ[p­nŮ@Pžă˝÷ě?đŔZţţAî.@PČąžÄ˛}?đŔ["1şˇŻ@PÝ@QpŘN˘‡?đŔ^–’R“@Qsžíor]?đŔ^ÁŽĄb.˘@QoYŻ BŢ?đŔ^Ř^‡ÖŸ÷@Q]GłEŁ?đŔ_ ‰ &v@QZ6r0„Ë?đŔ_Ń9!ßÉ@QnyLk•Á?đŔ_—I~@Q[,Ę ?đŔ_3˝K˜f‹@QŮ‘Ěݝ?đŔ_Em Ď˜‘@QpFƒÉđK?đŔ_W=ąÝég@Q]m‘ ;@Qp“8T6?đŔ`’Y#b`@Qk%ĺÖX~?đŔ`Ľ QŰÔF@Q]LEͲQ?đŔ`ťČÔ# @QTDÝŞeä?đŔ`Î3‚”}§@QEű‘'Ŕ?đŔ`ĚHŮď|7@Q3B›R§¤?đŔ`Ôŕ;Ţ&@Q4úüj?đŔ`ëś­‘ƒA@Q3@­ƒű?đŔa—FQŸ€@Q6¸şT#™?đŔaŠ'Ň&2@Q:7Áô´;?đŔa1#)ÓĚŹ@QA=Ř\i×?đŔaJ ÔřŚx@QN-ÉyĆ\?đŔaZڄâuň@QWzôĽf?đŔapŹ§^@Qcł^šĐ?đŔa‡čăŽô@QfŮŇĆLb?đŔaŁz˛ł@Qi˘ęŢF•?đŔašbN:ď@Qq†;6˙s?đŔaέ’xN‚@Q|/˙ŔˇM?đŔaç%A^(@Q…p°˜ß?đŔb‚Đ–ą7@QƒÔ‘ ?đŔbœ‘Ž @QQuż˝?đŔb2bQŸď@Q…tI~Ž?đŔbLxŸŢ:Č@Q‹sËâJ?đŔbfߣ÷şô@Q‹ËŹięÔ?đŔb€Šřâ‹5@Q“M~Ţ?đŔb˜ąŠźÔ@Q™ű Cd^?đŔb˛×ł&÷@Q  Ăa%§?đŔbÎόÜL@QŰCRţÎ?đŔbčĚÚś1Ľ@Q›hlCŠ?đŔcOě: +@Q˘îŞąT ?đŔc<ęčŒ÷@Qł´fë?đŔc)TËĽ_@Qš¤ţŠŔ?đŔcFO‰0ŮÖ@QľĹ’?đŔc^łÖLK9@QÂ"ÉĽF?đŔcw˝}üŹ@Qˇj#óˆt?đŔc{8ő׼@QĂseí܍?đŔczëńq\@QÓ§Žżiż?đŔc˘ž“)ěý@QĘŹW÷?đŔcłéB™Ş0@Qťťĺëtb?đŔcÍ)Ď.?ˇ@Q´J§3¨÷?đŔcčQ|w@Qł%Ĺyô?đŔcřĂlńŰď@QŚuŚŻŽä?đŔcřN:”;@Q—óDLh?đŔd+7ŐËľ@Q´'2^’?đŔddç*\˜@Q˜GśOĆÝ?đŔd8śĚďg@QŽÁ*čS4?đŔdG™UŃÍq@Q‰zfSŃy?đŔdU$„¨şÜ@QzT8Ÿ*Q?đŔd`çžiĹ@Qj,Çą…Ŕ?đŔdfl t›’@QW§Ł„ţ?đŔdsŮSŐ5@QHLű˘?đŔd‡ň%ŒOń@Q<ćcţľq?đŔdĄBa /?@Q8¤%˙öĎ?đŔdťƒœňĎ@Q7ŹZ#?đŔdĆÎéWä›@Q-óQPťŒ?đŔdĐgćÔćĚ@QB_8?đŔdĘC,ˆě@Q8ńáÝ?đŔdśĐâA0™@Q t9%Ž?đŔd˘ ú"­w@Pűö~iz?đŔd’Fuaƒy@Pđh짞?đŔd€^Iđ@PáŽâ"ţ?đŔdy(&éúq@PĎľ#}çŸ?đŔdk0ňődK@PÄyľ¤?đŔdQQpŮ@PĂvgys“?đŔd9~˛C‚@P˝Í>SŐń?đŔd6l„Gŕ@P¨ěđÇŘż?đŔd$)ĆO˘a@P§Đœú$?đŔd őƐYp@PŁ-?Öťá?đŔdxrv'O@Pš6ŤĎż ?đŔd/ u @PŸ^ÁrŽř?đŔdHĺV\Ў@P˛÷8?đŔdC D g@P¨†ß^ĎK?đŔd.VS’@P“%ƒÂ?đŔd:„đčŹV?đŔdÓŞ^Kđź@P>ăO†Ň´?đŔdÍącśŽí@P18A9 ?đŔdŔeŕBDŽ@P$ažľ˙W?đŔdŤ`˘&ý@P°jD¸î?đŔd™RjlœĆ@P“š@!?đŔd…eí†$@P$ż™x?đŔdi‹g<ť@P"tŤęěź?đŔd[Çqä{Y@PJ|ŒŽ?đŔdPi ŸŮŃ@P!T&slČ?đŔd>Cş§K@P.śu-?đŔd)ˇpœŠ@P6ˁ´}ž?đŔdżB7Čů@P0(qŸ?đŔd( rćr@PmŐם?đŔd œLđ—@P:bš!?đŔdH?+ˆ@OúŤ#ţç?đŔdvWÔs@O׺D.â?đŔd+U&a P@Ož#!š”ŕ?đŔdBqę°ç@OźâR<ž?đŔdP2˛Ż§~@OŤŢV\¸Ł?đŔd]á]­G@OÝÔ0ˇ?đŔdrÎŃ"Š@O‰ü ̝§?đŔdMćՊ@Ožšäľś?đŔdx¨ źv@O‰˝Wlš˘?đŔd˜vůĂM@OaŘOě{ę?đŔd–ćs-źX@O@ŁęűG?đŔdŚľç*i@O9ćqĎä5?đŔd˛!C07‹@O:­řP?đŔdˇăżăja@NóO(PXë?đŔdÁ0WÖ:@NŘ3,çŒ?đŔd˝ůź…Ë@Nź÷ć%OĚ?đŔd˛<đižĄ@N–íƒŚě?đŔdŠ˜J˜#@N¤¸!؂q?đŔdSĹkí@NĂVąd!’?đŔdL—¤ĘŻ@NżG€Ż˝?đŔdŚ3-™˝@Nžv•ŸQ{?đŔdŸk}ůă"@NƒYŤő?đŔdÇ°‚ę@Npěňˆ( ?đŔdyö%Íđâ@NuçĘ„?đŔdtÂŻăŐ-@N`ŔЉ?đŔd„ÖlŘe†@NWdĆ Ç?đŔd–Ŕ8A>f@Nn)Š\ă(?đŔdĽ…ŒëAP@NOŐÍÇS(?đŔd &@šŐ@N4Îm‡?đŔd’…‰fY@Nj<Ű&é?đŔd†ů˜(&@Műż%ÚHę?đŔdyŠçĚ+@Mçxšn´?đŔdga'>á@Mě;ąäÚ?đŔdVwÂ[bŠ@MüLö—yý?đŔdQ¤ŕÝÍŤ@N xĹČL?đŔdFîđÝB@NI-fő?đŔdJ˝Ml€@N3˛ ‰§wJ´#@MŹL͝ËW?đŔd;F…é@M¤ ŃÓ?đŔd8* Ž´‹@M„ęť?đŔd;‡Ś3§(@MW<qL\?đŔd/˘’dą‚@MQɟĽ”+?đŔd#}¨I2@MhÁ7š6,?đŔdl(cľ@M}œjŸ!>?đŔc˙Änał@Mnç2Ž¤?đŔcńőZoş%@MlřŢeî;?đŔcßé˛*ďÔ@MAťř%?đŔcŮö‡Ko@Mj‚ ’5‡?đŔcĘ jńň@MúJL@ť?đŔcÍËůHL”@Myç ['đ?đŔcɧţ*@MWz‡Đ ?đŔcş­4G@MY™&Cß?đŔcŞ gş[@MjO?đŔcxE)]Ă@Mƒ€É퍈?đŔcœ´#1™@M€““\&Ă?đŔc˘p.@–@M^9 ĚDË?đŔc­Ĺ*č#°@M@5ťs^„?đŔcŹÔ7ń|@Mő>W?đŔc´/5"Ç÷@LřŽć ÷Č?đŔc˛Ú…Ń@LĚibźnÂ?đŔcłŢň=yC@LÁ‹M?đŔcϒÚÚ'‡@L—Â÷4‡?đŔcŮîÇiž@LmpV‹*&?đŔcĺôŹÄé‡@L^IËúœ?đŔcňÝ%Ţ@LMďvA~Ž?đŔd>k$ŔĄ@L8Ü*‰?đŔd KsÉnă@LŘ 4hH?đŔd *ĺ@KňÇeŻ-œ?đŔdQČ´çƒ@KčĐ#lhI?đŔd$Ü ˝¨@KüĐřŒq@Kἁ~Ő?đŔdOtTĚ5@KÁL¸ˇÓI?đŔdV˜˙oô÷@K¨b–+E?đŔdb˛Žj“%@K—KX' ?đŔdiü=¨Ď'@Kxţ s×÷?đŔdd5@ţqĹ@K*bí‹?đŔdSŠ—Ť1C@KŒŽY|?đŔdE‰Ű$ÇU@K‹§bžÚ?đŔd<ˆrMeđ@KĄć°ĽÄ?đŔd3˙ǐZß@KĆ-•0 ?đŔd*•œW9w@Kź›KĄń—?đŔd=›Tťŕ@KžÂ#gE?đŔdk¤ł…Y@Kʌ˝6ßż?đŔdF›ј@Ká"”ˆ?đŔcőĂŤ*Ń@KŘ|nřĂ?đŔcđôÜ'Dő@Kŕœńďź?đŔcć¨÷´­@Kńď…6‰ż?đŔcÔ. #6“@L2ąD˘?đŔcĚ,ÚŚé@L ŃWń?đŔcËŠäKŤ@L7EĐy?đŔcž9$SƒG@LHmÖď?đŔcŻTÂąÍ@L]îo'T?đŔc îáˇ}@LpígŔ´?đŔc“ü…ÄĄk@L„]čą?đŔc‘ZŮ:@LŁmŐ?đŔc‚ˆQY–ň@Lż4ÓŚě?đŔcvŽöŲ@LŇK<2?đŔci@Pó ¸@Lčh•ŢO?đŔc[p˙ťţ@MF¸^ží?đŔcM"ďo™í@Ma€ă-?đŔcEĐC¤ŢĐ@M)x7?Ž?đŔc;š Óé @MHŽüuÔ?đŔc,š‰d0@Me¸ý¸+ĺ?đŔc1(Ď´ć@MŞŇoR¤?đŔcC´ťOŻ9@MĐ~ľÍ?đŔc=í‰.D.@M´‚ŽŤ$/?đŔc0ĺĺ¤ô’@MÓÝۊ/ ?đŔc$•˘–ó@MââşÄˆë?đŔcľlŐŒ@Mů[Ôüu?đŔc$ĎëóG@N ć`î?đŔcXíůŮ@N" @çÜé?đŔcM‡ČĽ@N>OŠŘy?đŔbű´Çó @N^?0ęéN?đŔbň(p.Ë@N{Îwçņ?đŔbâ71qu@N¸ú}BŐ?đŔbŃU†ňŚ_@N¤1X;R€?đŔbľżš"ý–@Nłź›ćđ?đŔb˝>â¸@NžűřJŚu?đŔbŹč@Ó @Nyüş0UĽ?đŔbş2Ë]Θ@Nxžˇh6ů?đŔbĚç4Sg@N}áÔáŠ3?đŔbŢ7łlÁ@Nlƒ›Ňä?đŔbę‡C–ny@NTr÷ăß?đŔ`÷ö+ëÚň@M:¸@ë°O?đŔ`éô€*@M&q™jř9?đŔ`âă˛(ÁÖ@M1ď}ŞC¤?đŔ`ćŇUf‚@MVúęßPŘ?đŔ`쳎ËW'@M‰–šPƒž?đŔ`ěĘY~@M§ż&–pő?đŔ`ę%qňŁ‘@MŸűZőGÄ?đŔ`ĺ‰EËŻ@M{ĆźŃé?đŔ`ßA'ŇÝR@M\ƒ°Us?đŔ`×VDŇ?@M6ˇąC,?đŔ`€(š‰@M/ŒÉ˛,?đŔ`źüôÎň@Mm5‚‚^?đŔ`ą¤Ţë•Ü@LóDć$ž˜Y‹›@KŐŃuäTĐ?đŔ`yđ Ą˙č@KĺĐÍ÷MB?đŔ`h~B•č‹@L#çŸP­?đŔ``ž†Î3ú@KęöSĹťę?đŔ`\÷—ƒ@KÉJEƒŻ?đŔ`X‚ţóƒ@Kž…†cÁ ?đŔ`ZšŠTWd@K‰ĺŻěúŕ?đŔ`X,9”A@KlTcL1?đŔ`Kł{ŹŒj@Kv–W?đŔ`C­'ču1@K—/?J56?đŔ`B‘ĽČŽ@K¸fö)•?đŔ`Bţ:…Ý@KŰ؅S”?đŔ`BŰ0†bÁ@KĺR?đŔ`@Ć`}`@KˇÉáGé?đŔ`B•,/‡’@KČĆŔŽ?đŔ`>4GĘ:î@K’z)=˙?đŔ`9ËŤLbH@Kş0Ł;‹?đŔ`5NYŠ@KśnŒłť˙?đŔ`:ôýœ{@Kˆt‡~ˇł?đŔ`@C Žč÷@Kuy4D?đŔ`Dxuéĺ@KU=@čŃX?đŔ`B|çZ٧@K8Ÿ#ÓĹM?đŔ`J÷~„Ţ@K=ËaÖ˙ô?đŔ`H]ż„d@K$|^  ?đŔ`7Dcô@KŒ#Îo?đŔ`:ҢßLÓ@K MäÂHk?đŔ`AHĆ×´@Júŕjz°?đŔ`9QŁv@Jܢúgś×?đŔ`-ŠĽ‡Yâ@JźÁ=F†˙?đŔ`&_cČ6@JĎmüŕ?đŔ`¸Ć8žÁ@Jď1dč÷š?đŔ`.˜rÔ@JčÜ +{ą?đŔ`ÂyÖl‹@JĂüń2G?đŔ`|‰rN@J°Âć.>I?đŔ` ’ŒÖÂ@J´ˆš§?đŔ`/Ęm@JŔÍś‰Ü?đŔ`žŔŰP@Jłw\Ž\l?đŔ` ľCe@J“Ľ@‹čŠ?đŔ`Řd†jç@Jp$ůćK­?đŔ`ŒoX{@J_)´‡T@Rę}ąs…WŔQdu˛=Ţ?đ@RĂ7_˛šrŔQiHV­˘s?đ@R—ĹGDŸmŔQo°*˓ĺ?đ@Rfn§c@¸ŔQw4v˘R4?đ@R< Đ%bŔQ‚xC ťf?đ@R0 \$”ƒŔQ”hs‰h¨?đ@R ŤÜ`TôŔQŁ˛A{?đ@QříÚőłĘŔQ°Ą\|ˆŮ?đ@Qß ‰>ÝŔQÂ;ž).?đ@QÓŢŠV´¤ŔQÔŕćb}2?đ@QĐ4TQ~ŔQćĚ˝ŕz?đ@QˇëĽ;őŸŔQřW5rá?đ@Q‹]ś/ŹšŔRŃáúšu?đ@QdąŤÚźäŔR’, Up?đ@Q-Ť<şoĹŔR¤â<Ćß?đ@PöŞ$´ó°ŔR“ŮĹ?đ@PŢt™(ŻńŔRmđŢŕW?đ@PďKéć3ĐŔQěœ\|ş´?đ@PöŚh'§(ŔQÝĂwTE?đ@Q]yä&ĂŔQÎż˛Ú7Ě?đ@Q;ŕo(ĽżŔQŔä ”œ?đ@QLŘÝ;gŔQŻV)˛ľ?đ@QKŮÍf€{ŔQ›ň"×#?đ@Q$’„ß7žŔQŚóé^?đ@QÝâö ŔQžTú*:‹?đ@Pî׃čŔQwRJľ?đ@Q.CÜłĎŔQ}•fýčR?đ@Q.˛fB"]ŔQ}”—ÎX?đ@QL…ŕ.ŔQp"Fa?đ@QŢěőisŔP™éIuŢ?đ@KűĎđťŔPk0Jœn?đ@KŔlM4ĐŔP[?¤uÖ?đ@Kjl“‘8ŔPy•›ö4?đ@KŔ„4NŔPx”bbV?đ@Jľ~󜊚ŔPwźxm?Ň?đ@J\{+,9ŔP{  6e?đ@JńXO˘VŔP~埝Š÷?đ@IşŘ"÷ŔPŠx6ă‘?đ@Ir|*KřnŔP•N†ŔJ?đ@I*˜WvŔP rtŠć?đ@I{ľŢޝŔP˛M5Xt?đ@IGŻŔ]ŔPĂéŐvć?đ@I;„'ŕ]žŔP˗¨q?đ@H⿢”ŔPÄh<|ę?đ@H?o~ŔPž\7+é?đ@H5Ž:VÄŔPÇ_‡;?đ@Hm0䏞ŔPŐüîLXĐ?đ@HRBđ_DâŔPŕĹÉ?đ@DÍŤ[&QeŔQjŸ˛v4?đ@DyůŘĹú ŔQ'#)ă܏?đ@D(U„lBŔQ25Lźß?đ@CćÄŞˇáĺŔQ?:ńüŠK?đ@Cß;^w‡=ŔQTÄR~?đ@CĚJŐšś÷ŔQe1\ŤĂ?đ@ChĄv)ů¸ŔQvif#ěÔ?đ@CM•ńg„ŔQhĘ:jt?đ@C ,Š˜ĚhŔQrÝX'Ű?đ@Bžqś>XŔŔQjë{•đł?đ@BęE:=’`ŔQZg—žWŃ?đ@BŽŢ-…ŔQVӓžŞ6?đ@BgXźĹţďŔQg÷ƒ“w~?đ@B$Dń ŔQ^A‘u­–?đ@B#ţă›ŔQPeßÚP˙?đ@Aźbu… óŔQF OĚŽŹ?đ@AxmuA`žž?đ@@rˇRź ˇŔQOî 1~E?đ@@')ý)eŔQ]"w{ľ?đ@?žIHŽc¨ŔQgpĄÍÜy?đ@>í‚Ńj˜üŔQqˇGő—?đ@>g™Ż´ŔQtJăIĺg?đ@=FŘÖP“ ŔQwđ˝řŘB?đ@<‡f@ŠĐJŔQ€iCl3}?đ@;źç8mućŔQ‡r\ŚČ?đ@:čEÂó÷MŔQŠ,Gӌ>?đ@:ҀJBQŔQĂˎúv?đ@9IŇ×ůŔQ•ĹÝÎqď?đ@8x‹T8 ŔQ›Š„…•÷?đ@7¤f('ŔQ ő;k ‚?đ@6Č…*ƒŕŔQ˘;÷ďą?đ@5öqꚧŔQ›.Ňn› ?đ@5ł›úآŔQ˜ô'­aŔRmŘ6‡f?đŔ0Üé°ŔRzM—QŽ?đŔ0J„5TÎŔRƒyná%?đŔ.¸śŚcŔRłł‚Äs?đŔ,<ܞޕŔRy;Ş€Í?đŔ,ƒÜüóV°ŔR…oE ƒD?đŔ.8TT2ŔRŇŃË ž?đŔ/ŸÝ%ŠĄŔRuH[.Œ?đŔ0›L$؁šŔRŠá†ţ°?đŔ17…3o]ŔR¸jžĄęx?đŔ1”?bۆ+ŔRĘť9€Đ?đŔ2 4ś!?ŔRŮÚMh˜„?đŔ2"H=DŔRíśÇ@Ń×?đŔ3Wą[ÎâDŔRňCbŽâ8?đŔ4SHŤŢAÚŔR÷˘:xŁA?đŔ5`Yút“ůŔRüŞ* !?đŔ6{ÄČę‘:ŔRţńZ?Ľ?đŔ7Ÿ÷Œ-uŔSŞMź?đŔ8ɡ6ŒŽXŔSĂŤńl˝?đŔ9äAЅXŔSďׄN'?đŔ:Ć öľ‰ŔS'G1˝*?đŔ;çt=ŘďŔS"Gźj<É?đŔ<čžP`ILŔS,ä-i?đŔ=Ćşż˝ŽŔS:O“FÇŞ?đŔ>ȌOZŰÉŔSFq`Ä?đŔ?ŹqtqÝŞŔSSď&Ců?đŔ@mQĹE’ ŔS\Źˇ?đŔ@â{Üž:WŔSj2•ÖĂ?đŔA@1†Ň™uŔSyÔ˘Ęq?đŔA ˇ™đŹŔS‰a-§™ ?đŔAňČŁEŢ ŔSš†Ď‹C?đŔB[=:-!ŔSŤÜčÁŐ?đŔBJčy.?ŔSžeo§?đŔAl]•´P:ŔSɋÄŔb?đŔ@ćH‰ţpÂŔSÖä[gfŁ?đŔ@/Ú-Řľ°ŔSŰ5;•z@?đŔ>ř#ńŔSŇĹgÉ(œ?đŔ=Ÿ<Ç>NŔSÉçŽÍş^?đŔ;ĚDí ÚŔSĂU4ÜÉ?đŔ<‡ćl ‚ŔSĚZŽ?đŔ=}ĆxBŔSڂ°MĚz?đŔ=Ę4ť„QŔSëçšť?đŔ<|:hĚ8ŔSůéqt_?đŔ<%›zŁ_˜ŔT -š.ó?đŔ=6žj†cƒŔTHłĆč?đŔ>áé\UőâŔTĄœă÷?đŔ@,d;ŠăŔT)‹0mĹ ?đŔA\ěŮAtŔT0„B?đŔAĎiţQVŔT8ԉ̚?đŔB¨6 "”zŔT?Âţšv ?đŔClŇŠrXĆŔTJ Ă&y›?đŔDA’•uňŔTS\1ôOü?đŔDúî0ľŁFŔT_>ôóK?đŔESGD7R„ŔTq56ţ؞?đŔF7ç!ŁšŃŔTw"<ş×?đŔG7WúöƒiŔTt2Â}?đŔH8żp°GŔTuôˆşÉ?đŔI/3O˜CŔT{Ä|ć?đŔJžČ°zĚŔTƒ‘Şş†e?đŔK Ť¨­šŔTŒ…űý1?đŔKÇ4|Üy9ŔTšç^e­?đŔLLPŠ[D¤ŔTŞyd#E?đŔM ?&ĚłAŔT˝E¤t‡?đŔMzLŃŐőŔT˛D؜ŇĚ?đŔMĽ!łŔ ÔŔT Ť˜Đ2?đŔNo÷ŘĚü<ŔT“ĐvÁ)[?đŔO=Çw}xŔT‡7›%Íj?đŔOüÖ–ŠŔTz[ÂŢč?đŔP[ŠÜ3ŔTm“ÔÍ ?đŔPľ“^űŔT`bř¸.đ?đŔQyě"ÝŔTT Ň×]f?đŔQwa:–ÂQŔTI†đű c?đŔQćf‡“pŔTBŃ7ˇŞ?đŔRIlĽňŢPŔT8l['T?đŔRŁFÚüF&ŔT,ˆ˛ FŔSˤőń?đŔTşvšžżŔSż4QHĂD?đŔTŘţĽÎƇŔS­u}oĂ?đŔTř{ŒŤƒƒŔSš›Ô¸[ő?đŔTĂ-e ĆŔS•r8á4?đŔTˆœ˝ŠzŔSĽœmÍv?đŔTAvtçPŔSąůď?đŔSäPâX{qŔS´Żż]BC?đŔSŠ0ş/UEŔSŽĂgCşÂ?đŔSdÍ˙ŢÎ?ŔSŸ^FťŔ?đŔS—o1îŮ2ŔS™‰Ř~›?đŔSę5óAŔSˆÄˇG?đŔT?í-%¨ŽŔS~I—dq]?đŔTB?Óu?đŔR?čD=žťŔSj„ĘôÄÍ?đŔR}_~ä mŔS_§nâ„×?đŔRÔě9hÉŔS^ĺ~†1ę?đŔS™Ą$ńžŔSRW‹<Š?đŔS=ÚĆŁZ5ŔSCN!ôa!?đŔSes˜†źŔS2ř5Áîü?đŔSˆĹ[ţ¤ŔS"‚Ëjqô?đŔSœN¸œŔSŻÝ+Čj?đŔSrRŇdĄŔS”żU -?đŔS-áB?BŔSnë…u?đŔS yÜźIŔS|Ó8‹?đŔRŰ°ďzZŔS":퐟Ÿ?đŔRŽąĎŔS&QĚM†?đŔR>{á' ëŔS(Ŕˆ;^?đŔQîM‰ÚĂŔS*˝Vɝ?đŔQ›‹ťřÉŔS+,7—?đŔQrůJŔSŻ™?đŔQ7ŚˆöźŔS>ß>fb?đŔPń­ŽŃZŔS ]5?đŔPŠ_ŘpŔS*ĂĺT?đŔPifžd•ŔRů:Ô Ü?đŔP.E­ŔRîČłŁŰ?đŔOäĆ\•(ŔR⊜Ř?đŔO檰Žn˛ŔRÓš%Š-M?đŔOĹ­QŽUŔRÄkĆ×ő?đŔO“}ŕş<=ŔR°ÂÚwő?đŔOC÷L|SŔR¸°8~Ut?đŔNřĎŚ›FŔR˛ˆó˝Ä›?đŔN憉|îmŔR c9—{˛?đŔNš|•1¨1ŔRŃ´ą2?đŔNąZáe}ŔRžÉ.ĹÜ?đŔNšmt %ŔRz,a/á?đŔN`̒!ŐŔRl—Çdë?đŔNŹ‚Ł.Œ(ŔR_Üľ"ż{?đŔNÔe{÷‡^ŔRPýIT}?đŔNqCŐ}ăŔRQ‰>ťŞ#?đŔNČ-VŽŔRMÖĎŤ&C?đŔNGěĝdŔR=R“B’?đŔNdÇcS&ŔR-E€+ž$?đŔNłŃ‘eĽĽŔR"š˙M§Ă?đŔNŔ1GxşŔR*NŻŒŕ?đŔN@sh–^ŔRxPą”Î?đŔO"ĺĚ D#ŔRpťú?đŔOSAćăŔQůw™ÁŔ=?đŔN“@jŒ1ŔQó„[4 ?đŔNž ßźrbŔQçeŠÜP?đŔNˇÂw–&ŔQÝť—ŚÇF?đŔNŠ:Üß;ŹŔQĐ2´hČ?đŔNŁ”oWĺŔQźđ1`ü?đŔNő­’j ĎŔQ´Og̖?đŔNăĽ×°?ŔQ¨ÝJŽ?đŔOč“=Ý^ŔQ™˜§)˝?đŔO-~řâ(ŔQ‰śÖë† ?đŔO=üƒ!ŔQwě`řzv?đŔO=|“śąŔQdę‹ó§ ?đŔOuS‰ĆĄçŔQVĄˆ ů?đŔOśsłzEŢŔQI;ý/kš?đŔOĂ-ŢÄşÉŔQ4‰ý/k?đŔOäT˛ÜňŔQ&•|ˆN?đŔO‘¤‘Ě$+ŔQ¨ąŽS?đŔOťˆŠÁ˖ŔQވ>#÷?đŔPPŕ†ćŔQd§°§â?đŔP Ź§ĚŔQ.jřjű"?đŔP)+öE˝ŔQ/ikű”Ć?đŔPKÉ\Ł§8ŔQ,mľEű?đŔPVĺřŰîľŔQ^+ÎĎ?đŔP?p`ęâłŔQ ŢŰӈ?đŔPXşIé÷oŔQŠżřž?đŔP]ћ9éxŔPđEjC?đŔP`ňąž˝›ŔPßrƒl{ú?đŔP@_D÷ťŔPÓnV†ĄŤ?đŔP1śí% „ŔPÁďÔxŇ?đŔP_GcŔPľ ˙ŃŠ?đŔOřy"§[ČŔP˘&ćƒ4o?đŔOČCumŔP’aŔş˙ź?đŔO\†‡_đŔP¤Ľ?-!?đŔOP§P= áŔP’@‡Ëƒ2@?đŔNXś/%0ŰŔP1óéÔ)?đŔNÓ­}ŹœŔP#uľ‘ƒĚ?đŔMĐw(˘ŔP\y-/?đŔM‚qOh.ŔPęq)?đŔMiÚo*{ŔPňśąp?đŔMU*ŞŮmrŔP Úů?đŔM%˛eăVŔOĺî`“F”?đŔLߖŠ[éýŔOĎłMŠőÄ?đŔLˆŁƒL.ŔOĆ%wÎîA?đŔLƒÜ]’YŔOĽłŃ„CŸ?đŔLĚg8á–xŔOĄw@ţ?đŔMÜ8ךŔO´žĽjĆ?đŔMaĽőA\ŔOĨ|€•?đŔMŸđ>ŁöţŔOß$>ţ‹?đŔMá8Cż-ŔOí@łÉ!™?đŔN'm—ŒŇ‹ŔOů‡jâ X?đŔNr9YP ŔP@^ŞŐ?đŔN™c^pŸŔPĐ O ?đŔNŐY盛QŔP")Źt l?đŔO)§8#xâŔP-CćĄ?đŔO\˜Ř"ÇŘŔP6´.ÉĹü?đŔO•üFÁ„qŔPCSt÷a@?đŔOňÝřz”ŔPE𠸿Ů?đŔOúcü9X=ŔPYŁˇ–ž?đŔPqqňQdŔPf-őąD÷?đŔPťÎŠHÂŔPsŽ^g?đŔP47î ŔP~ŕ’ÉKˆ?đŔPW”ÇߧdŔP†Ićĺ?đŔPtáaŽ[ŔP“5žK?đŔPŒÉiĺ9ŢŔP˘Ěƒˇ<?đŔPŹvĚ{ŔP˛SŘ?đŔP¸aŕ§ŔPžzŢS3?đŔPÜEŰŻüŠŔPÇ2…řܓ?đŔPီ˜vsŔPÜ쬉9â?đŔPŻŮúx4ŔPáržőPë?đŔPł*śö:úŔPíŽ&ĂP?đŔPÂNÔ HŔPýƒŻT|M?đŔPş AH1ŔQqiPÉ/?đŔPĂ éU;ŔQ ‰ňoF?đŔPÍVwL×ŔQ2Â|/őa?đŔPˇşÓ- ŔQ@­Âä5w?đŔPĘnďdŔQRpU™?đŔPüăÜĚQ?ŔQU´U„b?đŔQ#‘s%ĂWŔQZŤbw;3?đŔQ0:’ŔQm=Śťř­?đŔQŲÉwTŔQxř6'#?đŔQűœë™OŔQĚ”)Hç?đŔPňë0ş\ÁŔQĄ9 3‹Ŕ?đŔPĺ˙H˙(ŞŔQł#7Œß?đŔPŰoN {ŔQĹuçâŰ?đŔPŕƒáMnŔQ×ĂýéŔľ?đŔPҙŰĹ°ŔQéŹŢ¨ÍŽ?đŔPťúó`™ŒŔQúĄ‹çé?đŔPť9ŰO9ŔR >Hš°­?đŔPŔšĘ‘‚žŔRr™K˛Ż?đŔPŢ2 AÓÝŔR/}-řF?đŔQ ˛•j…?ŔR; ŹJ4?đŔQ==+OŔRGEĘĆ2?đŔQw3fy<$ŔRO˘)!y?đŔQľí!.\ŔRRsbLJă?đŔQđš’.o2ŔRX­đń^]?đŔR0këŔR^Ž;ë?đŔRhôżcÔŔRg:ŚńQ?đŔR¨°ŸÓAŔRlIsH ?đŔR曾’ŐŔRo"wQá×?đŔS(^NŚ_*ŔRu}Žń?đŔS1ÚŢ{ŽžŔRjoáow?đŔSVp,ĐĹhŔRbÓŔFČŠ?đŔS›§<Ӌ)ŔRiI„°Č?đŔS¸¤CôŻËŔR^g_m?đŔSߣˆW.ŔRO™ěa>Ö?đŔTmRqhŔRE‹J”­Ł?đŔT'ILŤAŔRM´aĆ_?đŔT=A)‚ŔRZžr;ă?đŔTIUĚ érŔRkú4˜¨c?đŔTlř†5+ŔRx`ôx˝[?đŔTĽ‡áľ7†ŔRv$ӓŻ;?đŔTá_‘~šÄŔRmýΟď›?đŔU¸ĹăP4ŔRk(¨m)?đŔU^N´[”ŔRcöŇ|™?đŔUv'ۤ9ŔRLôä7ZÍ?đŔUŁiŹƒá3ŔRQą‚ŚíQ?đŔUŰqfÍţŔRO˘=U#~?đŔVť1[ŔRK/Fë ?đŔV9Iôí!=ŔR3ŽÚŠą{?đŔVY Äóˇ°ŔRBć! M?đŔVŠ¸Ř6ŔRK%ƒož?đŔVÐŁ›ć¤ŔRQú÷LtŘ?đŔWœ›¤fŔRLV–P•Đ?đŔWCÁVđą_ŔRK˙hB?đŔWĚ<Ëĺ`ŔRQ$ôŠ ?đŔWżŮyäŔRN䶅(Ř?đŔW˙(t iŔRR$űpł8?đŔX=_č11ŔRP‡pđ6•?đŔXzŃ Đ)ˇŔRGŃ „ś?đŔXŠŠ×ţ°ŔR?j<bˆ?đŔXé’3|€ŔRA°Šž%ż?đŔY'×ü:NŔRC[Ľ Oě?đŔYmú¤źďoŔRBËőî÷?đŔYšÁrżVĆŔR;ěǐ|"?đŔYŔŐ̗IŔR0Č °?đŔYáŕI`ŔR<7%ińB?đŔYĐKÓNŔRN„ŢŞ€?đŔY™’‡-ŢŔRU˘Ót؍?đŔYZ=/¤ŔRVd]Úß?đŔYÔJčŒ-ŔRXu¤­Œ?đŔXáíf2ĐŔRdcă vŃ?đŔXúu€ŁFŇŔRm9Yś~m?đŔY ?ŔR•ć ˜ŮZ?đŔ[ĂÂÉť7¨ŔR.% t?đŔ[âŻő`žŔR˜ŞMÜ â?đŔ[⌛?,?ŔRŤ5ŢH?đŔ\ ý#ؓ ŔRľŽ˜QCÉ?đŔ\=^}ěű~ŔRŽ lá)Â?đŔ\PpÇ^ďŔRŸ˜+Ka?đŔ\VFT/čŔRŮűäÉÁ?đŔ\r€žë‡|ŔR~F ”M?đŔ\§žűčS`ŔR‚(|Eâé?đŔ\ŽĂ˙ÚRĹŔR–çáʼn?đŔ\çő“tŔRžM¤,?đŔ](⯊ œŔR˘mΊ?đŔ]jXŽZ{ŠŔRš=”¤x?đŔ]›w,Î dŔR /Ŕ„'É?đŔ]ŇĎ|V:ŔR§śî*u?đŔ^­Á„6AŔRŤœüÝzc?đŔ^]űżX§@ŔRŽ%b%?đŔ^Ł}9F.ąŔRŹ>ç?đŔ^çË°+œŔRŽt! č+?đŔ_.^gUŠpŔRŤT;Čac?đŔ_tN5S)°ŔRŞP“ˆ}P?đŔ_şsY÷"ŔRŠ‹OÚ{‹?đŔ_ţ.?FqÓŔRŹťÚqë?đŔ`ˇĄŻŞŔRł›­2Â~?đŔ`BsÉŃŔR´÷3÷ń?đŔ`eŸěÁ‡ZŔRąČŐüÜ?đŔ`ˆnű*ŤŔRŻ őĆÔ?đŔ`Ť˛ři uŔR´#'âg?đŔ`Čą{šŔR¨Xݍő?đŔ`éďăŤW’ŔR§P Ď+?đŔa ‡7$ümŔRŻ˜h°÷?đŔa YŻœŸAŔRž6Ăťáq?đŔaAłPoŔRÄĹ÷ĐŻ´?đŔafýÝH°ŔRÇć'ńÖ?đŔa|qžňkŔRÖák W”?đŔašYAK°îŔRßИ}ą‡?đŔażQ9iÎŔŔRß˝‰¸ ů?đŔaÝČvĘ+ŔRĺ›f-ě5?đŔbFüT™ŔRívyĺö™?đŔbićŃ$.ŔRřł™żâ?đŔb@ł6?•ŔRýX,˛Œ˝?đŔb::žâ\ĐŔSD#Bß?đŔb\+&ožŔSČŹŐ?đŔb€ÇF÷ä5ŔS "Iűţ×?đŔb¤D ˙ź°ŔS~74C?đŔb3˜˝ŔS Ń'Ć?đŔbiN˜ƒ¨wŔSaČS>?đŔbIłÍ­ŹRŔS&qţ‡?đŔb6§ßÎŔS5#Žąa*?đŔb<|ŽwűŔSC99Śˇ?đŔbA§Qę6ŔSU[v÷Ż?đŔb_yF2t<ŔSTŔ>ρ?đŔb†K°˛GŔS^ő\ÝűŸ?đŔbŚ6 Ó-ŔSiĄŕČU*?đŔbĹÁt—Ŕ’ŔSjNź<ę?đŔbäÖĚ3ęŽŔS\ v•L‹?đŔcŤÖíGŔSZj–˙Ťœ?đŔc$Lťăx6ŔSWÉ\… ?đŔcAŢëŹŔSK?.Ć&ó?đŔcißz´ëŔSF‡şÝ7š?đŔc†IŮŹ¤ŔSO&rçźŢ?đŔcŤß!ö ŔSLëZ^‡?đŔc¸yő˘ŔS\bUĎ?đŔcŔ:źŠ:ŔSm™T)¸Š?đŔcźotqŔSEśĽĆ?đŔc–ćH| ŔSË=ÉŰ?đŔck\—ňžŸŔSŠxĂ91Š?đŔcAńě)ďÁŔS‹ÍÂs%?đŔcDTŞŕĹŔS€ż¤Šr?đŔcpšFŮ;ŔSŚ_6V(3?đŔcnGśbqÇŔSłžě Ĺ?đŔcN6 “ZŢŔSÁH]‹Ü„?đŔc"ä|˘ąÝŔSÉFšjłS?đŔbřßG— űŔSŃĺŹ\Ž#?đŔbŃ>X čŔSÝt(HAÓ?đŔb¤ 4N˛&ŔS敺ČM˙?đŔbxƒaEˆŔSđ¸2ă(?đŔbRŞŐüŁÓŔSý"?ËÜ?đŔb=r/ čgŔT2XŮ?đŔb4 Ă6{˛ŔT Ćs‡?đŔbPŤĹ?ŕ`ŔT0đPěx?đŔbqťÇŹËhŔT?ŮÉŞ?đŔbŒĽŃÍŔTPĺ?żD?đŔbźÔŔiŘŔTVX]–Śđ?đŔbďČePCćŔTLdó€ě$?đŔc&(ÜAt‚ŔTE¤Ďé&?đŔc`ô,€sŔTAF!Ó?đŔc”mOŠ8(ŔTJKRÇ?đŔc{Á•óž&ŔTVžř“v˜?đŔcJʼn§_•ŔTcślćó?đŔcU6›ő ŔTuÔ}vü"?đŔcB@^ţŘDŔT‡ŠţbAŕ?đŔc,çÓăŔT—Q ťţ`?đŔbüôߐ (ŔT§âöéÚ ?đŔc önŔTš˝^;4?đŔc H¸ ŤŔTË×óƒ?đŔc‡ŽYęŔTŢrŞ.Úd?đŔc#ASţRŔTđĂ^S??đŔcŕ3ĺŔU咃?đŔböR=ĄŞŔUÖj;Ş?đŔbˇyŁ/°ŔU!ÄĎe:?đŔbbbÓPýÉŔU+ Ő!?đŔbŢ=^ôŔU1Ű!ř'?đŔa˘ĹɐĎŔU7ŕĄ÷w–?đŔa_Ú9…bŢŔUCH~Vć?đŔa›epÔŔUN°mô¨?đŔbXîzx'ŔUHŞon”?đŔbyĺŕđFŔUG\Ců_Ą?đŔbʼnÇ NŔUWĚôÝ$ţ?đŔc.B@Ůu…ŔUU§?|+E?đŔcĽ¨űwDçŔUY­ú ?đŔdIŚŕďUŔUS˙Flr8?đŔdk&;g ŔUIߓ‰„?đŔdŔ2‚ťëĽŔU>’Ť€Ü?đŔeKW÷˝ďŔU2ZgÔ?đŔeXŽ'–†ŔU&? *Ł?đŔeążŽé¸ŔU¨lJiZ?đŔf˝ˇ>ŔUVs‹aŽ?đŔfa€u}´ŔUgi›ŕ@fXH˛‘žŔU ő˛¸ż?đ@f Î[TžŔU/š)_O?đ@eÁĆďhĽŔT÷”ƒ9w7?đ@e†C$ÝpŔT힐_I?đ@e` ĘSDĽŔTŕ)ZšO?đ@eyä"ŔTŮo.…Í?đ@e¸‡ŠœŔTĐćY˘”?đ@dű‘jbjűŔTÁ TŠÇ?đ@dÚR)–fŔTłŐ›q#?đ@dłŸźz KŔTŁô” ĐZ?đ@d‹fF4œ•ŔT–]íőŽ¸?đ@dtĽkĔ ŔT‡Á´\âA?đ@dWľšđÜŔTvUÂBżĽ?đ@d(2dőžŔTd•đ„Nč?đ@d3ßř`Ξ÷?đ@eB݂ŚÓiŔR+Ś-Ѩ ?đ@eFńJ—^ŔRFۇm’?đ@eB)ŐpźňŔR ¸¤,Ě?đ@eT2+mtŔQýÄxΈd?đ@eZę<“ÝRŔQíň›Q¤ ?đ@eIç>bÎ&ŔQŢÂdi{Ą?đ@e-%0+ŔQŰ"_3Y‹?đ@e  ÁŔQ΍ça~?đ@e7gá–óŔQÂ5ř4Ó[?đ@dő ĆßFŔQ˛„yý&ą?đ@d×ő_‹°ĘŔQŹť×Ň[u?đ@dżˆvâŔQŞ=óÇź?đ@dĽgؙ–tŔQ¤?&i6Y?đ@d‰Ć.ĐVĘŔQŸů¤OÄ?đ@dpcÎśHŔQ¤¨ź‹ń?đ@d[¤KPoŔQ—ŐÚMĄ4?đ@dA qeüpŔQ“qŚţýŻ?đ@d(3¸<ĺĚŔQŽ˘×łW`?đ@d“,ŕ[ŢŔQ…d˙3ú?đ@daâY†ŔQwKQćWK?đ@cňC{ofŔQiĚ@V?đ@cܖ-’ť’ŔQ_Ŕäąĺű?đ@cɊ(ŠŔQS÷ƒ0Ÿđ?đ@cŹZigh0ŔQG/•J–P?đ@c—Ě@hýqŔQK˜t[Ę?đ@c×qĐtüŔQLʉrc?đ@cfžŁĆPnŔQGh•Ýœđ?đ@cPlśđäEŔQ:ŕ¤rą}?đ@cQĂ=5ĽŔQ*Ťm ěĚ?đ@c>!3bąÄŔQ„3,ĆJ?đ@c9wĎż…ŔQ'z]őAé?đ@c3qé˝ŔQ9;DÇ?đ@cŽ°Ő"ŹŔQ5¸ FŚ?đ@cŐn”ß%ŔQ5Ďub>?đ@bć]ۈâŔQ8…Ň|ţW?đ@bŕP~ţ¸]ŔQ ‚F˛[ň?đ@bșęÜËŔQČ SB?đ@bąÜş0@ŔQÖJ"ja?đ@b—ZDwˆçŔQ°÷Ţ֏?đ@běŹ÷˜ŻŔQy 0-–?đ@bâ$ŮbŞŔPůůöC?đ@bfţB{ăŔQ^Ľö÷1?đ@b_“ŁbŔPűai“ŮU?đ@bNŐ¸‡ÍCŔP쐺/Ť?đ@b3a[ë!]ŔPĺŞ yƒ?đ@b6FŔ¸Ě@ŔPÔ—xx?đ@b1Šú€kĽŔPĆhô$4?đ@b„pGf\ŔPÉN8­ńä?đ@b˝zÜŔPĂ@‡ťbž?đ@ađYÜdż¤ŔPšěĂşÁ?đ@a×1ńWQŸŔPžŔ¤ß–I?đ@aÇ€l™ŔP´8ţ3ć?đ@aŤ°eťşŔP˛L16ü?đ@a”ěžŮ"éŔPŽóňiş†?đ@anŞđ 8ŔPŠřţlÓć?đ@aiPCÓ ŔPŁ~ôuBS?đ@aRFţmMŔPĄ‚řŹG?đ@a<~űťřŔPš‡ÇW›?đ@a&×´xWÔŔP”÷ŠŞY?đ@a6œ°^WŔP”už˜˝Z?đ@`úsćwË<ŔPŒŸ4rĂ?đ@`ä ŇŞ™|ŔPƒ¨‹ŽŽ^?đ@`ă*î­2“ŔPsęîK,‰?đ@`č>ŸŘŔPa•xšęŔ?đ@`â˙ łiěŔPO”žs?đ@`؇đšĚŔPA×ĺf?đ@`ÇlŃŐńŔPB‰h‚+?đ@`Ä?yFýFŔPU‡g@?đ@`ĹÓ4]ۊŔPg˙Ň׍2?đ@`̇ëčţ,ŔPy†VUŘÇ?đ@`Ä;ňWŔPˆžG}?đ@`ŤĹ홽pŔP… î@ĎÄ?đ@`•ś‘ń[ŠŔP‰]âé3Ü?đ@`˜(uúłŔPŒCš6Ž?đ@`i"=XÜXŔPŽ¸ŻB?đ@`QţîXŁžŔPş)Ç?đ@`> $ŹŔP–ôJ_›?đ@`0v°C.¨ŔPŚ*'ž˛¨?đ@`*u!ÍŔPˇjyg9ň?đ@`¨QVg„ŔPĆ+ŸĎÂż?đ@`Pu[ĄŔPÂâhw•?đ@_âeŇfĹHŔP˝&ĺpů?đ@_žpař CŔPąôĘóك?đ@_śtƒíw)ŔPžŔ ęš?đ@_Ž™§ušŔP”7Z˘ÉE?đ@_c˝IŕŔPăIŁË@?đ@_H•ôL=¤ŔP­˛éa?đ@_'áX?Ů°ŔP§svň˝?đ@_ 9ioŔPŁĄôF°d?đ@^ׯß"öŔPŹÉÖwŇ?đ@^śA#4sďŔPŞuZƒŇY?đ@^…şľ’š=ŔPĽŽŽK&?đ@^YťYţÇŔPŹ‘–•?đ@^0•ă07źŔP´ˆń^Vţ?đ@^ş-Ľ…5ŔPśŽ”ÓĄ?đ@]ÔůśőŔPşŘ+[ŞM?đ@]˘Ř!Kś5ŔPťR˛‘^Ř?đ@]uÂň!d˘ŔP˝Ç¤¸‘?đ@]HXB( ŔPˇYŰëNâ?đ@]/wŇÇDŔP§ď°­ž.?đ@]š’(YŔPšM—Ź?đ@\ä $­ŔP˜7őWk'?đ@\´Ňľ°PźŔPž>Şîpż?đ@\žS÷őHkŔP×˙Jë?đ@\‚3jjmŔPa/ÓT?đ@\c“BoÜŔPrŔ^ń ?đ@\=%řZ&gŔPq‘ß•cT?đ@\‘UÜ%­ŔPxYăF?đ@[ćâJěŔP{Ă\ ˆ;?đ@[žsé“ŔŔPƒşáXńŢ?đ@[Ż†ĚŚ+ŔP””őJęŚ?đ@[™ě‚”JŔP˘ţt‹Úm?đ@[r‘Cœ ŔPŤąŸ¨8Ä?đ@[=\geŻÔŔPąbĹ,Z?đ@[ŽÎóŔP¨L–çŹd?đ@Zňđ6ˇ*ËŔPœř´?đ@ZĂŁhDa`ŔPš{ l›Š?đ@Z—‹58ŤŔP–?đ@ZkŢĄ˘çpŔPÄÜĽĺf?đ@Z@•ťeĚŔP‰Đhýƒ5?đ@Złž3ę†ŔPƒPÍś~(?đ@Yë6]oŮŔP€Ţ "?đ@Yż†š˝#˘ŔP{mWĂ?đ@Y’‘‚üIŔP{̎ŒUŻ?đ@Ygyˇ˛gęŔP€¸ţ–éŃ?đ@Y=ţ]ĽĂŔP†ć‹ĐN?đ@Y <VÇxŔP•”—Âě?đ@XüöMű‡TŔPĄ+ ť=+?đ@XÚä‘ţ?ÇŔPąŰ1;G#?đ@X˝^ńţś•ŔPŞřĆżxž?đ@Xš…†î,ŔP˘?T–0?đ@Xjl‹‡CŔPŠ÷ő C?đ@X?1Ń­\ŔPĽ´kúoŻ?đ@X˝ÎŰŔPŠ.ŮX9‹?đ@WߛÁXŽŔPŞ RWă˙?đ@W˛Ţœ”ćÂŔP¤Ł.łcđ?đ@W…OúzşŔP¨Ű/íB?đ@WW9?D­˙ŔPŚ#˜~Ť˛ëŰ?đ@V˘=SéđŔPŁşĆ|Pô?đ@VŸ$|‹âsŔPŠ ĐAŠ?đ@Vr§A§ËŔP­Ć"Ńz?đ@V?•&Ś–ŔPŽ—A˜??đ@V0ŞéańîŔPžĹŔzÉ?đ@VŽ#° ŔP‰M–n?đ@V ŻľĺŤ ŔP×ŽîÚl?đ@VVt\/óŔP¤_;:Ą;?đ@UěŒÁ,ÂhŔPł†ˇđ?đ@Uƃ7ŹËŔPžF÷ĎáI?đ@U˜ŢüőC‚ŔPÂŢ3Zŕî?đ@Uo›Ó÷ŔPĘ œĄ~Ź?đ@U>ї?ŔŔPɸÜć8?đ@UĹHFSpŔPÉqé#Zx?đ@Tŕˇ*ŢŔPĘş—˝†?đ@T´łá +ŞŔPӆžŐCű?đ@TŠXo6ŔPŇ%_8UH?đ@TpZÜ=ŔPă Yąn™?đ@Ta8ƒŻC˙ŔPě˛íe¸z?đ@T7Ł†^ŔP÷%ÝđY?đ@TBxkŔPűŘLÝ?đ@SÚĚÁ›ÉŔQ`ww˜ ?đ@S˛óŸ.´tŔQ ÷kÁ u?đ@S’‹–zĐŔQŚ5(?đ@S}(‘mŔQ,T ˛ŐR?đ@Sy§z¸[>ŔQ>ohCč´?đ@SZ+—Œ8˜ŔQK10ůśÖ?đ@S+­\ŐŔQT&­Ju{?đ@SÚšőŔQ]EŒ #Ŕ?đ@Rę}ąs…WŔQdu˛=Ţ@bĄ`…šĐ!Ŕ4ž ?đ@bšA̓yÁŔ4Î7/ę(?đ@b™I#ZęŔ4‚vˆÚÔĹ?đ@b—ŸMáčçŔ4CdÉOw?đ@b‰I'ˇŔ4# őŐxœ?đ@bˆ~'›Ŕ4tŢXý?đ@bFĄsŔ3â˘e§ýŹ?đ@bvĹĺx4ăŔ3ÁŰS܏?đ@boyqnľÝŔ3pŃqFŞ?đ@bgœÇxŚÇŔ3h•§(Ľô?đ@b_ŻqŖuŔ3EE/íÂ?đ@bUňD4'(Ŕ3/ kƒi?đ@bM†œD˛Ŕ3ÄËę?đ@bIBcä(Ŕ2É7Ć7Ů?đ@bHbpńđřŔ2‚ůóí”?đ@bBíęňÄŔ2JaKՖA?đ@bAË5if!Ŕ2dôM?đ@bCIë—}Ŕ1źűĘVîŕ?đ@bB5ˇÖ͇Ŕ1vŻîEŹ ?đ@b>Œ[ԋiŔ11‰6MőŃ?đ@b:ÓdfÂŔ0îS\! ?đ@b4 ܄;šŔ0śi!Ş5?đ@b.X•ŢýFŔ0y¤?,J_?đ@b.T⍳ˇŔ03Ô꫟Ž?đ@b,a-ŐĽ!Ŕ/Ő BIĚ)?đ@b*<– $Ŕ/Eęúô&?đ@b)(fb Ŕ.Ť´f˘S?đ@b(Ԑ$UĘŔ.%ÍŰe˙4?đ@b&”Y– űŔ-ŔË=üoń?đ@b†mí˙ŽŔ-lŰäżĺ?đ@bľéviüŔ-݋ˇpń?đ@b<—jßŔ,–’ł+r?đ@b œÂ†ĘTŔ,‹xaěEä?đ@bńhÂśjŔ,ÇBY€_?đ@aű•4ăšâŔ,čf"ih?đ@aöŔ˘ŒŔ,gA„Ĺa.?đ@aó 9Ŕ+Ü˙ÖߝJ?đ@ańĐąŮ1ŕŔ+O.ź#š˘?đ@ańÂó¤,ĎŔ*ÁO ÄŞA?đ@ađ:#lˆřŔ*-¸śO ?đ@aíŐź1 Ŕ)Ş"r wˆ?đ@aęý÷ LËŔ)쨁<2?đ@aä~Ź~ŻŔ(¤Ć”É?đ@aĺ!!Ý]ŽŔ( ŽQ—‹h?đ@aŢKňґmŔ'żŞQúmŸ?đ@aۍOŔ'/Ô˘€ž%?đ@aÚqş˙BŔ&Ÿ/ąčĹĄ?đ@a×7V<4 Ŕ&Ĺ勖ţ?đ@aŃŁ‰^_Ŕ%Ľ+_aŁ(?đ@aˆa•qžŔ%Ż ügëâ?đ@aĹ(ËEÁŔ&źˆu@?đ@aĂăş DŐŔ&Ž1‘ŽŐ?đ@aÁ/ ăCŒŔ'>č˛Ýâ_?đ@aż3/ćmŔ'ÔŽá“R’?đ@aźH"*:Ŕ(™ú+ß?đ@aˇNóóŮŔ(Łă1ďŠ?đ@aş<ÄëŔ)Döw4ß#?đ@aˇ/F[Ú÷Ŕ)ŚşÜ`q?đ@ał­ş¨śZŔ*vĐîź#?đ@a´°‡^Ŕ*Ž=é0k?đ@a°˘Œˆ;‰Ŕ+9›öć?đ@aŻ€[3>Ŕ+ÍÔˇtÁ?đ@a˛Î ,ŢŔ,X)Qw%Ţ?đ@aą0FN…ÔŔ,í\ňH ?đ@a˛EĘUÖ(Ŕ-é~Ő˛?đ@a´rgžßŔ.œń3­?đ@aążr—Ŕ.žŒă†ľ§?đ@aŽź—]ÜŔ/-}ˇ×˙š?đ@aŹç…¤UĆŔ/Áٽڟ˙?đ@aŹJ‡D?tŔ0(ľCĄŽ?đ@aŠS×!؅Ŕ0soM€?đ@aĽ„ž)śŔ0śVɉÁü?đ@a "1vöŔ0ó žÉm6?đ@aQëF}Ŕ18¨5Ňx?đ@a˜úŽŠ4nŔ1x3Mě9Ż?đ@ałŸ4ŇgŔ1Ÿsœ¸u?đ@a‡pď“–Ŕ1ł)Ď_&Á?đ@a~@n€šŔ1¨mÜ!Ţä?đ@ausˇxŘŔ1ˆ ĚźC?đ@amfó\ęŔ1bžÍœË?đ@aeĐż˝›čŔ18/‚Ŕ•ĺ?đ@aaźgŚťŔ0ö>b|/[?đ@aX°ĘDÍŔ0×ý€ˇ?đ@aO`ŚŒe Ŕ0Ć­ďÎn?đ@aF'ýîň™Ŕ0ąĆĐ‘?đ@a>…ź3V|Ŕ0ƒŰ#ŻŮů?đ@a8&@.áŔ0KĹeŒ>˛?đ@a/Ÿ\n%‹Ŕ0*$äMŤ?đ@a'`uV„ÚŔ0Đď ?đ@azgYŔ/ŇóşéqP?đ@a6ŽŃŔ/ąĄ&;`´?đ@aj‘čAMŔ/SoŤW?đ@a‚g ĐĹŔ.햦Ńî?đ@a ‹ř—xŔ.“L&i?đ@`řƒ†ŹrŔ.==K(?đ@`đ(úŹ•Ŕ-đBRí_Â?đ@`î6MîXÍŔ-lÂÖe?đ@`óŻ—ĺ”éŔ,í}$(ě?đ@`ú ™cůhŔ,y6Ë^o?đ@`ýďĎË.Ŕ+újŇŠač?đ@`˙0=í.Ŕ+l[ą˝qŹ?đ@`üâű$cYŔ*çeŹë-°?đ@aĹPÖSăŔ*€jΘ\?đ@a =UՓ Ŕ*[Á"2° ?đ@a¸@ű•łŔ*UĚ}óŕé?đ@ař›LóăŔ)ÄFâü|^?đ@a:Ý%Ŕ)(çžqă?đ@aŻżX Ŕ(Ĺšérť?đ@aĹpž9JŔ(sŤE=S?đ@aśŘI6ĆŔ(°)ý¸?đ@a ežŘŇŐŔ( –d „?đ@aônšP–Ŕ(yŹc?đ@a„JŕŔ(äǢ?8Ď?đ@a' `őŔ(tžíÉ?đ@`úăB8‹ţŔ(jť÷‡?8?đ@`öţQzŔ(UŤL 4œ?đ@`űAâ´ř8Ŕ'ÝŤC:ŽD?đ@`ú´nKŔ'ťÄÎü˘^?đ@`ňLE{™íŔ(Šäܡ?đ@`é'őťşĄŔ(hŞý{?đ@`áŃ ŹYtŔ(p­Çú°ď?đ@`Ůvπ+ČŔ(˛Ç`?đ@`ŃU+}űśŔ(ŽÂpô?đ@`ÇYąů˜Ŕ(@8Ŕ(mżaĺe(?đ@`]@sőŔ(÷Âř@?đ@`Wa+!B—Ŕ(ńÓÚދž?đ@`RR1VϑŔ)Bőyf4?đ@`KZ‚őÄůŔ)‹ä~TÍ?đ@`EN;qjŔŔ)ř‚ŘjBş?đ@`Gbä˙YŔ*•lc›g?đ@`@+ÉDĺŔ*řšJ­?đ@`:ٞšjŔ+?óyľgZ?đ@`7ń¨ž ‡Ŕ+ĹÔö/˝ň?đ@`1Ďž¨$śŔ,$—1n•T?đ@`,Ŕ՚HnŔ,˛őŤ_Z}?đ@`4_aj÷¨Ŕ-(#3†U4?đ@`:ţĺÎF8Ŕ-+Ź­çJ?đ@`8›Ł)VŔ-°˜VBuŕ?đ@`5 \' ˜Ŕ.1´ĐóŃ?đ@`1ÔŹ=Ŕ. ° TąT?đ@`'°3týÄŔ.šĐŮ A?đ@`#—gÇÍŔ-ă$ŠŐ­?đ@`mé°ťŔ-Ş`W #?đ@`ľ…"Ŕ-šFú&h?đ@` ˝î)1Ŕ-˙pŁŢ[?đ@`\ľÝ3—Ŕ.¤ŒŘŹ˛ˇ?đ@`6ąX¤ěŔ.rň¸ýdô?đ@`ˆbáôŔ-×Ë´4tî?đ@`¨—ŠnnŔ-aŁ~\˜?đ@_ů[Q7XŔ,ůŒ^ź*0?đ@_î řbšŔ,†}s˛Š?đ@_ߚǧćŔ,”ůá“?đ@_Ďéư̊Ŕ+ÝůâL?đ@_Â43ľŽúŔ+§Ă#Sőž?đ@_´¨ŠŽN„Ŕ+ľÔ<:˝Á?đ@_Ť¨_.dôŔ,,Í˝ĚHš?đ@_ Ć ›ĆĆŔ,rŻ0?đ@_”–Ô”QŃŔ,@뽚?đ@_‰X(B"^Ŕ,Xßç}Â?đ@_„­ÓLÇŔ,'Ëi÷#v?đ@_oëŔ§Ŕ,ÖSą)o‹?đ@_r ŞžŔ- Ű˙_ Ż?đ@_j¸ň*5Ŕ,ŠÇ5œÍ ?đ@_e˙jœĐˆŔ,Đ*Ż?đ@_[ˆxMű^Ŕ-袏¨??đ@_MĽľçU‘Ŕ-c‹4ÝK{?đ@_RŠ‡ť'Ŕ-âBf6¨?đ@_R‰ŇtŔ.2÷ó?!?đ@_AÖń؅˙Ŕ.ŇsUJ?đ@_@ Űř<śŔ.Łœâ śű?đ@_3ř˛Č˜Ŕ.Ľ›“|,E?đ@_)\vvšÇŔ.ĐQuˇ–é?đ@_>ť3‰ŘŔ/2ú`ě[?đ@_"{šÔéěŔ/ť­ťŠA?đ@_#j/&˛ýŔ0 ŚĹťI?đ@_kŮźŔ0?y5}ż?đ@_0g„ň"–Ŕ0`ŁËM?đ@_+ěŚ˙ĺ3Ŕ0f@#YłK?đ@_WßZY{Ŕ0cÂŢőKŔ0uňV¨?đ@^ăeڄ=Ŕ0™ĎŹ !?đ@^ő!ňéęŔ0Ů+C/?đ@^đ?çé#ĂŔ1i˝č…?đ@^äÇâ rŔ1k[O%Ňá?đ@^Ú3ôť•yŔ1Pž7uĹ,?đ@^Đ澑°ŇŔ1Ć85N?đ@^Ç—Ä !ŮŔ0Çȉźv?đ@^Ŕ[şLÉEŔ0„äZÍ!f?đ@^ˇ˜ „Ŕ0€ľAßÁĆ?đ@^­É¸(hČŔ0ż˜fËa“?đ@^ŸÂŁ˘$BŔ0đb Î?đ@^kziĄŔ1$AC#$ž?đ@^‰’ÎÔ0Ŕ1g͋…™/?đ@^‹„(Ú6CŔ1°"ú+ō?đ@^eI!ŚŔ1ög Şľ?đ@^˘n.ŒŔ2. °Yř?đ@^‚˜@Ŕ2]îűšĐ5?đ@^rś;AÒŔ2ŒŮ^[bć?đ@^hĚ[#”BŔ2É/â8yk?đ@^`¤wXz[Ŕ3 ŮśŮ?đ@^V­Ň|Ŕ3P2Ă;#?đ@^H@AY°ÂŔ3„ŃViď?đ@^7˛âšçŔ3Şs;>?đ@^%Ťú#ăŔ3Č ú•Ĺ?đ@^!ťmĺ—Ŕ3â‡3ƒ|ć?đ@]˙ąƒˆšŔ3ď”<Ł6ˇ?đ@]ěžS|Ŕ4Wo[ě?đ@]ڂqÂNŔ4I$q…g?đ@]Ç Ú6Œ…Ŕ3ţ&xBS?đ@]¸QŽs Ŕ40›:nE?đ@]§ł1´đŔ4QnďWĚĎ?đ@]“Q ÉŔ4Zńô4e•?đ@]ĐbôŸŔ4qáúŁ 4?đ@]rť1ĺŔ4Ÿ Xů.??đ@]`MżďgďŔ4łĄ™Âô?đ@]Kô›[×Ŕ4Ş$pZĺq?đ@]6ÜA‘Ŕ4ĄFœ'¤Ď?đ@](ľłfŽŔ4´ ×c˝?đ@]™ ]/Ŕ4Ö%iąü˛?đ@]|T=eűŔ4öŞľĺÄ?đ@\÷Ÿç ďŔ5%>)qŔz?đ@\čÇŁ;UíŔ5TŘfůĺ^?đ@\ÚWϧ2Ŕ5†č8qűM?đ@\Ç<ŽÝöŔ5ŚXńń[ ?đ@\ľÓS%Ŕ5Ŕť‰R0?đ@\Ľ_˘•C,Ŕ5ółŐW?đ@\ž3-žŹŔ6-źŠ9[?đ@\‘%°ŁŰŔ6u%.ľ@‡?đ@\‡ĚŞx^4Ŕ6KMhżpű?đ@\‡TśzťOŔ5ęVĚÜ?đ@\{ݓ[ŚŔ5ý%{ĽŔ?đ@\t˝×–˝6Ŕ6BQHTlČ?đ@\lv"‡9Ŕ6†Śřłu3?đ@\nť0Ue6Ŕ6Č˝Ň"ě?đ@\rsƒpŔ7œóú¨?đ@\q<~x=×Ŕ7ZěSř|?đ@\ilŚ{hŔ7›÷BŇl?đ@\_‹đ(Ŕ7܍H{ GÜ9h7v?đ@\Ä˙v5ř7Ŕ>O†@…?đ@\Í"ŔINŔ>Őľ*CŮ×?đ@\ÖÜ]é Ŕ?hńĎî?đ@\ߏ2DÝ~Ŕ?[FäŚ3?đ@\éi1ďŔ?u8ƒÖS?đ@\îěHiúúŔ?ĺěŹěí?đ@\îŒđÎ Ŕ@&Fů˜?đ@\ěĄEM Ŕ@KÜÁ~ŮŠ?đ@\çf;.żŔ@_LłÚý?đ@\ęë 3h`Ŕ@„XˇŽn?đ@\ę* ýŔ@¤ńđW§ ?đ@\ÜdřéEŔ@ČĐĚbđ ?đ@\Äůl˜ 6ŔA"’˘˙Ř?đ@\ÚVk†sěŔA-AÔN- ?đ@\ě´¨›Î ŔAB ˘č–˛?đ@\ű§ťL_ÄŔA_2rˇ?đ@]Ľa!šŔApmœLF?đ@]]Ô}¤@ŔA|_@ę ť?đ@]7eFűŔA„ âl6@?đ@]Nđůp ŔA„ ˇňľ?đ@]e# DŔAŠŚôBd?đ@]zşk;rďŔA‡ýÎĹFQ?đ@]X¤ż*ŔAxu¤šß?đ@] ł´/üŔA]×óT??đ@]˛â0čęŔAEŚmĂĽ?đ@]ÇäŕEdşŔA>"°¤?đ@]Ű[g”؍ŔA3'¤,Čm?đ@]掜ĚɌŔAŽ#É‘?đ@]řŰŮź1Ŕ@ü0)51š?đ@^ČýŞ~rŔ@ůIaȋ?đ@^$L‚N,7Ŕ@őĂ JG?đ@^:”ë“ż…Ŕ@îú$łHí?đ@^P6%O‰śŔ@ërŚ$  ?đ@^f”,0čŔ@ěç ůđ˝?đ@^~žQ-ĺVŔ@ň>c é?đ@^š×œo´Ŕ@ýs?…Ý?đ@^¤Ëg˙yEŔ@őϟue?đ@^ť5ŹëŔ@ń @Dƒ4?đ@^Ďp—3îŔ@ů蚯Đ?đ@^ç0ąqBŔ@îmąœJ?đ@^ö˘ˆňk)Ŕ@вl˲ë?đ@_cōěŔ@ąϕW?đ@_ 5ŹZŔ@Žƒ_AP?đ@_ŔĚŜlŔ@yÎáRą’?đ@_0Ł’\6ŘŔ@pĎČ L?đ@_C8ŔxǍŔ@]†;h?đ@_VœßXÖüŔ@KÜ & 3?đ@_ilZfÇŔ@:9 đ?đ@_|O˘Ŕ@&zŇÁŻÇ?đ@_‘„ăş™ăŔ@!šü|}?đ@_§ŻTǡŔ@'Y\Ď5ť?đ@_˝œřŹŃŔ@&Îe„ĆĆ?đ@_ÓRÝŘŔ@"xœ-?đ@_çŠI>(VŔ@Ť÷=ĺ”?đ@_ü˝› Ŕ@ C­Č?đ@`Ÿő`ń Ŕ?˙|ĐMá?đ@`‹#¨ÓÓŔ?ßëđƒ"Ľ?đ@` ǀmŔ?˝5Ă$?đ@`&Şí$´—Ŕ?Şt÷÷Ě?đ@`1r4ůcŔ?Ądk‹ĂW?đ@` Ú?đ@a;ˆśJĹDŔ@Vń1*È?đ@a>šÍá’óŔ@zŸ‰?đ@a=P)ŇŚŔ@™QĐĎb?đ@a=8€ËRĽŔ@ż{îŕ?đ@a8_iĚYăŔ@ÝPö;Ö ?đ@a2’6bŮŔ@űţ""Ďt?đ@a/z‹„ĽËŔA›Kˆ×Ż?đ@a.őiË2ŽŔAAąŹ!˝L?đ@a.ž–KMŔAm1›Í™?đ@a$匨ŔAv!žHő¤?đ@aů.¤źŔA˜Ŕßű?đ@a) ‹e$ÍŔA—7ABkl?đ@a4ևľžŔA2!Í ?đ@a:7”hů.ŔAoˆY˛/Ä?đ@a<ŠÚëőŔAK‘>ÚV ?đ@aAşÇ.ŔA!ˇ&lzĺ?đ@aHA F‰ ŔA5Ml–??đ@aNßc5€ŠŔAY6 "á?đ@aOÚĚĹŔAzAv"˜Â?đ@aNXË#|ŔAŸ“Č63_?đ@aGŒĎę{†ŔAČŞŒ\Ż‡?đ@aR”>˜TöŔAÎ9ćs—Ž?đ@a]FHm)ËŔAŔ†™h 4?đ@agů@k§ýŔA°›ŻŁĆÂ?đ@agváx}ŽŔAĘ@ąéˆR?đ@aeŮ=,ŹtŔAŮBoČ[?đ@amBőšóŔAóýąh?đ@aqşá”şlŔBlb|‘?đ@ab–4œpŔAԁĆ#_˝?đ@adŃcőPŔAÜ26ü+‚?đ@al÷‹Â0 ŔAőÔtžâ ?đ@as‚Đr~—ŔBŘ%ŞW?đ@ax)îbĺ—ŔB5ĐÝEĘ?đ@a{N WOEŔBYŢd[?đ@awçßOůŸŔB|ś`ď`ś?đ@ayŤŐdŔC.b迸?đ@aśÜ5A…ŔC(kE]‘?đ@aĂnUB}ŔC.Ď I?đ@aÎÔĹgŘxŔC2NjwžĽ?đ@aŘýěü¤AŔCF~ô˛?đ@aă’v–{šŔCW™G6â?đ@aîpăŤć˛ŔCgíŠTi?đ@ař̏ŰŕŔC[~ˇ÷ńŰ?đ@beqśvŔCAřŽÇ›?đ@b +‡őźŔC,x…˜ú?đ@b܃Żń*ŔCŰoś*‘?đ@bĐ2łYąŔBöŹČ ÷“?đ@b"‰EWŔC o@W ?đ@bGşô¸ˇŔC+’ĹČTe?đ@b“8ßâŔC;6 ̘?đ@b)§Ő-iŔC%÷ Ů˝?đ@b.ďr‚ÝŔC8 šÂ]?đ@b6Fő‡ëŔCT+Ôdâ-?đ@b>]őő—ÖŔCjĆwţôS?đ@bJş§,ÁIŔCƒŠu×Ţ?đ@bK~PKŔCj*ԁť ?đ@bQjKşČŔCYŰłľk?đ@b\šyľĂţŔCP//ýşž?đ@be>H;ź4ŔC4NúPőy?đ@bmxÝmdŹŔC Oţ•ď?đ@bvfUbŻ`ŔCËœ|?đ@b€ČŻ0ąŔBńň]>-{?đ@bŒ2ńÃxŔBéÎr8?đ@b—ă÷źçzŔB瘖"9?đ@b¤`uúŔB坣b0?đ@bŻ}é{sŔBâ°Žœ‰?đ@b¸…eŒ¤ŔBÉăUÜ}?đ@bż.¸o>/ŔBŻŤL7?đ@bžbŤÉ`ŔB6ô:n ?đ@bž* Z‡ŔBlÝ2_cĚ?đ@bÁijíŔBH Â_Cđ?đ@bĂכAńĹŔB$%i÷ˇ?đ@bÄyş5W.ŔBĽ9eĐg?đ@bČZČöő=ŔAÝűkęÓG?đ@bÍťÓÜĄ9ŔAťĂ4XN|?đ@bÓą*°8ŔA›šě k?đ@b؄kŞŤŔAƒLLŔ?đ@bڔ}„ ŔA^>Í"÷ľ?đ@bÜ6 řŠŔA?ú 'čŒ?đ@báš<_ŮŔA”yYő?đ@bćŹčÎcĘŔ@ýšŠ'#ź?đ@béRşcěIŔ@Ň6r ŮZ?đ@bďJuîoďŔ@ą—¸îäâ?đ@bômSPÉŔ@–žSVÚť?đ@bů•â 8ďŔ@w/ˆu•?đ@c˝Žŕ‰KŔ@^ŃŮ°ŕ?đ@c `ęJĄŃŔ@GĘđl§~?đ@c ¸ă‘eŔ@,”9?đ@cof°÷Ŕ@Ř*%ç[?đ@c_ĆGÉŔ?Κ€˙_?đ@cĚI†šEŔ?‰?wu,?đ@cWĂŽŔ?BĺH4Ú?đ@c!Ǣ'ÁŔ>÷ŤçR?đ@c b(XĐKŔ>Ż%i>a„?đ@c"ÜëMc2Ŕ>fňvŁ.?đ@c&áŹďRŔ> ]˙X0?đ@c(Ů]NšMŔ=Ů(sÜş?đ@c*ż°ýä|Ŕ=xą/sę?đ@c+ęĹ — Ŕ=G”ŚDŘ?đ@c/´-bŐwŔ=ůć÷6Ť?đ@c3hŠÇ ŹŔ<ťľ9 ?đ@c2N6_OŔiš¸Ŕ6u&cžěŁ?đ@bÂčúe Ŕ6='Ťťíš?đ@bżJ¤ţ­–Ŕ6ymô&đa?đ@b¸ăUÄs^Ŕ6qĺN€˘?đ@bł9Ě>üőŔ6>4p˛2?đ@bŻĆÝ(lŔ5öuá¨é?đ@bŽ~-›‚}Ŕ5ĽÚĆ9 ?đ@bŞ&3üísŔ5nŠ €ƒP?đ@bŚÖçĽ.ĎŔ5(Ň@ĽÜé?đ@bĄ`…šĐ!Ŕ4ž ŔA×J˜Ÿ#@PŽѲ‡?đŔAÍŔKč˙Ř@P–Ť•ţč?đŔA~/* }S@P•D 0?đŔADş{M°@PĄ$Ps.Ŕ?đŔA#ˇ-­P@P­ő×É?đŔ@ć˝nnź@PŔ ÷_†?đŔ@žÝńzˇ!@PґÂî?đŔ@žÓRdÔ%@PⳒr}ń?đŔ@lÍYÔę|@P‚m$?đŔ@óĺGś)@PúŁ:q??đŔ@ü4Węź@Q ü‰şđŞ?đŔ@8˝ŠˇˆX@QŁőŻŠť?đŔ@"Ŕ‚űÄ@Q*W’Zď?đŔ?Ęu@Ü!@Q$č?đŔ?a H2Ř@Q:HĹí?đŔ>‘Ň\äě“@Q 0xe3?đŔ>×&6Č@QŽî™ěŘ?đŔ=łÝŢ&)@QĐ3™V?đŔ=%>úŕxä@Q)rI?đŔ<\­ŮŠž@@Q(IǛ8?đŔ;¸M–MĽ­@Q!‚Zm÷?đŔ:řq˙Üb$@Q(̔-Ú?đŔ:;Ľ+–gu@Q/,Ŕ  ?đŔ9˘Ąf,E@Q<ÇLyŕf?đŔ98‘Ü"@QIsśťň?đŔ8˘Ą>ţŻ+@QUÎ-Ašď?đŔ8şľrĂÍ@Qb Ź2K-?đŔ7y(ťÁœÁ@QpKT^TĹ?đŔ6ć ěĆ?@QyŃn’Ýç?đŔ6}¨Vœ{@Q„ţpâăž?đŔ7ŽŒÝL^ú@Qˆ&óɀP?đŔ8qLuÎ'7@QEN Š˜?đŔ98Ŕýü˙{@Q– šô(?đŔ:ÄP?g@Q‘& ŔYÇ?đŔ:Ţ%E‡>@QF­¸3ť?đŔ;ő”ľcQ@QŘslí?đŔ<žKź˘é@Q†aÁjɓ?đŔ:ý4_'˘@Q’8Ç˝?đŔ:˛—˙b† @Q›'Ś"}?đŔ;ÁÚT&E@QšbœbĆ?đŔ<„šhđ+@Qksň?đŔ<ŕ]]MA@Qž˛pžýb?đŔ<"wâć`@QŤP áx?đŔ;ýf3'¸ť@Q˝şL|Ŕ ?đŔ;ŸÚ‘HŐQ@QÂo ßŇ?đŔ:͜ˇ@/A@Qź¤í%Żg?đŔ:†ŁVCú@QÄSĆ[Ÿú?đŔ9}ë8>ł@QŃăR1e+?đŔ:Ź˛ňĎ@QßgŚ;ˇö?đŔ;]癢}@Qáy#B:?đŔ;×Nál.@Qĺ$‡ŽÎ?đŔ< ŃîšţÇ@Qćž60?đŔ;‘­çž;Ř@QđS`ţ2ý?đŔ<1Ľţ œž@Qütóů š?đŔ!=?đŔ6¨_Q: Ú@RRÜ{zhü?đŔ5ÍĚÁ3{P@RWSVŮ?đŔ5ɧK@R]R‘T?đŔ4wu—ăT”@ReěîXQ-?đŔ4ŽZ‘J@Rw!€c÷=?đŔ5­ŠŒý6@R|¤WÎ?đŔ5Ú.ë˛č@Rr÷oÜ˝9?đŔ69÷Ý 0o@R‡] ‘?đŔ6‘ ĎsĐ@R—ŁníÁ?đŔ5Ž=ˇw@R BŸZ@?đŔ4€Kšü°@Rš˙¨Z?đŔ3§ŢPS™•@R‘+ îƒÝ?đŔ3/h_”@RŸŢTҎ?đŔ3ĹnK0%Č@R¨ôüě ?đŔ4Ă! •S@RŽOgăX?đŔ5ŢÔÚ8@RÁ‰´u.™?đŔ5ÖŽNť˘W@RđͤŔ?đŔ4ŢÂ_‘5…@RĎQˎnű?đŔ5ă–$sŻ@RÝf…ÔŇ?đŔ5ćCG´an@RâćŚëĂĆ?đŔ4ňBŤ+ĺŚ@RםĐ|]ş?đŔ3ĘŁXöŽd@RĎšýn.Ž?đŔ3iFHԅ:@RáŹj-ľ?đŔ3›ŰéŸ?—@RňśÖĺ:I?đŔ4KuďŽě@RüŻœ(ě?đŔ5@]ŕX.@R˙2„ ˆŹ?đŔ4ŇĚj@S bĹ Ą?đŔ5âŻú¨Ť@SzďĚ7.?đŔ6CTłn@S! ˛{`?đŔ6 łÍ—@S/nżgý-?đŔ5rmü@S7öl×g-?đŔ4ü™Ýs@S<ăľ|Mť?đŔ2¸™Ë¨‚Ä@S4Ť|:ˆt?đŔ2'Îé•Ő&@S@Ŕ’=A?đŔ2ź¨ăţ ď@SR§wáĚ?đŔ3Ň‹@SWtB1?đŔ4Œx3FÍ@Sawń`ë?đŔ4ŕž„Ś@Sl \ŮQp?đŔ3\B֑@SmĚo˜Ł?đŔ4㒯+ű@SzÉ&CI?đŔ5Şî!|MĘ@Spép;?đŔ5y—D[Fˆ@S‰¸0—L|?đŔ53ŢR1ń@SœôˆfYŐ?đŔ5X“Ł’@S­ŕ˛Íß_?đŔ4 ˝çS` @S˝ ÜŔ?ó?đŔ3~â[ň@SĎÇŐçQ?đŔ3¨Ő-őÇD@SâłŢžÇ?đŔ2Öہ‰…%@S𲣝 a?đŔ1¸"ŽRT@Sü$ ć~?đŔ2I†:AÚ@T`Isnó?đŔ3ӂ‹qťś@S˙ôąďń~?đŔ4`˜ ‡ú@Sú¤nŠ‡?đŔ3‚ĺ¸˙”a@T’âx I?đŔ1Ž,yţĘÖ@TĹc ç?đŔ0…Íós¸œ@TŠ\tŐ˝?đŔ1\Šý@T%\˙ľ´g?đŔ2ÚltŽw@T$óź!ëś?đŔ3ö ;6@T'_–?đŔ1hœí÷p@T0O&KӍ?đŔ/4ľFÖ@T4•YąZÉ?đŔ-tłż = @TCôÍ;?đŔ+$řşĹ@TR}TŽAv?đŔ)¤+8@Tc­ţĐĹş?đŔ*÷ôĘ'ůW@TsŠË{Ĺ?đŔ.¸E:3B@Tzb×q,?đŔ1Fů†>@TsóŠ˘Ďl?đŔ2VĽđˇh@TbÂĂ°E?đŔ4OB§Vz @Tc=nć™5?đŔ5Ť…ĺĘ@TSžKO@?đŔ6˘Q í @TCš„“?đŔ7PŻg@T3˙] †?đŔ8mp|@T,ÍĘš?đŔ7HĚ)ÖĐ@TE[•“9ž?đŔ6œq§:Řp@TU\pÁŇ?đŔ6üs”ż@Thţîś7?đŔ6 şżÂŃ.@TzŁ˛\Hż?đŔ7[žaQĹA@T‚L„Ÿ=Ü?đŔ8LÝ*–@TqôؤD?đŔ9śĽ$DŢ4@TeVv8V?đŔ:ĺ$ƒ´’@TaÍlR/?đŔ9c\Ř–$@TyüJĘĎ?đŔ;$ŁG›‚i@T?ÓĘ?đŔ=SĚh–ż@T|yđVŰ?đŔ?0¨t¸"@Tv˙?ú Í?đŔ@)ˇ!BŠ@Tu—Ł´o?đŔ>e7]Ş˝Ý@T‰Ł¸‹ŽŠ?đŔ;áů(#< @T‹>÷aKl?đŔ9žÖ.ĺPZ@T‰ÔăyŇ?đŔ7Ń) ŻÓ@TŃ#çÂË?đŔ6$œž ł•@T›fŮvĐ?đŔ5ĘQCśeH@TŤ'13|F?đŔ7łřPóťŠ@Tľ0–dą=?đŔ9.ܟpkŁ@Tše‰y?đŔ:B)ŻŁ@TÇ45@˘3?đŔ6Ćšn@TÄĚ´X.?đŔ@IŸu †Ô@T˝]üŔäç?đŔA#ŽlHÜ@TşĘŇžŁD?đŔ@ąŮ'˛Ŕ@TĆ<śĹ?đŔ=ę|qďť@TĘ7‰5S>?đŔ;jč7Š•%@TÉĹ?ÝľŘ?đŔ:4PťA2m@TՕĎ.1O?đŔ<œHŤî@TކOŞ˝˜?đŔ>ţűřć B@TĺyĚń†s?đŔ@ágƒî ~@Täf?đŔBíŻĚx"@Tŕ lĽ2?đŔBŇjĄÓl\@TŰ5hş!ż?đŔCHfŇçÍg@TŃlÎsb?đŔC‡Đ›&@TÄş~˝?đŔC¤čŇwę@T¸˘Ď¤K\?đŔDŢ´6$Xƒ@TÉCŕčťË?đŔEžfęz&@TËz7{€?đŔFšűŻ„é@TŔ{ ţą?đŔFÚ­ů;ßô@T¸p /2,?đŔEłę+ôs@Tś1bŸn…?đŔD”ąR´:@TąŮëBˇç?đŔCôí&e@T¤čk|“?đŔDÔfű‘@TŸő“Čkö?đŔDî)†´T<@TŠ˙)ä+?đŔF.çhß:@TąŚ $0?đŔF™ˇř9@TŞY#­A?đŔEřŽfSƒ@T™Í.AÎÂ?đŔEԖ˘•"˛@TŽîĘÜ?đŔFIęëě:ú@Tz˘CĹ]â?đŔF°ĐłŰŞ@TvÉD”?đŔGR"7*Ž_@T†¤R-Ţ?đŔHh=8O@T’×ęČ??đŔHâ…>yŞ@TŸriÚŠ?đŔIu'W"@T˜$(Uý[?đŔI$óRĄ/˘@T…ěBŹ÷@?đŔI('uĺŤ @TwX%MJ˝?đŔI/ˇŻ5œ,@Tn*łY ?đŔJH‰ÚŸP@T{´‚Ĺ=ź?đŔJˡÓ-ž@Tmî¨ŕĺž?đŔJäď–9Zz@TŒŚŐV¸?đŔKŁąůľ@Tí¤Ä K?đŔL{qžp„÷@T‹ÍÖR;?đŔMo@tU†‡@T€"%N?đŔM śÜV-@TmFěŰé?đŔL^î;@T]›Ý-pą?đŔL‰žŮŚB@T\09žÚe?đŔM1•+ŤľY@Tję䘼ă?đŔMҒ谀Q@Tyc×TTK?đŔNœ˘0Ś¸ @Tp–;ś…ě?đŔNƒjÜ@T]{ߌbÚ?đŔNÓ çP‡ž@TJÖŻ`˙?đŔOĄËh#đp@TEÜžŘ?đŔOÉÂgŻ˛@T={~Šń?đŔPYUp›Oq@T/îŞ[´F?đŔP˘J‰q5 @T"űÁSę?đŔPŐĹĐ ëk@TfŽ?đŔPš¤ŮŞJ4@T_8+?đŔP2iu1U;@TW@í?đŔPĚGbh°@Tgžżńi?đŔP@x?rn+@Ső$2‡ ?đŔP; vóŔD@SâÄ`~(?đŔPbbŞ>´@SŃŹŹ{Ä6?đŔPŠŃăđa@SČvŠë?đŔP˙Œlsý@SÄV?Ľ C?đŔQI„ui€@SˇĘÚĽOř?đŔQŸXTŤv@SŹ…hÄŁv?đŔQîę3şłł@SĽŰůťük?đŔR)<ŢĘҧ@S˜!WÍ#§?đŔR+¸JS­Č@S‡Ń7]ó?đŔQéR§čî@Sxe^¸?đŔQ¨3ӎ§@Ssš S ?đŔQ„,ZÚÁď@Slʔ” ;?đŔQiĹâ+ń@S`CâŞ|?đŔQďłęäo@Sc–š ?đŔPË”Ů[@Sgm„ËČc?đŔP–ůVyá@Sf1aëĘN?đŔPŁœ‚);@SVXŕ–=†?đŔQv1BěI@SWŮ ˜D?đŔQvgúV@SOE'zkM?đŔPśAžyC=@SJ¨aßn¤?đŔPŽv8nL@SI×f˘?đŔQš`ZxJ@SK€Żăôľ?đŔQ\9ŞB@SMáâ?SŹ?đŔQŽ°LĽ;@SK{S›‘?đŔQÂô%Ž@S<äŁúăŇ?đŔQ‘ž™@S6ô0V1Ľ?đŔQu m Ôe@S7ŹzK„^?đŔQ=č4 ó@S+1çżłě?đŔQ°Üř @S%ń&źˇB?đŔQS&’Ěx@SŒ6~ă¨?đŔQÚÁĹ]@Só@ŽĆB?đŔPÍâkţ|@R˙ƒ´śg?đŔPľŸ ƒ„Ô@S%4”ë?đŔPŠĐN^ţ(@S #ŰŃ?đŔPq…kBŽ'@S bř—ţî?đŔPCŃżČěÝ@S-ţ`!?đŔP 0üI@S–¤š?đŔOsâ•äź@SišźŠ?đŔNçăTŠü@S i#ţ`?đŔN[; C>@S|iŢ?đŔMßS˛}ČJ@RůtÎúŔ?đŔMo5aŽ^ż@Rîţ o‡s?đŔM+5`žŃ1@Rŕ6 ë˙?đŔM+=!/Ę`@RÓv Ôţî?đŔL褨‚ĺÝ@R‹RŒˆ?đŔLĂ#Č­?@R˛+ŔĆ?đŔL;9:'>@R ˆË"ý:?đŔL>{Ô8ĄÂ@R“nç{‰š?đŔLLŠˇťh@R‰~–jW?đŔKóŸťZ`@Ryć 1Ö?đŔKčMěă@RjČçŽ?đŔKĽ‘ćc…@RUý5]ň?đŔKĄ |Ý_@RE foM:?đŔKZcĽĘ˛Ľ@R27Ťíg?đŔKiy˙Ą÷;@R"_Hu?đŔKAkçI@R‚3?đŔKzĽĂŒĂ@Riżă*?đŔKxÉ:K‘@R‹ďkqw?đŔKËÍ­˘@Qî%+ý?đŔK¤ĽR7ŠŸ@QÜ[-Ą”ň?đŔK@A0ĺŠ@Q×á¨ę°Ł?đŔJűB?rH@Qä 5ˆÎ*?đŔJے<‰Ë@Qď-ěx‰?đŔJÓŇôĚo@R&Œ%ËĎ?đŔJŮŐV€cP@R2˜?đŔJ‡e\ŤŞ<@QöşAš¤•?đŔJD?ă@Qé¨9vÁ?đŔJ ŇÂęYq@Qç ´ŠÄ?đŔJCŠÍnYL@QÚO¸ýb?đŔIě{Ů鞓@QÚ°Ľ\‚u?đŔJyNQž @QĎÄwˇň|?đŔIě°ýO@QÎś}OÜQ?đŔI鷍Ä. @QÇm'=Űy?đŔIłá˜:Ę!@QŔÁÚĂ%Ľ?đŔIƒŮƒő@QŻýKz?đŔIpx“łzŰ@QĄ]j˜k_?đŔIyŹHžžŇ@Q—NĂĆů?đŔIßáŁ@QŸů˘t?đŔJ6^śÄĹ@QŤg‚- b?đŔJĄGăňBÓ@Q°öeĐa?đŔKů‹ŮÍĆ@Q˛ŰýŠšĎ?đŔK5ŚĘĚ]@QŚŒirË?đŔJçĆďľżż@Q˜ö,Ă|Ľ?đŔJ€ Š|öI@Q’ôP?ă?đŔJ,H'•§¸@Q†<ţô-?đŔIÇ"vYŕ@Q€‡Œ1PŰ?đŔIuFcĆş°@Q€ž}6Xi?đŔI0RńÚĆś@Q{?äx?đŔILZ¸8}@QkYٕ>:?đŔIU_…ô?Y@Q]_T˝Çm?đŔIHP2œť„@QLÎ^ƒt.?đŔIMăźčŐ@QAÓóϜá?đŔI.íĚ˙œ@Q4@˛ł?đŔI’¤ĽĎ'ĺ@Q&˝™ô?đŔIü]c‹ű­@Q#K˘ˆf?đŔJMeXă,´@QşŔ} ?đŔJm=9"}@QöđvŠ?đŔIö6´7N @QPôÎŕ?đŔIŽsPÓăâ@QÔ!*n†?đŔI‰.GF0d@Qď8•"€?đŔIˆkˆý@QyëÇM?đŔIJěqąóŒ@PüřĆá­t?đŔIČŢ_˝†G@Qu˘ ?đŔJ$Œ(„ú\@Q˛ń_V?đŔJc8óëŽZ@Q č¤\Ą?đŔJ’㑤}ť@Q~, Š?đŔJu”6‹7<@PüKN?đŔJÄŇúr @Pď÷ÂÚö?đŔJš*<ŐN2@Päţ›jš˝?đŔJa4­ 6…@PňîŹn?đŔJ 9ł˝1q@PůšL ÎY?đŔIĘÓÂŰÝ]@PőĚGŹ_?đŔId÷ĎN@Pőďł<ŒÄ?đŔILŞÖÄLŚ@Pó1ś,˙?đŔIuE…ąsl@PëUě ’ƒ?đŔI1 YU1@Pć(FwI?đŔI~€Iőj@Pĺ8G¤“o?đŔIŐĄžóTI@Pę9pqŁ?đŔJ4Ą;Z`@Pď`kŽk?đŔJzęíŇč1@Pęo ŹQ+?đŔJ՝Ůq@PÜZˆs$ń?đŔJĆOŸť#@PŃF‹]A ?đŔJbȨ|Ę@PÔöi›<Ę?đŔJA?ôUˇ@P×é ö:?đŔIŽáąńa@PŐ\]ů§?đŔIgšÖŰ\@PËűuęZa?đŔIZö—Fţ@PĘÝňL_?đŔIł˝t9Şo@PĎ7HÇYÔ?đŔJ‹p0ßá@PÖ8 ďT?đŔJbĐg ÖÇ@PҎdđ [?đŔJżžM݀×@P͕0Š,?đŔJŐŞŞÇ=@PÄ34vĽ?đŔJŁAŤqk)@PźžŐŃc?đŔJFz”gĚ @Pˇœdő˜Š?đŔJ€˜ö:đ@PŹ \Ó.ţ?đŔJu şuP7@PĄĽ>­-?đŔJĚs’0ŚŐ@P›‹á§k?đŔJą› Űچ@PŒnćÖÉx?đŔJXť)J !@P•ńźáY/?đŔJC—}ő@P˘^ęšź?đŔI՞×7pą@PŻôČßLí?đŔIŒ,oßĎ@Pť˛1Zâ_?đŔI61n)@PÁ˜šwP;?đŔI.YUnÍ@PżȌt?đŔIh´žĹN@Pˇ"čjľé?đŔIÉĆąOŚŞ@P­”ĐřJó?đŔJ ůˆ.ł@P ăß]‰?đŔJT*ÝĎ'â@P”*Zcć?đŔJ–đżŠ5Š@Pˆ ­U?đŔJ–.Â@P}…]KŃ?đŔJ?ĺfŞĚ8@P}5ôHFË?đŔJ *‚aśr@P}?ŰčZ&?đŔJ„Aę ăĎ@PrĚ‚z.?đŔJbüc„Ű’@PjMˆ]č?đŔJ;@ĺţËa@P`ŢÜ9‹ž?đŔIî6 Š*@PiWśOŕ h§@P2|ú¸6+?đŔIf#đ5Ŕ@PD×ă?đŔIúň@P0\ę/[@P)ç—p—?đŔIRf›úÔr@P"(śáDH?đŔIH5Ríy@P‰íŻ?đŔI”˘ań÷”@Pe {‡?đŔIž2pŇ ő@P >řÎ:’?đŔI\9őółş@P Y­]xJ?đŔI.ŇÜĄ°6@P ‘‰úš’?đŔI çZč‘ţ@P”KFóę?đŔI°•ńš1Œ@OôފӷŮ?đŔI—ˇ[Ž;‡@Oě.s?b?đŔI´ěi‘-@OŇ@{6ŁH?đŔI‹‰zÜL@OÎCßDg5?đŔInrˆßĹR@OĘŇۜŤ-?đŔI2“eŽ‚@O´dŸ×Ď?đŔI\ľ-+r@O­×}ˆ?đŔIkÉ_÷@Oš8ŐńK?đŔI/ĎÓÉË@OŠ;Ő3!/?đŔIÉcˇö@Osƒš‘í?đŔHüŠCę@O|=K•j?đŔI4ÜRô@OaŇoƒs‹?đŔIÜ @O5Ŕ—"ô?đŔHŢzßʙi@O$ Ś“Ň×?đŔHžóümkC@OMż›7 ?đŔHŻßá>ěx@OÉC‘Ü˝?đŔH˛ƒ”2@OȤ˙j?đŔHœúuX€@NëŐÔi†p?đŔHyßX"WÉ@Nń6wÎ2?đŔH}˝BgZ@NΧǧŮ?đŔH=Č9]6@NŸ°*$?đŔHB:vLí˝@NŔbŹť?đŔHSӗ¸ž1@NŤÝFŽ o?đŔH%ď0+ ×@Nšwą˜Ă?đŔHŮp@N•vpťƒ?đŔHFiy @N}0:p/Ä?đŔGűH_dˆ@NjĚúY~?đŔGĂ ó–',@NqDc§/ć?đŔGiî&x˝@NssŞďúü?đŔG#†|Ój@N…<ă’3?đŔFäœŞ€ @N„Š?đŔFśŠ†ŕňW@N‡Ŕ؝Éú?đŔFě7ěű,đ@Nk˛%Nä÷?đŔFžlŢÚí@Nj4ámţ7?đŔFŃb¤ćö@NN—¤ţ{é?đŔF§21Ún@NNp‰2IC?đŔF˜őí=Q›@NE`â+o?đŔFkřÉîéę@ND×ëd˙v?đŔF}7ý+F,@NřV´Ľ?đŔFRĺ„ ĂÎ@N/ĘŻĽÜ˙?đŔFi!Đę/Ă@N @Œ…¸˛?đŔFyuEFQ@N 1dœ,?đŔEŔŹŰŁf@Né;Ż5‰?đŔE–É{¨@N ú?đŔEźŁÜȓÓ@N4™ß ˛Ľ?đŔEć,ÎnŠ~@NK%ŽXŽ?đŔEˆlmœR@NFľF˝#—?đŔE€>Aŕ>!@NY1r˙(3?đŔE”óĺ6§-@NnQ“aj?đŔElŔ¨CA?@N„7Š^§h?đŔE™‚–ČGm@NŽĹŸ —Ŕ?đŔEpűZ䡣@N•!–Áę?đŔEpŠćIE@N™ż‰y/?đŔEgÓŔc?Ş@N˘ Ů <†?đŔEn୑9@NŠ‹lj[?đŔEMR¨ŮŒe@Nźşc0eV?đŔEW-b–;Ü@NĘbăvsp?đŔE?ąźđ&1@Nڃ–׏?đŔEJcÂŕÂ@Nâb­Î]?đŔE*Š˙1@Nú˜›0ű ?đŔE.´šQH@Oƒ2b­?đŔEEVłQ§=@O<ť €§X?đŔEY×BÉü™@O_Ř?&ó?đŔE-×F,É@OmcŞ˛so?đŔDĺŒpŽây@OzdF˙&?đŔDíhú@O#>'=5?đŔDÎXKź e@OĄżÔÄUż?đŔD̍ĹáŔ@Oˇá^4H?đŔDŽćŠQ¸4@Oš­kâ?đŔDŽÉ÷ÎL@Ožr¸Ÿc/?đŔDsEĄő`@OÎVqůI?đŔD›Ě$=@Oßń~˙?đŔDNś–)9‡@Oéi` ˛ß?đŔDhĹXÝÍ@PĄźĄ—?đŔDĽô…ďĄ@PVŐf¨?đŔDG2/toÍ@PNěpJž?đŔDh÷qH°Ŕ@P1‚ łvŮ?đŔDzbq`@@PA÷+čDb?đŔD+ŁŒÍá…@PD}„“?đŔC÷×/Rco@PM™ůÎĎ?đŔCôW_ŕĺ@Paľ ˙ü?đŔCŤâ+`'a@Ph a5ę?đŔCSAšËřŒ@PhejKő?đŔCD6—Ë@PpąeŐ;§?đŔCwq|‰7@Pl:o[?đŔBô–^5ň@P’TÔ­‹?đŔBĘkHíÍ @P–ÉżcíĘ?đŔBľbŁŹf@PŽE ҄÷?đŔBÚD˙Cú5@P} Lšctc?đŔA×J˜Ÿ#@PŽѲ‡ŔPÇq ĄŢď@Qś= GŃ?đŔPâÖC›%@Qˆü(Ҳ?đŔPËăč˙20@Qčü Ţ?đŔPěˇB†ä@Qsŕ?đŔQ!J7˝uÍ@Q%nćKŔ?đŔQp´%@Q)m`Űß?đŔQ:ĂŐ"ћ@Q2—NôœŹ?đŔQË-ú@Q58ŹÓ^.?đŔQće–y@Q?÷?ÝGŃ?đŔQ2'ťhlŸ@QGzuƒ˛ú?đŔQĆ"çź@QNFŤră?đŔQ7­K@QSPK,ظ?đŔQ$ŸšÚ¤@QTo 7}?đŔPô' ô_ä@QMŔ ĺ?đŔPŔaoGšë@QJž19}&?đŔPˇ@šÖ„ô@QV˛?đŔPĺ ;¤áÓ@Q^]\Nö?đŔQ˙˙ĽL@Qb-Ŕ”0?đŔQ`9LW@QbSOő?đŔQG™3Ö@Qd„>žL ?đŔQňŸPŸ›@QkIZőşY?đŔPŰĽ´oŒÝ@QpZzě@‘?đŔPÔ pcD@Q~Úˆiâ?đŔPő%Ž‹$@Qu–Ŕżź?đŔQTúĐŻÁ@Qˆâx9CI?đŔQ5žfä=@Q|xďś#ć?đŔQmĎßÂÄD@Qo‚Ęô}ú?đŔQh< [Ȕ@QtS,•„?đŔQ:u.ŸŹá@Q†TŽÂ?đŔQ^e—Ľžm@Q‰xaźa˘?đŔQ„úçÇP@Q{Ű’żű?đŔQ„¨œU=@QżuŒńt?đŔQfůy ĚŮ@QŒ´Œ˛ ;?đŔQ/lßčôŁ@Q—`Ş?đŔQbce#/@Q˘šąă>{?đŔQL<ĘÎ,0@QŻ‚ć4Ég?đŔQ‡M.Łą˘@QŤ1.éQ•?đŔQľ„=ćÉz@QŠ7š`Œ[?đŔQәÄ'Ě@QŽtM€Š?đŔQĎnB•ô‹@Q™SÉäÎ2?đŔQčp^Co°@Qœ/J?đŔQčđXŰ@QĄÜžü0?đŔQ˝XĆ@QŤđ’‹l9?đŔQŠPąSă@Qż,ţ4Nƒ?đŔQÍŤŔl´@Qź‰@?~?đŔR:ŤöĚ8@QąJĘä´?đŔRÜĐ÷~n@QŔL;ń Ç?đŔQŮGjwĚ|@QÉŔ Ke?đŔQÚŇ JęO@QŰŤ7Ö?đŔR •%‘‡<@Qćƒg[݌?đŔR1?{/DŢ@QßqkűŁ’?đŔRXB_¤O"@QË.Rí /?đŔRfŕćX<@QŰ/-é[?đŔR‚›q#M@QÔéŃ@żH?đŔRˆ 7Š @QŘEXsĺp?đŔRqŹ‹3~@Që˘TÁ?đŔRŒăԝ@Qę>¸ă‰?đŔR´|ˇA@QÖ{É"KČ?đŔRźp•K$@QâU•ş&­?đŔRÁďĚ÷#˘@QělŽż7V?đŔR‘´n§Jć@Qůcv¤i?đŔRŻ02ž}@RhWO—?đŔRë˙$ÉëĽ@Qő}Uw¸?đŔRŕ6!i5Ň@RڒŃÎĄ?đŔS $Â4Ç@Qţäl ?đŔSňUP9@RąÇţ­?đŔRŃđva¨Ł@R g'Ž_‹?đŔRÉËŕ˘-@R>˛X??đŔRüäË9Ńđ@R#áŻ&Ű?đŔS/K;ҨP@R+ń}›i?đŔSk1ŇBʓ@R.0gMťŹ?đŔS›yË yČ@R"5Áׄ?đŔSf}÷¤&@R p#ą)Ę?đŔSœžÚĺŒ@RáKţ?đŔS†…¸Ž=:@QůZÍÄXŃ?đŔSŻ ě-ăš@R˙é \?đŔSŔŠK–`ş@R ŇAkVż?đŔSć‹ąĂ@R­°—­?đŔSţZű¤}@R(‰y­€?đŔT#—|~Ü@R˜jDäţ?đŔT8AKżŘË@RťŃĺ4(?đŔT4 qüz¸@RiŽ`˘Š?đŔTHż†‘&@R0ĺř ?đŔT&öR›¸@RBˆĐž\??đŔTE"â(Ř5@RR Jy?đŔTSÝ6,Ÿ@RdyQ‡Ż?đŔT€ zľÇ@Rn@kít?đŔTŔ•Ôźv@RkŁŽĽČ?đŔTó0ĄŹ@R\ż–ÖŹh?đŔU)V|mB@RU$˝šöA?đŔU3Ř,<ń@RE˛˜č3Ä?đŔUJYź9…˜@REÄŰ4Ý?đŔU&ĆĚQĚ @R8”öe͝?đŔUP˙ )@R;JÍ~€Ž?đŔUkPƒÉ‹¸@R-ŻĄż”/?đŔUN}ú ą@R„ŘRN?đŔU";n˘ÝŸ@R T]ůh?đŔUIXĄś!@R[jn`?đŔUo]ň$ÎŽ@RŐ]ǖ?đŔU^şĺr#@QňénĚĆ2?đŔU2;Ň) @QçŰdWő?đŔU-1Qʌ[@Q֜să?đŔU3ť?|ö7@Qž3†‚?đŔUB×4‹mŸ@QÇd \?đŔU‘B´ó@QÂă~ݞÂ?đŔU|Fî˘gí@QɉÝ@ǃ?đŔUIg!Gó!@QŇËü<Ľ?đŔU_q…G¤@Qâ& $Ş?đŔUƒśăżž@Qń˘\{†:?đŔU™|ĽEβ@R݈ężË?đŔU–8:­+§@RnÔ¸u?đŔUŁ‚t’đ@R&ŞěĽ&{?đŔUŚ[zć@R8€ŢŹ÷?đŔUŽĂk”bz@RHřaô'R?đŔUröTĹ÷÷@RZwů•î?đŔUGcy'Ëę@RhD+O‰?đŔUTŞo0ŚA@RsďT™ŸĽ?đŔU—8)c@Rvz!?đŔUÖ¸ua#ą@Rq#d֝œ?đŔV #˜˝Ă@Re˙ ‡L?đŔV2wÎGĎx@RTÝxq§?đŔVLˇpš@RF.0Í]?đŔVZdý¨‹ú@R3 V’¸Ÿ?đŔVoˇoD÷X@R"˛ ö?đŔVtÇŽ]Gó@RáĆ>Ö?đŔV|ÖŽm<×@Rą{$Vě?đŔVzđŚˇîë@QíĘp|ü?đŔVyÝúp=i@QÚ٢ÖĆë?đŔVI‹˛ÚĚë@QŃÖŻĽ´?đŔV 9—ĘŠ*@QĎ+÷ĚWŤ?đŔUÝ ˙Œz@QÂŘÉh/?đŔV6ď„/@QžĘ×ĆđÍ?đŔVO%8 Đ@QÁQ3§-–?đŔVO CČô@Q°Ĺxľ&°?đŔV0Ýç G@Q ŁÍŻ?đŔVćT´p'@Q”ë“ `~?đŔUÖd ×HÍ@Q”čIš–:?đŔUŽ? ˜G­@Qšf0ۧ?đŔUŸçžNI@Q–¸Ž>™?đŔUŒą5š @Q††*W@Ô?đŔUau„ôbé@QƒMĽ/†l?đŔU+ĐÍ[ @Q‚*@Ř-?đŔTó7đ@[@Q}ŔHŞŤj?đŔTžv­&m/@Q}—4˜Ź2?đŔT†{¨}ťń@Qv“–˝?đŔT ţE˛bÚ@QŠƒśëó8?đŔT‚Ö`}Ë0@Q„Ô„ă-Ş?đŔTK ‰(+@QuwˇţÂ@?đŔTZlőö@QĚ¸Npt?đŔTBPÎţ’v@Q„Ćľ ž>?đŔT (rľěŠ@QiĐŔëŰ?đŔSß-3@Qx[R­)Ń?đŔSŻóƒłęJ@QFŞĆĚ?đŔSĆY‰/ťş@Qž{s;?đŔSŁúŠÔA@Q•qşG?đŔS|hş#ŕ@QŒŒçÒŇ?đŔSjŕĄYšÍ@Qx%ńI”?đŔSY(zÁ8˛@Qv(ťŢžŰ?đŔS?ŘHV@Qrvf“¨ˆ?đŔS'+fý@QgáĘ;‰0?đŔS [ŁƒŠ@QYšhľşu?đŔR뙁Ož@QJ‰-—Ó­?đŔS3­(lc@QAq)Ŕô?đŔSH°h4ŕ@Q14€pż:?đŔRé‘Ą#@Q:3í•VÄ?đŔRźNkÔą@Q=éMgí&?đŔR­Öâ˛3@Q1ÉFÝeË?đŔR…K:?šü@Q&㪎ěł?đŔRröbpn-@Q#ÝcƄ?đŔR_k_2´@Q.Ę#äŘ?đŔRB_}s Ţ@Q 6@ȍ?đŔR3jY$ŹF@PřBv„Ô?đŔR"Cłayy@PćÍ4’`?đŔRĘÉ:\@Pԇ@(Ë?đŔR#PžĹ@PŤ ŢzŹ?đŔR:ŁŘÖ@Pľdž c?đŔR]1¸Ţ‡@P­2âFýß?đŔQäň3Z˝@PŠä ýš?đŔQÄúzÇÚ4@Pźoeib?đŔQŁ+‚¤Ż@P´'7ńƒ­?đŔQ~dĚłř@PŤĚ-Imw?đŔQ\œ*g@PŸ^ź‰ e?đŔQgf[Ź@PçG†Ő?đŔQšŕ“ @PŮP[: ?đŔQĂݛ°ßí@P„Tžű°“?đŔQʌ×ŰHŮ@Pƒ -,?đŔQ×Ŕ…VB@P ôv~ŕ.?đŔRš¤şn @PŞaŇ#]á}ć@Pş?RWĐ?đŔS>#ĽœR@P5_Y?đŔRő:Öę5B@Pâ 6Q?đŔRÚFFÍ[@P °BÁ#j?đŔRŹ„†]ÓÇ@Pí =ś?đŔRą)­Á@P1™˛Ę„Ť?đŔRĽ°íëţW@P1k˛Źľm?đŔR†wź*Ä@P"ţ1ÚRî?đŔR^#Wüü@P%x'xÉx?đŔRTŮŞű=@PĐŞ‡űC?đŔR>@Ťá?@P ĆĚşÝX?đŔR"ńżŮOF@Oőœ¸CÉ?đŔRL9žöI@Oŕî >Ń?đŔQá4ýiœ@OŇEŞ kÇ?đŔQóú§Îߘ@Oś•rČźú?đŔQë‹Rßi @O›áóÜć­?đŔQÄƋ~Ü@O‡ý˜{ă?đŔQŹZ+œ[@OqöcÖňt?đŔQ~Ý@ma@Obm ‡w ?đŔQ_LJHŞ@OUśýýT;?đŔQHč@ćŚ@O8WŚčڊ?đŔQ(cë¨Ň@O%é"Q/V>?đŔPŠSžŘö¤@O™ŻäńÖ?đŔPĽr9Ą™ľ@O™Âx_jŸ?đŔPˆęůF‰@O‚\ĺťŔ|?đŔPh0; ˝M@Ot6ů\?đŔPO6ĄÖOO@OY&úYŽÝ?đŔPCljő"@Ob<ÉĂŚľ?đŔP;ÍžŰĂS@OzéEbËé?đŔP>ĆVÝ×ü@OŃü7m?đŔPG:ĐŠ|Č@OÎde—ě}?đŔP+ŞaŽ}@O˛÷€x?đŔP#lĺmóG@OÎMéšń?đŔP3Šě(z?@OńüŞT†?đŔPFůţd l@PEmњ?đŔPTż(ň6˘@PŕîęB?đŔPd^0D@P#?ŐÚR&?đŔP|,šň@P1tCÇ]?đŔP¤Žŕ9@P:y`ÁIk?đŔPť:Ú­˙ˆ@PGöţŽ%Í?đŔPĐU–ŚşŠ@PZiżTł?đŔPěx=—te@PeńÍfź{?đŔPţ<Úî@PoźSĘĂO?đŔQýxŽ@P…łČž˙?đŔQčXň@P‚E†öJ?đŔPâ˙Ű­ÉÂ@Pz‚Sťć„?đŔPÔ5 s:2@P„ÚXű?đŔPóSľ IC@P˜ĹˇZĐ?đŔPÜc28–@P–‰’-v?đŔPŮ)´ń@PŸ+sÎ'”?đŔPŔ)Ź_Ý@PŁPŹČˇŻ?đŔP˘ @P”ö›4ďş?đŔPtéŘkś@PCŒo›?đŔPt49u´Ť@P„ă@|ö?đŔPZP”[Pţ@PĎvöre?đŔP+U_–ˇ@P4ô&š?đŔP2#•%’@P…<Ľ?¸?đŔPTž7rj:@Pwž(MŐX?đŔPFÖs8}@PizIÔ$i?đŔP?+ůŽB@PaʜB?đŔP'ć*‰ž@PTN|ôâ—?đŔP ŽRČD;@PJCyˆH ?đŔOŢ;űtݕ@P@mEˇíĽ?đŔO¸u6C I@PC=[jŤč?đŔOˇŽ(ĽĎ0@PUgôŁb‘?đŔO˝Aƒ’!@Pk6pzăT?đŔO~ęöřÔ@Pj9%Ÿ?đŔOUŻFp6@PpĄœ?đŔOXtbď@P4P.UK?đŔOqQ}Ś@P‚Đ=*Ś¨?đŔOIŽč ç%@P’Ąňž˘˙?đŔNđţC9Ş @P–HŸţ=Ó?đŔNëÔԗ=Ő@P ăŮ'ň„?đŔNËÎú "Ž@PŠi֕B?đŔNîŠVף@PşCŁQ]v?đŔO0Cć¨Ůp@PšbĐx9Ń?đŔOf+ďCi˘@Pą—Îa?đŔOqŰv ó@Pśçžœ˜?đŔOˇőE Â@P´Ť1ţ q?đŔOž]ńâŸ@Pš\ëĎ2?đŔO”Ź6sË@PÍÜě{?đŔOĐ)K§@PČš´Îj+?đŔP˜Wƒę˛@PƓžžię?đŔPó%]@Pτo¸˝š?đŔP ĚýCÎ@PÚ'ᡠ?đŔPßćůţ¸@PěYîJß?đŔP9]ÄůË°@PďNˇ*ř?đŔP@ؗ &ö@PůŇţýo?đŔPYE&4ó@Pń,šÎĆĆ?đŔPa…↣@Pöůiڜň?đŔPx¤ë,Pá@Póčá<„?đŔP|h^@ʲ@Q WĽ\ě?đŔPŢŒ@|Ü@PúHČ6OŒ?đŔP˘\GpŘ#@QŰ7 ?đŔPĘ/ŕ2ňŚ@Q k­Ä?đŔPÇq ĄŢď@Qś= GŃ@aŁ”‰‘\;Ŕ"fç|&ž´?đ@aŹŻœVěŔ"X”×?đ@aľm÷§ZŔ"oŁÁ—N?đ@ažŃŽ(Ŕ"g˙Ăß}?đ@aČ˃ďŔ"aĎI?đ@aŃďŠŇŔ"”•¸ržÖ?đ@aŮ°Ş°Ŕ"€łř^P)?đ@aáĂühŔĽŔ"5‘÷ëş?đ@aę°KTíĽŔ!÷^„ `?đ@aęäęŻ:řŔ!jžŠ’Žé?đ@aäWInŔ!ľl„â°?đ@a۞”RůŔ Ç[Ćdô?đ@aŇš>ă+Ŕ Ž™Čnr?đ@aÉ šŔ xYÎGż?đ@aËÖ=dŔ xSM(*?đ@aÓů&}8$Ŕ •í!&Z?đ@aÝ39‚ő|Ŕ žá?đ@aćg#CĆěŔ ’ ő&Łf?đ@ađüxëĆŔ oYwíľ?đ@aîúżťóđŔńČłôŃ?đ@ađ8^ŐîŔÚ>†OŽ?đ@aű<2î ŔÜ ,¸Q?đ@a÷Ő­H WŔIX™Ćńc?đ@aű]yDÎŔŠŠgžY?đ@bhĆCŚŔ óŒo€?đ@b ɇußŔżßÎşŒĚ?đ@bźŚČEŔi]Y?đ@bş+ŤGôŔˇč$úę5?đ@b"Ť~ďRkŔBˇúĽŸ?đ@b+láĐ+Ŕ˜÷’Ć71?đ@b5ť’œUŔĆhĹ1ĺŠ?đ@b;ĂűEMgŔ ŞY}­?đ@bCéCu&Ŕ V˝aŤŮP?đ@bHńňrĂżŔ Ô;f¨łČ?đ@bNˆšżžäŔ!PáÔąpl?đ@bRw<-Ć@Ŕ!njU´Ń?đ@b[§…ŕMŔ"*˜ďaĎ ?đ@b^e|jâôŔ"™ŠĆbČA?đ@beōôAŔ"ů™ěÎ?đ@bl6¸dŔŔ#KęLO’?đ@bqžŰŚ}Ŕ#Ěëâ[‹ž?đ@by2ŽĹŔ$"SšÖ€Ż?đ@b‚l­é@Ŕ$?‡UÝĐ?đ@b‹RĂ4ßŔ$U"ťx?đ@b•ÚŐoŔ$Xů†‹-a?đ@bžŚ§9‚Ŕ$—w]‹;?đ@b§xM`Ŕ$Œ°Ăžƒ“?đ@b°"đŠŇŔ$ŽnfůĄ?đ@b˝X‚“äŔ$çš+ÇÎ?đ@bżđiFÔŔ%1łPôJ??đ@bČÚş™3Ŕ%ZnĂFmá?đ@bŃ޸m‚Ŕ%:—‡Â#?đ@bĎ´›7|œŔ$Đ+Gń´Ň?đ@b×1íH§Ŕ$–— €Ţ?đ@bÔ%‡ƒZqŔ$}ťÎac?đ@bËC™˙…oßd?đ@b†î$[DŔ Éb^Í[Ó?đ@aäžÄ4E Ŕ ëńϙw?đ@aۏN7ŔŔ vzZťƒ?đ@aŇŹ č^üŔ Ę!zŤŠ?đ@aÉő)^ŐˇŔţJ…R>‹?đ@aÁƒ‰1ŔJk‘3?đ@a¸˙ <ă_Ŕ4 c•›L?đ@a°š´ĂŽCŔ1†°rĂ?đ@a¨9c… Ŕ>ľ5͟Ž?đ@aŸ6Ô"(ŚŔŮ „Ÿ?đ@a–đ× TÝŔgbŽ?đ@aâĄ„WTŔtŞě°úA?đ@a…]0ĐĂžŔ÷gx`Ă?đ@a|3si8ŃŔď‰u1^?đ@asx.i¨„Ŕ/ÇFˇcR?đ@ak„Đë˘Ŕ)PÇÝX?đ@ab´ŢÜ5-Ŕ+%j˝T??đ@aZ(^guŐżţ˜M¸°Ł?đ@aR I›íżüM†Ţ?đ@aI?bŤ>żúäî ˆ?đ@a@̘=˙zżůhu˙?đ@a8q@Ë ďżř *Œ+‡\?đ@a/á6Y–żůňv–Ľ ˘?đ@a'ˆĄHŞEżü |#mĂ?đ@a%Ł§¤hż˙š|nŃě`?đ@a řÜ r×Ŕ+Ž•Ç?đ@aR]-?űŔŮ°Ć?đŮ?đ@aůű*ČVŔŮł$‚ç.?đ@a żlßăŔ„[{Ă4y?đ@aôĆO ŔFÇu˙‚?đ@`ţ@-ßô"ŔőnÇóP?đ@`ř‹ęŔłŕŹQÚ?đ@`ńľ:aşzŔ ClˇF?đ@`é‡ĂLŔ ˙ëęî}?đ@`ŕŰĆ@Ŕ z?. ?đ@`ŰĆ忘ŔîľJJş?đ@`×ÓIâ?"ŔOwëö`ć?đ@`ÓäBŔ–ćŤ ‚?đ@`Ďnń–ŔtŔ¸.&ćCƒ?đ@`ËtN&é×Ŕč¸ĎÜ É?đ@`ƒ Á¤ Ŕ˙>’wJ?đ@`Ät¸WŮŔĂČEůoÄ?đ@`ĂŁš8n5żüé  Ň1Ł?đ@`Ć&u&UżřŕžYK4Ĺ?đ@`Ç°7x:żôb:”’š?đ@`ÂęÉ•żď U-ŔE?đ@`ŔÁPü,ÉżčßŮ ~jw?đ@`ˇďŐĐĹQżçśĽóJ ?đ@`Ž‚řaâFżçI3wh.Ą?đ@`ŚLmrŸDżâem…Fô?đ@`ôƒÔ)ÍżÝUßćiŚĂ?đ@`• żlűż×ś‰œ+?đ@`‹ż(׶}!şSĐ?đ@`ƒYír™LżŢ쵆AňÓ?đ@`|8dÜżĺDşUž´?đ@`rŁ'W Śżč$9A ŒÓ?đ@`i؆ɠżęԟ|і7?đ@`g&4pżńŃń‚.?đ@``Ű z˝żő;Ezéf?đ@`c1Q*QÜż÷ˆĐW{?đ@`kl'ˆ0Sż÷9÷ŐŤf?đ@`uÄţ¸UpżřrţôřŹj?đ@`|ô;ßTéżůĂrPçřÓ?đ@`~îGWT/żýÁ2ř„?đ@`ƒ*/z‘Ŕ˜Ÿ´ĎY@?đ@`‹˜¨çd¨ŔéU@‰z”?đ@`”ýDcTŔ˝OB˛?đ@`ž@EhoďŔ 4O˛Ö?đ@`§¤Ç;YcŔÉň26ů?đ@`ąJK‡šŔÍýŚ ¨?đ@`šŰŮçݟŔ-a4­Sř?đ@`˝_‹ĆĘŔK-4‚ŘY?đ@`¸—Çďľ#Ŕ[ŞŘĂ?đ@`Ż(ťď†{Ŕ˘Xĕˇ?đ@`ŞŐ$)ŻŔ;$Łáa?đ@`˘˛ę‹ŹŔĂ %~ó?đ@`œ'tÉ÷KŔiž>šZ?đ@`”‡Z“ť^ŔöU×1Ÿ ?đ@aUäX§ ŔlĺŮłÝ?đ@aX˘˝‘8ŤŔ~ů. ?đ@abô7ŁÓŔŸp˝>)ô?đ@a`§ýӇ[ŔĄ?b¤ç§?đ@aUř#`cŔ˛řgąLÁ?đ@a`˙źýđŔżˆőw3?đ@aY”6qĐ1ŔÎГ~j?đ@aYô˘Ń­çŔ;*Ťn?P?đ@a`|PľŔ%׏őš?đ@a_ąŰ×ý\Ŕ@ .F!Ç?đ@a\őHŁĂżŔ MŰaőÖa?đ@aeÚfśŒŔ p|Zz?đ@aiK.1×vŔ Bţpćh?đ@ar57CiŔ OŇˀ(“?đ@a€ËîëhŔ ĽşRŽJ?đ@a@˙3Ŕ zQÁć|ž?đ@aˆÖ‰BŔ áH_Ź×?đ@a˘Ňdö>Ŕ!DÝÄ8Ö?đ@a•tař÷Ŕ!ˇŸ…Ô´ľ?đ@aœI.+zÜŔ"Ş_p)…?đ@aŁ”‰‘\;Ŕ"fç|&ž´@]kŘţ@B6RvŤ˝?đ@]Ž(9KĐ@hň_đÚ?đ@]’Qö?ř@MŢJËbŚ?đ@]ĄĎżAüŠ@čéŔS&&?đ@]ĺKçkĎ@Ţř÷ýŃ?đ@]’Č@͏W‡d?đ@] Ű˘>‡@á@Źtw?đ@]ł$dŘŤ@îâz<ŘÂ?đ@]ÄŮyKœ@OÁěî?đ@]Đcň2§@~5Eą ?đ@]ÄĹëR@ŽĹk‹Ű??đ@]ľ’ŠŇ^@ó“`Ďšc?đ@]Ľ›Ţ@‚Ů#9ü?đ@]•Ţâœŕ@1ÓUĆî?đ@]ƒŠŹ8”Ž@ç8_lXa?đ@]‚ĎA-é@ˆeŰ+?đ@]x‹*˝ŕ@čŞy›Ü?đ@]h5YłkÓ@š&5uąţ?đ@]fJL!éą@Ř虼?đ@]jă¤JC|@ěZؖšo?đ@]iÄ䍰d@ňznč?đ@]Zi†Cr@l šz]?đ@]OUřŚčÓ@r6—kQ?đ@]DSźţÂČ@ŠŐD•Ő?đ@]6Ôe]˛Í@÷ęěkâ?đ@]-k™ˆ­ň@ĽB2Źh&?đ@]$âţ,@ÉŁĽ5 ?đ@]Ȉ_‰á@™pĽąŤ$?đ@]yEř­@âv4{H?đ@]Ɗэ @âĹó›ř?đ@\ű=Ëë~6@Ů`Ô° ?đ@\ęđx ™@8>'ˇrÂ?đ@\Ýŕsňĺě@ßĘČÁJD?đ@\ށ3´/@˙ô¤§Ź˝?đ@\ßô†ĐT„@" Ťii?đ@\ΠĘND@¤[“źg?đ@\ÁŽmĹ@ɼݍƒ?đ@\Ž˘,ĂĂ;@,ŹTÓ1?đ@\ żH@Ȋd/?đ@\ŽĚČkK@bˆR‡Č?đ@\[#Ť@ËÍTŁ?đ@\xýNJ÷@ÔR0Ô>?đ@\mhgVüŤ@ŇŸiŃŔ?đ@\_hÎ@F!{E„O?đ@\T{˘Č 5@ o„ĺ?đ@\H…ňŽ@ Ą X;–?đ@\;óxSĎ@ ŐůŘš?đ@\*1‘Ţ@e“ź&?R?đ@\RGŕk@ŘbéćF?đ@\cÄéŠ@G˘ăÍ1?đ@[ô2}w@ńƒŔ*řC?đ@[ăâ—^@íod҈?đ@[Ü_U`0@%{,U?đ@[Ôŕ´f'@ď•z!Áp?đ@[ĐĘë|Ď@ ›#?š?đ@[ČN’eĹJ?ýfľć¨žM?đ@[ÇxŕF@D?ůœ>”ö ?đ@[Ë-!Ń$>?ö~,ś•f?đ@[ŻŤWM˝?ř[uPŹ[?đ@[žW˘g?ú˝č9ž:>?đ@[éŻă4˘?űŚÔńËś?đ@[{š5`ęŚ?ű™J%e?đ@[l†=>d ?ţxÖ´•#Ş?đ@[b– •ă/@ÖpÜ1?đ@[TNWó|6?ý~'‡› ?đ@[IdĆ Čç?ůeyĽŰzŽ?đ@[G/K°_?ôÇřźi9?đ@[=\Jő}?ń,›$ż ¨?đ@[9%pöŻ?čßü(ŇŽD?đ@[;bxŸ€č?ŢoJ\Ćl?đ@[Bœë-tR?Đžóp˘k?đ@[M4D’Ü“?•ƒIm*ŕ?đ@[H*żŰ3żĐ€LM;Š=?đ@[Kř*řxŇżáߨ@–?đ@[Wj0íűOżć/˜Ÿ$"É?đ@[ZјfXŃżěCro-)?đ@[lĂ؋čżîA:HÜ?đ@[yóó¨î9żňuG%ăG$?đ@[ƒ5+{­œżön“ť o?đ@[<úEÜSżű;@••”Š?đ@[.‚Ěżţ˜T2ě?đ@[‡cšĘú°Ŕlëżrs?đ@[Œéo—ŔůÄâ44?đ@[ľ?Îä×Ŕç/#Cłk?đ@[•ť}“Ŕ™ëw_Y?đ@[¨ŕ˙ÂlĺŔŘuť9T4?đ@[ˇ­Xą>Ŕä6GW2–?đ@[Ę\[řŔtg•Źh?đ@\p]%``…Ŕ łĹöwň?đ@\‹ŮäOŔ ¸ę1Qą?đ@\ŽĎŽ& ;Ŕ ~E~ŀÓ?đ@\žZÝ2VßŔ œ;TkÖÖ?đ@\ŚŤámŔ Ľ‚¤[ÂÁ?đ@\§QţWG;Ŕ‡™Ż'?đ@\Ż“ţĘbŔŔ‘ wú?đ@\Á6ÝĘŃŔyşhʃ?đ@\Ň“&- Ŕ)|°ĺĆ?đ@\ㅨ¸]ŔQň hŤ?đ@\ôggŢó!Ŕ KbţE ?đ@]’rŽŤČŔ × Dl!?đ@] ˛ŇŔ ŮĽdó÷?đ@] 2­ř%Ŕ&ĚÝ2žŔ?đ@]˝1‚ÉŔœSĄ7?đ@]ßw\Ŕ~ÓxŽ„8?đ@]$Óz_|şŔź´ÇÉĺc?đ@]îňű ŔwŇĄ2G?đ@]͝ şŔ…$ĺDEÜ?đ@]łZa‡żü\u řs?đ@]%ma^œ!ż÷ˇ7B6p’?đ@]0ÉűfňżóôŤ‚Ňěg?đ@]3l‹A‘°żňłę[CĚü?đ@]Cˇ•ŔČŤżň?}:ž?đ@]QEĐR<˜żěŠ§™ĎǤ?đ@]ašx gżč°úW8ą‚?đ@]b™thÚۿߨ^a˜?đ@]]ťy$ř0żËŸžÉPŽ?đ@]_Ďdő ő?ś}•aÔť‹?đ@]d!ygá?×9gagÍ?đ@]lqIqÉľ?ăě|Ědá?đ@]yƒŤtŐŽ?éʓßRŒ?đ@]~pďŚ?îoËŒç?đ@]—Ď6s?đi:SnŤ?đ@]ĎöŽ„?ëac’śź?đ@]˘PœyM)?ęvľ,á˘i?đ@]´Üyo-(?ë1­K\?đ@]ş˙Ě/¸Ż?đż"’ž?đ@]­˘vľU?ô .< Ćĺ?đ@]äŰH?öăÚ^&lâ?đ@]Ž8)˝ŞĂ?ůŒĘśbÁ?đ@]ňź=?üt(ns˛E?đ@]v#ŠU@>Žôł#Ë?đ@]‚bÔ0=ľ@VńZI3?đ@]xŕÚôW@_…˜”:$?đ@]mJď§ö}@ƒÉ@!NĄ?đ@]fđé@Ą˛–ą˘?đ@]WkúÎý@ ő°Ćk?đ@]T@ɛ:@ ť|Óţ´?đ@]M”EŒě@ íĄč„?đ@]d ć:(8@ nŻ&ľćO?đ@]oœ{őŽ@>u뺒p?đ@]dLĂř@ÂuŻ8\?đ@]]UşXń@Äŕ‰?đ@]kŘţ@B6RvŤ˝ŔS ąVV×@TĽE˕á?đŔSFšcYy@T´^“R&6?đŔSą6f.Ž@Tšť Ćf?đŔSăĹŮţŚ@T°čţ%V(?đŔTń{>I@TŽ/?đŔTYYŽ92@TŠđĹëŐ?đŔTŽ1ó>ŒŐ@T;—+ş?đŔTVŞŒäŹ @T‹6w/ëŔ?đŔSńôPÍĚĚ@T|]ç|?đŔT •ěť\Ă@T}!šŠČI?đŔT•„35lÇ@T‰ż˝]ł?đŔTŃř$ÝŮ@TŽ8†‚Ó?đŔU1Ą4O@T›[˜1"ë?đŔUw$ůpAP@T“XÍ4ž‰?đŔUW€ Ëß@T~ÖŰÔ ?đŔU´@ŠDSt@Tť}$Ë?đŔV%FqŚ]@Tzú’¤ľ?đŔVލzš…ß@TorţJ*?đŔVĹkYS@Taä{Ă\h?đŔVëËS&”@T`Ůt‚ F?đŔVRúšó\@TZp×PŽÝ?đŔVpłÓcÁ@TKblŮ˝-?đŔV%›™p Š@TCkělĐ_?đŔUyćADÜ(@TLh^=.=YOÚ?đŔUŸËH6Ő&@T-MpJÓ?đŔUm˝yqŚŇ@T#NĆ>ře?đŔTď掏NË@T+—¤Őwƒ?đŔT§l+;#‰@T+휡ç?đŔTNĽf@T(ŇmÂG?đŔSňQďçä@T4AQgXĂ?đŔSČŇkžod@TF.fţn8?đŔSf.őö'ľ@TV|ŠžČ?đŔSubŔŁĚ@TQ Hďh¨?đŔSŽO’žüě@T?/8UŹ?đŔST2.؃ů@T8řyˆľR?đŔSgĚÍůşš@T4x#â ?đŔSŇÝÇO\@T,ƒbÁŹS?đŔSł§ ÖŃ@@T&xîÎa&?đŔSȨŽ6@T#TśŽb?đŔT*l˝îŘx@TůôŚŮź?đŔTŸź{+ü&@T#ë&?đŔT§*ŸŠwZ@T ‹–ŠMý?đŔTjÂGM×@SůěŚ:ž?đŔT%ĺ=˝@Sëč.ťŢ’?đŔTBcň÷ˇń@SćöúÝě2?đŔT{EfĄůz@SďÍÔƸ¤?đŔTą€y!Ş@S˙ŕ–ţ?đŔT÷Ş WFk@TN‡‹?đŔUb´‡ŠU9@Tő°Äž?đŔU¤Łv”‰ @T S÷›rL?đŔUƒE F@SúĘ V?đŔUb:ž|Č@SëlúƁ?đŔU+ómĎŹ¨@SÜSŚč˘h?đŔUb$Ě1@SÇŰR)?đŔULĆYÂ@S˝[Qš8?đŔT‚ga5<@Sź]u~÷ř?đŔT§xX-˛÷@SŻ$–HÇ?đŔTď+ňÜ5Ş@Słý‰ˇˆĚ?đŔULůaӉ@S¸+P¨–Ż?đŔU¨.Řó.L@S°t0Ź?đŔUÍIfb œ@S ü‘–'Ł?đŔUÔyę7eU@SŒp—ýýć?đŔUƒÄ8Œ•@SŒtDFQZ?đŔU:¸žnÓ@Sš-´‰?đŔU*”*œ<%@S‘]Ţ``Ď?đŔU.#žŕÚa@S†Ś,5¸x?đŔUD˝Rű9@Sx#çčÓE?đŔU1‹”ĘÜ@ShĐř*XÉ?đŔTďN`JFŠ@Sc•0݉Ź?đŔT°ŇłT[@S{Ě ‡­}?đŔTągęa–@SrßĐšL—?đŔTŢA•ł÷]@S`#ĽűĂž?đŔU LŐŻĆí@SW&ŠĆY?đŔUY&9žţ@SZž¤G™?đŔU{a,đœÁ@Si{?đŔU˛¸éEĐš@SwD‰éu?đŔV˝fR°G@SrvH|?đŔUó;ĺLlâ@S`­á"?đŔUĹf§eup@SQďů[Â?đŔUÔ_B`¸@SIßż ?đŔV"Ľ,Ó$D@SCíœ8ä?đŔVYi˘Łř<@S4]źjΧ?đŔVX$Œ`I@S!Ę‚ \?đŔV(ŒčŽ@S%RěRĂÍ?đŔUř˛ţ…z@SŃ(0T™?đŔUŤŤ†y@SŃęý§R?đŔUmóO @—@SŔţŻ´¸?đŔU0O1`f@Sӛčj˛?đŔT둞ĎÔ[@S$d\ßŰÚ?đŔTž_UP@S%ô_ĘÓ ?đŔTaĺ/0jT@S ś84á?đŔT7 ´ď|Z@SŠŽÉ÷x?đŔSřąçűk@SŢ٢đŹ?đŔSľŔ¤(ů@Sčëće?đŔS€G´¨.§@S'Źţ%‹?đŔSxÁt¸@S9÷ŠRj?đŔSąÇŠ`@S:qž_|„?đŔSĚĄ?œXÉ@SGC%-×?đŔT}ęü1@SK†łő0\?đŔTfÉf>@SNźÉ"ŔŰ?đŔTkB‡š@S]oĹćŒP?đŔTO#“Ÿg@S\ !ژ ?đŔTćÔŠ#¨@SS>?Ň*ž?đŔS˛JʎÂ@SUüé Ö?đŔS}žçöo@Sd'X”Ť?đŔS‚°^ Čv@Sx÷_ŠÝ?đŔS$UOp@S}FÚĹ#†?đŔS C;)Ú@Sˆî’ĺs?đŔRäƄ‚nĚ@SxeźU?đŔSű'Ůą@Sžaś¨x?đŔRÎxÜőDN@SŁƒŻÝŸ?đŔRŔ”hÇmF@SłŇRÔš?đŔS ;á@9@Sźc‚gvŕ?đŔSxĎŃ˙@SšŐ-ęď?đŔSŒ nmx@SżA˝ sč?đŔSVo%5]@SÇľďŮ?đŔS6nŢs˝@SËoWĽ^ő?đŔRšý<Š´y@SĆE^„?đŔRŇű2ÉĚ@SĎ(Ý6ŘŁ?đŔSO⊹/™@SŇćäÎO?đŔS.řp6¸4@SŰnż[ X?đŔRĎđďęď"@S۝˘ Îç?đŔRp ~=aĺ@SŕXŃÄţ]?đŔR~ĂŤ?T@SňW(¤Ň?đŔRLbšî•ě@Sňbfě.s?đŔQŕŽt¤Ç@Sń邏j†?đŔQâŃľDHG@T÷ Ó\?đŔQ˜,eÝ~@ToČcl ?đŔQMĘö$]0@T÷iX§?đŔQoiýňˆ@T.ŽČy.2?đŔPό]W"@T<šAŸ%ó?đŔP„—*yCŽ@TKşajqá?đŔP/LZ‰@TZI˛ŹŰf?đŔPeľÝJœ˙@T_”öîż{?đŔPÓs] dw@TW(ÖĐú?đŔQ]šKŘ?đŔPÓVŔž÷@T\tžŽ@?đŔQ?đŔRFşƒČő:@TśĺĺAĘ}?đŔR†ę~˛§%@Tźw&͸˘?đŔS \p@°@TÁ͉t?đŔS+UWšţ@TˇZvXo?đŔRů‹Qŕ0^@TŚ(1‹Q?đŔS ąVV×@TĽE˕áŔU¸ š*c@Eƒź˙¤<Ű@ŔU”˘ŠNř@E›żâLŹI@ŔUž%U0Ú@EźƒR'@ŔUžŇěˇ2@Eߚnýţ@ŔUž7l;űí@FJˇzR@ŔU“ďű?šÁ@F'ď˜Î@ŔUŇ+ęm@FMcÓY8ü@ŔU„v+Îv@FlěnŰ@ŔUmSĹţô@F‹„ĺÜLÇ@ŔUd[E0şź@FsĎÂľ „@ŔUZ ÎDĆ@F~™D.@ŔUU'-,k@FŁl„+… @ŔUBîw§G@Fťś~+ä@ŔU8YÁŸÔ@FŕÄZźĽ@ŔUTö@F؝×üâž@ŔUƒŹZlž@FÇÖr—E@ŔTđ™çÍó@Fľů‚i<2@ŔTÚ÷;í'š@F˘9ü<1|@ŔT×v˛™>u@FcýsŃď@ŔTÓY8ŠŒk@FYľűzęŽ@ŔTÖşKw@F3†›˘¤Ť@ŔTăœĐ†@FنLĚe@ŔTő%/÷:@Eú\GCa_@ŔT÷>_Ľů@EŘo#¨4ę@ŔTâGh3‚c@EŮ^×Ăә@ŔTÓŻw¸Š/@Eö´-,A†@ŔTşxtŕŹÁ@FŔÎŕĆ@ŔTŠÇ+ §@EéO䖟@ŔTĽLyćŒ@EÄżé8L^@ŔT ŕĎ­›@EŸĺ1*Ń#@ŔT“1Z3%@E‡ž‘˛č˜@ŔT|„g‡hű@Eœ¸g,Ú@ŔTmüŚ5@EšąJ”c@ŔTnV!Œ@Eß?~ű“Ŕ@ŔTmŹ˜fŃĽ@F>&)ŰA@ŔTdxËĘW@F(ĺKšé@ŔTU˜źFtD@FFv*l•L@ŔTT`Ö=1M@FkN6x@ŔTd훿@F“4p• @ŔTUCWI“@F–ŕ~mמ@ŔTE˘ Ń(œ@Fu{ă›@ŔT:—ń/°@F[uÁƒžI@ŔT#é‘Ţóc@FQ'2 zć@ŔT FśąÁ@FBłš č–@ŔS÷Ĺ` ôu@Fektý @ŔSů„řQ@F{TĆń™×@ŔT[ţč@F =|‹ěľ@ŔT=4yDt@FťQ P@ŔT$mŔ+Z˜@FŐÜ7ú3Ď@ŔT3Ôa ü@FôĽí'ř@ŔTMöq›u@Fý"×Fg@ŔTh=B§ĺ@GÉKe@ŔT‚ßűë@Gˆ ń@ŔTěŮéęW@Gádˇ2´@ŔTśš?@Gĺs՟ƒ@ŔTĐ]Úüw=@G"Ä~'@ŔTę˝qU6@G#tgl÷@ŔU’ó÷@G1žr˝5@ŔUE`řÄy@GDĺYltp@ŔUş–Î<@Gdržd&˙@ŔU*}ę2H@@Gíţ?˙@ŔU)ŔÚĎűÜ@GŚă@sĚ@ŔU;Ĺě@GÇŤËż1@ŔU;‡~2é@GîH. @ŔUQD¸WÝ@GůŸ*ŠV@ŔUlž^Ň~)@Gů?Íť"É@ŔU§uwh@HŸkA@ŔUŒ}×͑,@H1ϧfĄo@ŔU—Tăƒ\@HW śrÉÇ@ŔUŽ‚ F3\@Hb˜eŮŮ@ŔUĘOĂ/“@Hd€¨™’ś@ŔUćxd,Ć@Hoe„MkÚ@ŔV梖Ŕ@H|D @=@ŔV?|N…ń@HT˜č&ƒ@ŔV0%)¤.y@H>Oíéó@ŔVEşv~ë@H>*˘ +ˆ@ŔVQ4r>ľ@HŁ9q†:@ŔVaŠ:jń@HPđ|@ŔVy •l˝5@Gď{Ü›Ś@ŔV“żŽM@Gá?•¨Z@ŔVŹtł&ž\@GŇŹcĹln@ŔVÂK̚@GťŢRHH÷@ŔVÔĽşůk1@G *‘ň)@ŔVčm ˆ-@G†–&2~Ď@ŔV˙9ČíI@GiąťaÝŮ@ŔVńĂQ`uĂ@G[–I§ë@ŔVÖIăĘHM@GhńşKó@ŔV˝‘kg˙@Gu´0ęzk@ŔVˇuÓd$b@G\¸L\“X@ŔVŤ3@GT@GQŁ™ŇŒ@ŔValÝŢ@GP¤űL@ŔVxÝŠCˇ@GbÔç ž@ŔV_yÔoŠę@GmŽdîĐ@ŔVG5‰JA @G}dúU™ť@ŔV-$+Œú@G“:ßÍä@ŔV Uz)`@Gt?~Ŕr@@ŔV00@B&@Gr¨pĎ$€@ŔUö=ôQ]5@GrRé Źš@ŔUă/.ŕ@G\IϤšĘ@ŔUĎT˙Ío@GCăŔbs@ŔUłî1°@G<żf8ž@ŔUœ)Y 9]@GG_RU™@ŔU„ D%Ń@GVůŕ“-u@ŔUhÚUżŽ@GX‡zó V@ŔUI4‡9ƒ[@G`tnךš@ŔU<ô`‚—=@GC†ř€,@ŔU" [COL@G;ę˙ť @ŔUŘφń@G+¸ĽED@ŔUą{=ű+@G ;˘üűj@ŔUĎú‘Ĺ@FţŮ&Źĺ@ŔU*3=U@Fű+ő |˙@ŔU?ëő€7@F˙N+­Ä@ŔUY‰´ŢĄ@G U:8‰Ă@ŔUr×ţ菇@FüĘÚHu`@ŔU¨J‰7š@F÷[ýN˝w@ŔUĄ‚'Bpž@FܑwÂLľ@ŔU§áîĘÁĘ@Fŕ“`_,ć@ŔUˇPîÜz@Fćú Ä‘_@ŔUÄĆŘSró@Fâ~ ŕˆ@ŔUҨ˜ @Fǁa?@ŔUŢô Ź@F˘ƒşq o@ŔUëČƒcű@F‚ű?Q@ŔUüuálĹr@FWšbľ{f@ŔUáčCźˆü@Fb{`]‚÷@ŔUߣŁ˛wv@F;Đł¤ŇC@ŔUăÓ͟zĹ@FTť91ř@ŔUíŒPO°ô@EôHLˆsŕ@ŔUďî …H@EĐ,Ďú3@ŔU÷z­@E­šËd@ŔUřLT…@Eˆ—( ĺŚ@ŔUó <b@EdeÉăü@ŔUóš˙DČ%@E?5‚<8g@ŔUň: ÂŕŁ@E(z{˘@ŔUčČ/Fr@DřwxÝÚ@ŔUÜí.‚ő¤@D؉.—@ŔUĆɧɨ@DÔŠC$Î@ŔU°žá<,L@Dç^(.4 @ŔU˘V2L1Ť@ERŠHMž@ŔU–­,9­@E%ţćĄ @ŔUŇĘĐL}@EIcś0Ć@ŔUŽ6͜E@Emţ+đ @ŔU¸ š*c@Eƒź˙¤<Ű@^m‚¤„1Ŕ[qB1{?đ@^5˜şîŔ.xŽEĹâ?đ@^ż˝ŠÖŔUý ?đ@^bmÚÎŔ}Ł@Ŕü?đ@^QWěKŔ÷­“⶝?đ@^÷…jŔ˔g*?đ@^yÍš<ĘŔĽKó_Źż?đ@^DUa+ĚŔI‡Œ^?đ@^ĆůqGéŔ Îúv™Ô?đ@^ ÝâŔ bĂC– Y?đ@^ˆsÎqŔ:`ŐOv“?đ@^VHŇśŁŔƒÇď ö?đ@^+ŽHY Ŕ>Í˝Śáś?đ@^=‚ýüŘŔ^Ż‘ţ×?đ@^C ZéwŔí3†Ď?đ@^B>* ŸÇŔ ‡•űóF?đ@^9—€,aŔ łÄxĺÓ?đ@^D((Á)Ŕ ™śG—|Ö?đ@^Q°ƒżlZŔ%mBŠ?đ@^bźˆÇߓŔ1’b“˘?đ@^cEń•!Ŕ&ŤÔsDˇ?đ@^_ĆńoŔ`”pŽžĽ?đ@^k5˝ŸýŔ0‰Ş2ł?đ@^€{,$j0Ŕ4ˆ̅Ő?đ@^‰oŚ7:Ŕ‰\Ť\?đ@^›‚čYŹŢŔÁ—7E„z?đ@^­úqü­˘Ŕ¤S6c^S?đ@^ˇ-Óš"ŔÄŤM–^6?đ@^Ş_EăÓŔ)ҧŻJŔ?đ@^˘;8ť]Ŕˇďq1ˆ?đ@^’ď`ş›Ŕ |ąŮÍâ?đ@^•1ßFŠńŔ ̊ÁiüP?đ@^˜žĺíÖŔúbŹaI:?đ@^ŽĽ§A1žŔü'ZÇ?đ@^Ré°ĄŔ>Š:m3a?đ@^xj0Ä6:Ŕ.;đÇłĹ?đ@^kź$SűÇŔ“<ÝÁŐş?đ@^YöDÜżţŻŠOç\Ă?đ@^gţ _Čżţi š$?đ@^vÖ?´˜ńżűJźutŔŁ?đ@^ˆs¸AtżůŤó…łú´?đ@^˜‰E5՚ż÷xœďŠö•?đ@^Ľ2ťłlżô !Ȅ,É?đ@^°~S jXżđxłŹľh?đ@^ż6qzR1żě[źŁ]?đ@^Ńd°_żď;jՉÔ?đ@^ÚÇ@ #¿秒ž˙?đ@^ËŸĚšČ żâUż-qń?đ@^ˇ§z×?żĺ˘ŽŻ¨i?đ@^ŤŤIbBżčĐ7ƒĐ?ü?đ@^˜ÔçżčS ń˙_H?đ@^ˆ>ŠÉżë^%šßG?đ@^w`'żîP‡’šŻ–?đ@^e*4˝ßMżëŻĆűF\—?đ@^U`ţÔDJżđő럌Łŕ?đ@^JľH uzżô°‰S!ˆ#?đ@^<†÷ş˜żöO1;•E?đ@^*?Ě-Î żő%î"Ś/‡?đ@^!âÖúxżđ֍Š“–?đ@^禕˙żěŠě<~íŰ?đ@^‡>Ę@3żĺ˘ść%Gh?đ@^$ďiżŮl•| zú?đ@^ö{ăR"żź[xß~Žř?đ@^`i??ÄJi'Ž­?đ@^Yłx;?ŮMW‰°(?đ@^#Uúśy?ŕžńDś4#?đ@^5¸ř?ÝUúşwÉř?đ@^G.čOw,?ÜÖČśŇ?đ@^Z7ÚVdÁ?ŢÍx1œƒ?đ@^kHviš›?ŕÓޅ?đ@^|Ż/€3L?ܚ9D‘ŕ?đ@^ŽÂm0rI?Ţ͕ÝL?đ@^˘łP3“ć?߉4ŐI"?đ@^˛ůČ%. ?ß+`‘taT?đ@^Ĺ˙VÁúÇ?ÝAsא^?đ@^Ö5żqS?ÓÍ1O;Ę?đ@^čŮAAœŠ?ŇŇč[S÷ę?đ@^ű[Üç]?ŐÖý¨i?đ@_ e,4Ó?ŘS7!?đ@_sD–Ô?ßçüF[“?đ@_(.˝Ý"ţ?ç9rą+w?đ@_5=ŹHl—?î8ŕü°Î?đ@_@ňĹÜ?ň}#r?đ@_JŸĺŁy&?öĘ>Îđ;?đ@_FmŠÚÜŮ?úžžľíŹ?đ@_7n“tÂ÷?ů6şˇ#„?đ@_( Ś6đŞ?őÂaŠƒmÁ?đ@_˜$ ó?ó ‹XŢí?đ@_ĎN?đ2YĂČŁZ?đ@^ţü÷(Zš?ě Â4[Í?đ@^íÄ2×ě?ëarUż…A?đ@^Úéšq~?ěŮ&îĄA?đ@^É°#1 V?î1jdô8?đ@^ˇX \â?ëýŢp–$@?đ@^ĽŠł×C•?îž ý‡÷ ?đ@^“výÍĐ?đAćW¸Q{?đ@^€č‰ƒM1?đŢv__?đ@^oaČëČ?ń,°Ë8ő“?đ@^^vxąň?ňň|cşŽ?đ@^Oçś ?ô3IW|á?đ@^;ך+1?ő5nšTą?đ@^3)hŒT?ńčutS:ë?đ@^'ç–?ěL-*ý ÷?đ@^PhI4+?ěšeFW¨?đ@^ ŚĺcşS?čďŒ}XýÇ?đ@]˙ŹŁhźÎ?áŠVŇH_?đ@]ő—xůŻő?ҔCmß4t?đ@]đĹ<‘kż™l†ŰFƒ?đ@]ńŃ šÍńżŃ[j’Öm?đ@]ňŚ’ą°żćžĄËň?đ@]ć,ŚČőżéŤk51x?đ@]ܚjL8öżń…˝ĎŽŤ?đ@]Ô>ˍřżő=ę?đ@]ÓđEŔ'żů¤'ĐÄCm?đ@]ÔgˆéZ”żţpăĆěř?đ@]ʅĆ×ZńŔA eKjČ?đ@]ƸŹ­źŔ€{Ş Ř?đ@]¸Z=šŔŒ]—*ä?đ@]´‰œ˜dŔÝîáş?đ@]´D'´Ŕ ˇCŐ\Ű?đ@]ş|A€ŮöŔ Ó#;†Ąň?đ@]ËPËš Ŕ Ţěž%ái?đ@]ÜĐ-D‚Ŕ 9„űŁĐ?đ@]ŕpJD0qŔ„đ?×?đ@]ç# EÜ{Ŕ?fèÔ?đ@]çfč Ŕ‚ĺ˜ż‹C?đ@]â‘çhăŔ§5K0Ř?đ@]ßť(Ýî[Ŕɖ9Ç/?đ@]؝CżűŔÚĽŰŢs?đ@]۞dLŚQŔżWˇ?đ@]é?ăČ}#Ŕ¤a~žb¸?đ@]űśŤMđšŔif=îW„?đ@^m‚¤„1Ŕ[qB1{@WÍţu“żU@ËyÍzá?ţż;O4˘ˇ?đ@XŻ¨O3ś?úäîp”—)?đ@X˛“‘G„Đ?öźÚÓ°Œ?đ@XšP˘ÖÚđ?ňeŞ˝‘cK?đ@Xž÷ČLA?ëţížoě?đ@XĹőÓ°8?ă@\NĎo?đ@XĘH]ö.Ť?Ó­ä´Đř:?đ@XŮŕbܤ?ÇwקŻEł?đ@Xę_ÚwS™?Ś}¨ď˘Í˛?đ@XňOâhŢ0żĘ(c=}?đ@Xý]xG†żŰaRG—(Ź?đ@Y MĹI=˜żäˇř짖.?đ@Y¤Lžú@żě,ă4ÎŻŕ?đ@Yé–w+áżňŒł•ś)/?đ@Y$olÜżöfˇű”o?đ@Y,SP¸üżúŽůqźˇÚ?đ@Y5č]CGżţˆr0{iŠ?đ@Y7ˆÂj´Ŕ‹oÉç=H?đ@Y@CăóŔŁżI6Ď?đ@YM7Âéß/Ŕ>Ű˙}ů˘?đ@YYŇušśŔń}éy?đ@Yb]™ď˜ÎŔň ˛ql?đ@Yn˙šä6Ŕ •Śzg‘×?đ@Y~(–'Ŕ îű@čý?đ@Y4QŃ­Ŕ Zî|傸?đ@Y“ůąL(ŸŔ{ßŃM r?đ@Y řĐě}çŔą,né?đ@YŻşÍžŇ[Ŕ@5żv ?đ@Y˝Ćđ JĹŔuf2 q?đ@YÍQ˙ßýXŔĽ8ähŔđ?đ@YŰ+ѕEŻŔ]Á–M?đ@Yě>ĹG7Ŕçëć?đ@Yú Ńo;aŔŤƒbžĂ?đ@ZťbxZŔ“=ń#ź?đ@Z˙#QřŔgnÂRËł?đ@Z% ¤˘#Ŕh×ę9*Š?đ@Z%§tc,ÂŔkY A?đ@Z0h}íŔKůP'x?đ@ZDĹ­ËŔöô#ř ?đ@ZNgťŰ+wŔOÔŔ„ŔG?đ@ZZě~Ö0ŔesŇ*…?đ@Zj°ŠB”Ŕ5ŞO&iđ?đ@Zta'=JŔŒĐ›Â`?đ@Zu斉°čŔfę´ ?đ@ZwחƒŻŔ?h‰°?{?đ@Zxjż}ŔţŘ_?đ@ZxŁ6÷Ŕňś}č-?đ@ZtŃ?jŐnŔÔbśCĺM?đ@ZzŠĆ˘}ŔE÷,%?đ@Zuć7­'hŔ ,N™ëƒ?đ@Z|” ĘeŔ çűŁŕ"ą?đ@Zƒ˝Ő¸u˙Ŕ U#ŮH?đ@Zxu1lłŔjĺŰXȂ?đ@ZnuŽ;˜Ŕ"'ú“?đ@ZdžL–“Ŕ„S°GK;?đ@ZPި捎ŔëłLaâ™?đ@Z=زtŮŽŔ¸ŃŐö¤Ł?đ@Z*ě=™›ąŔąĺ#˝Q?đ@Z,ŞĹ?EźŔ.8Lţš°?đ@Z5ŰU”‹Ŕú—Ôţ!L?đ@Z'í×ĺ\ż˙[¸ń"D?đ@Z Şŕńcążü2˛ýŒx?đ@Z— á ż÷€Xâš)œ?đ@ZüäĎHżňúaĹšLR?đ@Xďčqö#@ -[‡0ö?đ@XŕYţĘĹÜ@ j ćÝ;Ę?đ@XŇT{˝@ Ţůůúž\?đ@XÂiJÄůë@ tÜgŇ~?đ@XąDşa<ó@"ř×ë ¤?đ@X¤ žą:@ÂbvôëÄ?đ@X’$ózŠ@t7"Eôx?đ@XŤ„ÎË@. @H‹?đ@X†.€Ť…@!ĎAŽľ?đ@X}p<Äöő@ ^0ěŚ?đ@XrTk`7@é$ŸĚď?đ@Xcüx싸@š#΅ë?đ@XQmďgđÜ@ť-HZcĆ?đ@X@ * 'Ŕ@Ç%[ęĺ?đ@X-ş‘‡ÇĘ@÷üţŢí?đ@XNÁ„Pî@âiЙď?đ@X QÜCN@#:€uęę?đ@Wú<˙Hľ@ÎnnY?đ@Wꉵ|Gř@ev4u%?đ@WŘGœň™­@s%1ć ?đ@WÍţu“żU@ËyÍz<@HŸÖˆ—/e@Cœ‚šSVd@@H…QrňűŸ@C†ŮËI–@@Hnp#É@Ca !}ôĂ@@Hp1ň˝č/@C:×<ŻŒL@@Hr.ŽŸ'@CĹ[k(˘@@H{<l> @Bń}f7Ęđ@@HH~|IR@BѝEš;}@@Hš˘D ]@Bż¸°77@@HëmJRw‰@Bť ѧM§@@Iî­ěó@BŻ ţ´Ö:@@I.̎l5d@B~˺ޏ@@IRůőđ]@By|čŽ^@@IzLÑ/@Be×P,ß@@I¤îi b@BYnů3q@@IŃńUĽÚŇ@BPĹÚÉF$@@I˙çËu3Z@BK˘ÝÖmí@@J,ŕ4É}Ü@BU#뚨s@@JZ^’^Z@B] <ĺŤ@@J†ÓÝäí@Bg=ŹČq@@JłÜůš Ç@BośŒ„„@@Jâ)R@Bsƒ§8@@Jđš8šăe@BtJTüBŃ@@Jô¨K ĂČ@BŤÂÄËŘŔ@@Jěu2"Nş@BĐ'R•“@@Jçm‚€Ĺt@Bő…^™;@@JěĎŚ.Bˇ@CxťÍ@@Jë^žU•Ň@C?PťF@@Jőr|Œâž@CcŢˇü@@Jč• ˜*@CƒI>ßÎ@@JĎäE‡Žö@C›Ä ˛ƒ@@J{˙<Ž@CŚ9člóŽ@@J”×LKs@CŔ~ßń<@@JŞwŘC i@CÇ#=R˘@@JÇźŐĄűâ@CĚŮ;řV@@JˇëÄółÁ@Cóţ$şQĺ@@J~ĐŃľĐ@Cňgö=–’@@JaŒÍšÜö@D ę´cč†@@J[ĺrΑ@D1Tó%L[@@Jjňăw#5@DUŔ€›ť%@@Jč厡9@DsżůŔÄN@@Jś_–ţňń@Dew …@@J×çăű@D_fČ*™Ş@@Jú&7ĘU@DTźúÜ^`@@K&âgŞ[B@DaÒ::Ć@@KP* 1Üi@DsŐ .ë*@@KRţ‚qz•@D‘űVß'@@K)nąëřŘ@DŞů§?@@Kâ‰Č? @DĹťćoTE@@Jű9?…X@DęOnÖ T@@Jć>Š;Ç@E „ÔSz@@Jąh”ižß@E Ń)Ĺ;€@@Jƒ"C -@E I‹ş@@JkřČAm @DÝ;ĄPĺ@@JmmCN$@DťJÁ6e@@JfQA… Đ@DĄ8É=čX@@JCôxFĂ@DÔř‹Ě@@J:ĐJÔ˘@DřyQg´{@@J>hí‘ct@EÄt‹Ć@@JSý#&@E<ƒ#ą:_@@JPQ79ůi@EZ¤Ěí ˇ@@J8xB(@El )žƒ@@Iěv<ÁŠi@Ev>Ś—ä@@IĘDŚÚˇ(@E“$4̛+@@IŚŸ!6Â@E˘+ˆYÔ@@IœR#LĐ$@EÉBśueí@@I‚é˜@E襐ŐĘ@@Io93ŢI@F Hnă†u@@INYĎjӋ@F"m @@I"|föČ(@F2­âÝ­;@@I/ÁÜböË@FNähŒ…›@@IgŒŽ-Ó¸@FMőP”@@I™XCcŔ@FB^=FŢ@@I˛\ ϡ1@FL&ŒĹ@@IƒŠ|R @FsČ˙ƒu@@IĄRŒérá@FX†XÚ@@IÂąŽĺ@F­=`çLÇ@@Ió6Ÿqgő@F˛ô˜Ł@@J*˙á’~ę@F˛ŇM)-@@J^[Qř9@F­_&Š@@Jƒ8aŞh@Fł!`z‹@@JhÓ*?’@FŮ˝es×@@J„~"8öč@FúůÍLŕ@@J‘Ę*jżœ@Gůě0 @@JŠgřJxd@GBv*Fr/@@J–•Ś™Ż@Ge7Ń~Z9@@Jd­N{@GxđťŢÖ @@J+ŔĚxĂ@Gs÷…żů @@IţŠo™Kn@Gpk? @@IŇźQűŞľ@GĎĺ~­@@IŸ ŚNm@G‹]sÔ&’@@Ii;aĺxU@G}üŇ|ÉĎ@@I=Ő"̀Ĺ@Gmő‰z’ţ@@I—×M\@GZ§tŘ@@HÜ­ćwі@GFJłę=‡@@H­jł-•„@G>¸Ż{@@H“ T-kŽ@G!ΠÍÎ^@@Hg-Č|ďY@G őŽŽŐ@@HLž“cg@Fň<'ü72@@H÷Ÿ[Ź@FßĐH[˘@@GךŹj@FŐż;gR@@Gźţ†żH@FĘ݊Żq@@GŽ†:ɉ@FŸj´a×@@G–Ś‰ĂCÎ@F})cr`@@G|öíăę›@Fg|-äŒ@@G[F—7Ę@FFnŠoŢM@@Gy‡č*ƒ’@F- |ů!@@GžŽů—˝@Fdg•Ö@@G¸ >@Eď!ő9@@GÁ˜…°Čý@E×#Ybj]@@GÂ7ŚD:@E§_Őˇń@@GÁ,xFTĄ@E‚R‰R€@@GڂI×ńš@EbMsq‘¸@@GňƁ,i@EC •z@@H€ÜşÚ@E%WT{[2@@H)@ňëH4@E=˜^t@@HIé¸pX@Dë_|ôľ@@HjOMâ{@DÎĎÓťJ@@H†ŒŒźŒ˜@D°ľą2Ď÷@@H—EÓŠ# @DŽ ‡t¨@@H˛°`"?Ś@Do˘˙@@HÎ:!źjŠ@DRF˙v‹@@I,D­M@DGĆöĐAĎ@@I'<ŻŃçk@D3 +@@HŸÖˆ—/e@Cœ‚šSVd@E˘Üş˘† Ŕ5˙[–đD2?đ@EŁ6üf‹ Ŕ6?˝ƒ3ˇp?đ@E¨U ú^Ŕ6´*ş-p?đ@E˛Ć¸śľÇŔ6×8†EHÝ?đ@EĘIĐÇfƒŔ7NŢőĹd?đ@E×z lŔ7Y{ž9ĎÄ?đ@EÜŁG’>–Ŕ7—Ńł+ϸ?đ@E×(ŕťşŕŔ7ăŤç_Íg?đ@EŘ|/Ct:Ŕ8.8ž}§?đ@EăęąýŔ8q‹‚Ł?đ@Eú¤W1qŔ8­ZăÝ?đ@F h<ěʏŔ8ôv•Ž8?đ@F,şÖUáŔ9*ńĞ?đ@FH`Ö˝zsŔ9EÓťŒÇĚ?đ@FožČ^:ÇŔ9[…Ž˝^?đ@F’ ęÁŔ9‡m߂Ě?đ@FšK‡ŠŞ Ŕ9ç’ćĂ?đ@FŢ0ĹEůőŔ9qżÉ˛M~?đ@GŹ§eŔ9KNF/!t?đ@G')ޘňŔ9/ťňҨ-?đ@GQ&=ƒÓŔ9(‘?đ@GvĹě†îSŔ9'ě…M?đ@G’թǝÄŔ8áh– f?đ@GĄĚ›śkúŔ8—GŤ Zś?đ@GŻg”‹ˇŔ8P=çżŞ?đ@G˝ťV€°Ŕ8 Ĺ ž:Ľ?đ@GÍ$E†DŔ7Ç@/Gü˙?đ@GŐÚ˝_žÝŔ7~6Őç%4?đ@GáŔiÉúŔ77CĹla?đ@Gë¸ÁŢĽIŔ6ďxč‚w?đ@GňHÁŸźQŔ6Śpĺě¤A?đ@Gü2řŞúYŔ6^rÚ¨Ćů?đ@H'žëfŔ6V ?đ@HwśoqŞŔ5Ô˛Č͗?đ@H#śémOŔ5Źťň †?đ@H/^ĽyçÂŔ5FÉęÁV?đ@H9Eo×`Ŕ4ţY„=qś?đ@HBŠÎjBŔ4śGł27?đ@HMIJ›WŔ4n ‚1Ú?đ@H\-×>Ŕ4)äOŰÚ?đ@Hg4:Ý˝ÝŔ3éÍ˙››?đ@Hqßăž}ˇŔ3œîTŸ˘ë?đ@H0Ń']iŔ3W‰á‚`ú?đ@HŠČ%ů3&Ŕ3z|Ů1?đ@H™S°ŢpĆŔ2ËĚÝ me?đ@H§vO ŕŞŔ2†¨G”EË?đ@H˛űŮq¤Ŕ2?Šü2ë ?đ@Hš3<çpŔ1řöĂ&k?đ@HÁ4Ľč”ťŔ1Żž€2Š ?đ@Hšő}@­nŔ1gâ… rĚ?đ@HÂSĚAU Ŕ1›œMAŰ?đ@H×ě­§ť3Ŕ0ĺ`ţ@B?đ@Häő}PŔ0škt [š?đ@Hí35eŃ)Ŕ0jÖ8“ň?đ@HĺNôćŚ(Ŕ0&Cך(?đ@HŰt ĹĂŔ/żßřţ?đ@HÔŚÄoěŔ/+<Áâ4?đ@HďYý4ŕŔ.řŹK‚V_?đ@I  ŸżŔ/ĺčďÍt?đ@IDąĹәŔ/Ő2̓á?đ@I1şźšżŔ/XIMÂ^5?đ@I=“üpśIŔ.É*‚‡V™?đ@I7ç˛AŔ.?÷¨­K?đ@I%\.ƒ—-Ŕ-ş•\PY]?đ@IYąěđŔ-+"%űm*?đ@IO™NvCŔ,–€–-Ói?đ@IpĆ ‡Ŕ,g؉š€?đ@IřNţOŔ+oRě˝[?đ@I§6ĹÄ&Ŕ*ÝsÂ(u‚?đ@HůSTďŮŔ*TÚĚÖ¤?đ@HěćfRxŔ)Ěfú\ÓĹ?đ@HÔA´”’ËŔ)pńśh?đ@HĹ şCâŔ(ßž×Äʒ?đ@HŁ:0SÓwŔ(HŁPÜŰÖ?đ@HŠŮĎ?‘÷Ŕ(‹ÂôŚ ?đ@Hm—óŔ(óĘĆ^Ď?đ@HuĎü+oŔ)‰ 3DłK?đ@Hon$ƒ×ˆŔ*‚‰žB?đ@HdÍśăQ`Ŕ*¨A÷ą5?đ@HCýܤ°Ŕ*éztöAĘ?đ@H'~šWuŸŔ+`.MČTW?đ@HÖşDRŔ+'Ëżő˛8?đ@Gô(ĽżĐ Ŕ+Z4Aę:?đ@Gýó|ätŔ,4žEăf?đ@GîFű<ŒĹŔ,uf‘Š?đ@Gď=ažŔ-4ŃB?đ@GÖȒů’ Ŕ-{ć…Mtě?đ@GÂ>jgx”Ŕ.YÑŐH?đ@G¸|:ŐjőŔ-Ľj/ Ţ.?đ@GŚé&¸Ŕ-Öeˇˇ ?đ@G‹ľŃjÓˇŔ.¸ďűőË?đ@Gv=-Ŕ Ŕ.„ŕ\rk?đ@GSžăęŔ.Ň3M÷"˘?đ@G7š×šEmŔ/(n΄Ş&?đ@G1č,ywŔ/ޞáZnE?đ@G*ł€sqŔ/Í xF?đ@G VĨŔ/–`I'Ů?đ@Fç{ô°ŻŔ/—9ýĚţŃ?đ@FĘú˜¨śíŔ/녀•h“?đ@FŚ}úţ)ÓŔ0–“F˛?đ@F€ç’–<Ŕ0 Şâ‘ľ?đ@F_lD†EĚŔ03^Aj?đ@F;’â)ŽŇŔ0G§ćˇdĂ?đ@F9¨ˇź€VŔ0—AúŸ;U?đ@F*5Ql‚éŔ0ە#Žˇ?đ@F՟úpĂŔ1ŚŢ?đ@F­6 D Ŕ1YůŚAň?đ@Eý•˛ŽĹŃŔ1ĄIžů—i?đ@F§ěśŇőŔ1ć‹ßN ľ?đ@F? ţ¤Ŕ20ŠŢłK?đ@Fę_pÉŔ2w§ĆÚ<­?đ@Fĺ˝bJ‡Ŕ2şNYŽ^?đ@F!Ş×íąŐŔ2˙zöőŻ”?đ@F/ůŔr]˜Ŕ3Gb}~ĺ?đ@FKěŔ4ӒňN ů?đ@E쀙ŤZŔ5?’ ¤Č?đ@EĐ|^â€ŢŔ5Iç‰ Ü?đ@Eźî›Ń"yŔ5zCHV`ć?đ@E˛¨­ťĆ¸Ŕ5Ç@'PQ?đ@E˘Üş˘† Ŕ5˙[–đD2@aŸ´§)ţ@Dž+y.ą9?đ@aš úâűá@D ÎŔAü?đ@a¤u,¨W@D™ŞŻ°1ŕ?đ@aĽÂ,˜@Dz°îĚÉĚ?đ@a™đȢ5°@DtƒÂŒť?đ@avýܤh@D•Ěż-\Ş?đ@aŠm&-˜@D‚´Ö˙ ?đ@a„ş6ĐHG@DbFŻ?đ@a}`ÚŔč@DH~N˚k?đ@a€J•˝-@D"ó}A đ?đ@azŰ jo@Cřˇűa4?đ@aÚB#;Ě@CŘůşƒą?đ@a€Ćú Ĺ×@CłżŒ1?đ@a|Š<ÖgG@C’  ŞJ?đ@ay>0pď@CmćQ྘?đ@as*äc @CN^Ą)‘?đ@an̙Ţdˇ@C+ŤylD?đ@ajĎ'ë@C ľąž€ń?đ@aa¸X/ŕ@Bő4Hp'?đ@aYyc™Ŕ@BÚő&9&?đ@aSŕIÚ÷@Bşˆ‡ŕ‚Œ?đ@aKťĐo^@B Šlc@g?đ@aAś;šŐż@Bhxš0?đ@a7ţ•@ť@B€ÂNŰ?đ@a-lŒ•*@Bmź¨uľ?đ@a#)â~üŐ@BgeŽBhh?đ@a2ŚŽďË@Bi?đ@a(4eKý@B˛A|řź?đ@a!TŞ‹@B¸ř%7}?đ@aŮU([?@B¤ťś‘ă?đ@aÂeNÉ=@B‚D žr?đ@a% +( @B]”{Nď?đ@aË÷´Ó@B>{úüek?đ@aŸx;@B#~‘cT‡?đ@aÄ3/Ü`@Bü.m?đ@a,RÁD@AŢ%V8?đ@`řłąEj#@AĹőç9Śń?đ@`íłwĂ@AÁ|ˆ°ę-?đ@`ć™K€›@AŇSÎ< 9?đ@`ÚP?™ł@AŇĄë‰tf?đ@`Îý˝%Ĺ@AĎh_ľ[÷?đ@`ÄVyŰ)ő@AĂIBp?đ@`¸ď"‹ E@Ażg!ěQ?đ@`ŤŢ ŠšŘ@AŔ0H‹¤?đ@`˘+΢5n@AĹi‰ë‰?đ@`——uS8@Aśů.ŃĽ?đ@`Ř˘!Ł@AšŘęŽÚu?đ@`‡–Gř Ľ@AĹˆć?đ@`OęŮč@AhęŚú˝ô?đ@`uÓP4Ü@ASŔkB?đ@`mœ"0Ą…@A;˝˘ą~Š?đ@`c…}Z¨@A2ĺ |m?đ@`\¨'* @AgöƒŽ>?đ@`_˝”˘lą@@ţA,‡§ř?đ@`k¨˝“”˘@@ýa,)Łő?đ@`vŁŢܕ@A&pŚ+I?đ@`1¨ƒ+@@î`J‘ŠŚ?đ@`…łâVú@@ýąy_" ?đ@`‰drĂ@A"uÄ# ?đ@`‘ę‚R–@A!j`]Žž?đ@`ŸĺÁCU@A(=“*Ë?đ@`§đ^“@A,"ç23Á?đ@`°sÂm4@A;FŮ.˜/?đ@`˝GŒ,@AB›!šˆ?đ@`ĆČż†Ă @ATŤ5˜áT?đ@`Фűłż‹@A`ÚUí;Ď?đ@`Űn>.Kĺ@AYzY:+?đ@`ĺŐăN[@ATŽYB+ ?đ@`í-]đgŇ@AIĄ‡’2r?đ@`ĺVوB%@A&čŻmo?đ@`ăĎ1ÜŮ÷@A>˝9ęœ?đ@`čńťőؓ@@á^(ŢŚÂ?đ@`îđf‚°`@@ÇTsšIK?đ@`ůr*+~Q@@žlŐ"ÔÎ?đ@a 7ŮźÍ@@ؕdi§„?đ@aԐ5ę+@@üŢ­”÷j?đ@a ǛŸ~‹@A÷F6<ß?đ@aїŐĐS@A$]°A!6?đ@ať[WG6@A5;v?đ@aˡôď@AO÷ž ”ĺ?đ@a}ŐdhŢ@AsËĂÎ9?đ@a~*^łE@Aq VT2D?đ@a%0ĄmaT@AYv9!j?đ@a+Jdŕč@AQ)ŒUđO?đ@a6XœŸp›@AS;I¤”?đ@aCůŞÜÄ@AP‚GSź3?đ@aJ:sČĚ@Ah,Ťçű?đ@aUŸ÷@A„uA\/{?đ@a[b1ŞZ@A[—Uˆć?đ@acöw/V@Au.ę6ć6?đ@ae_…xŰ(@A˜KĄ^'|?đ@arđZŁ•Q@AžşüV‘)?đ@a{ˆ1Á&@AÄÜřŇż•?đ@a{ăg6@A§şq/3-?đ@azĎxŮ`Ý@AĄčń‡?đ@az5ç\@A‚׈r E?đ@a‹%ŽěWý@A—’Lű?đ@aŽ_§<7 @Aź­ĂPA6?đ@a–ŔÜÎX›@AŐ<Ž"4?đ@a™#ÂáS @Ač”ĺ÷“Š?đ@a“ŹL–ö@B }o^/?đ@a“ Ňjáƒ@B-.(•l?đ@a–čËT@BQˆč•2?đ@a›YË8@BrvmTöÂ?đ@aŸň B>*@B’}ßÍP?đ@aĄŐÇPč@BˇeĽ$tě?đ@aŸň,övk@BŰ×ţBM?đ@aŚ˛mš@C’ě[ž?đ@a˘JÉMI@C%`˝RuĎ?đ@aŹ_óÄ”@C-QˆŮÎ?đ@a°eŮ˙Č;@C8ý]ŕ¨?đ@a°ŇF`A@CYI×ČźV?đ@aśWŒÄ)6@Cz„ČŸux?đ@aźűÍ^Ę@C™áăśnę?đ@aŔŘ'\Ö@Cž˘5DÁ?đ@ażjx0Ş@Cáę›Ül$?đ@aźo;ƒ@DË\Ç?đ@a¸¸Ä@ @D(OŮŠco?đ@aąÖťÝů@DF:|?đ@a­%Èó4@DhÄ/_É?đ@a­¤žgř@Dý¸Pş?đ@aŤ$ďփ@DŽ!Ú Ł0?đ@aŸ´§)ţ@Dž+y.ą9Ŕ~íGa@MIfI5ƒL?đŔAÂ[rž @M.Śt„m™?đŔ"áM‰¨@Ms͐jŹ?đŔů$Ł–bu@Lů&źu?đŔyN4]s@LńÓĆé­ť?đŔŮz1S9@Lă÷žJ~?đŔÍ'ËÄV@L˝8úĹ?đŔMrČ9@L˘…Ú0d{?đŔɡÔá°×@LáŽ&ş?đŔ•anśC@L\#ĂĐą`?đŔ˙äLé@LEˆß…Wz?đŔ/ž1Unú@LZßśăA?đŔ˙"'’[@LRèŽp=?đŔ­o1žěr@L96ô2˜?đŔiĂĘ4&@L ˛ç¸?đŔar‘Ň@K쾈?'?đŔşŐńËeß@K¸k9¨ ?đŔôöNg@KÉő-ĐÁe?đŔČ?ť @Kí3ç‰Đ‰?đŔ­ýŃ î@Luëg"?đŔčIuΚ@KýəŽFA?đŔ†ő-Ĺď@KâáŁţu?đŔČÜ!ĹV°@KŔžĺě0Ý?đŔšëzŇ_k@Kœ}˘Q?đŔZ‘—LľĘ@KyÖ§šël?đŔ‚|ƒ(˝@K`•ćG;?đŔUîíĂp@Ke¸8J]?đŔÍąƒÄë@Kjç>ž×?đŔ bćű0Ţ˝@KzĘß)Ú/?đŔ ¸ÖĂ?K@Ko2Ľ(?đŔ ’< Š@KJŠ5[;Ç?đŔ cw!ZŘ@K(”ž—Z?đŔ‰ŐʛCM@K‚Ž?đŔˆ-ˆ§ß¤@Jů|A.ř?đŔóŠďX0 @J׍¤Źą]?đŔŘfÇäŁ@J­ó\”ÝU?đŔ YÏɮ @J§ůŸđ(?đŔPM:@*@JĽ˜YWŠ?đŔĺçHB"$@J”ą(ČŐ?đŔgŕI \ @Jr;–,.?đŔiG!Ň@JlŇ<Ë!?đŔ7Lvgϖ@JQë<}CJ@I/<\Ž?đŔC,xlÍ@ImŞa&Ť?đŔŒPD{?0@I2Ô+]?đŔ;a1ođ4@IÔ§REč?đŔ… ˇ@I#֏—1?đŔČTî$@I+Ç;üş˛?đŔŠG2[_@I! ěMs?đŔ x}“9@Ipa–:ÁÁ?đ?đD^o8€‘@Iŕô`L'?đ?őŐ ĘT̖@I˘žŕ_îC?đ?ç;śz’Çĺ@Iˇ@aÎś˘?đ?ěecrĆ ’@IŘľź1t”?đ?óݔú Ôş@IôŠ=}Í?đ?řĆJ™ˇ@J €2ýČ ?đ?űHz˘¤O@J/Ӌú5Ű?đ?űu`ŽOD)@JSćÚŰë?đ?öČÔůÉóZ@Joźqh‰?đ?ď%‹8FŃś@Jzd7Djc?đ?ŕ"ě#Šq@JqŃž‚p”?đ?ĂÜăEëtÓ@Jtˆk‰?đ?ÔсÔOő@Jšë) ‰Ĺ?đ?ťíڀŚƒł@Jź§¸5uÖ?đżÜE%ř™ÜĂ@J֞Mgńv?𿰀÷Cä@JŐ'ř÷œk?đżÁ×Dş7ő@Jó7ś1{0?đżÎ˛›@KT\ü2?đżá 8˛ą“ç@K7 ™TŤÇ?đżďS—˙ʈň@KK? Ů°?đżôϨźÄt@K^ﱉ-;?đżöѧŞ;˝@Kƒ>ľó–?đżřéF •qg@KŚˇť&f?đżű@ů#s2@KĘăŢ0…?đŔ-Í÷6<†@Kç\?đŔ] OÉ&@Kül âýś?đŔöúß E@LŃBRŒ?đŔ ‚ Ăf>@LfL^ Á?đŔ Üœąg”@L˘ßśSó?đŔSËM9@L‰ Ď !?đŔĹB˘ň@L1{߅ö?đŔůwŞř<Ú@L8lĎb?đŔ¤*l@LI‰Ŕć ?đŔmrÖUťĄ@Lg÷ěˆř[?đŔÉě;ŢŰŰ@LŠ@Ź?đżţl~TĽI@L­#*Œ#?đżţćěŕ]$@L̆U6Â?đŔůË݊‚@LŐşˇÁ?đŔEîězŃi@L×*őâéę?đŔ ™ˆÉů”˙@L×÷ÍMéś?đŔ˜) á1Ú@LĚl›P{Đ?đŔţ˜c<D@Lć+Ú ç?đŔbĘőâŮ@MŐÍZ˛?đŔ .§ŞZ@M:(ěr?đŔ HËCmb@MFbŒ>Xe?đŔ #2e‰Ü@MLxË \Ż?đŔ§P!@MD*W6&/?đŔčžü Î@MF*Œ4RX?đŔ~íGa@MIfI5ƒLŔ\˘qđá|@R'<ĹwkL?đŔ\Ž9.;@R0,(S?đŔ\€iĘkŇ@RBÍ7?Ś?đŔ\”Ł+ Œ@RSŠgF9?đŔ\͔#žsa@RQ,Gţ$Ć?đŔ]ćÇÍ|@RHMąé?đŔ];Q‘ŒĎ,@R>PPlÚ?đŔ]h¸­šË@R2Ľů…v?đŔ]’zý5ŕP@R%3ZŤ)?đŔ]•óR@R¸ŤÁ_a?đŔ]´śŽŮëô@RĚŚŒ?đŔ]ŔońÓ@QíFr8Q?đŔ]Żš(-@QčČśĘq–?đŔ]~).g÷)@QŕÄż´ţ?đŔ][@uű˙ @QŰ8ŁsÚ?đŔ]ĄŠ$šű@QވŽFÎ$?đŔ\ŕa7€Ío@Qáx0ÝV?đŔ\ďńg$ž]@Qܑůƒ1™?đŔ]Źţ@QŐč-§At?đŔ]HŰŞ- @QÎ}ŤJÁĹ?đŔ]~޲aé@QÇY9ľť ?đŔ]8^1ş~@Qš%.}Ň?đŔ]f׽ϝF@QŠňWƒšń?đŔ]2­F‡T@Q§D SĄ?đŔ\ü×=đ@QŚBÍżŇE?đŔ\Ă[œz@QŚâo yš?đŔ\ŒËâXlK@QŤbÇŽM?đŔ\Wj1­°@QŠ ’9ó?đŔ\$žI´~Œ@Q˘Îť?đŔ[ďÚbo@Q–ˇźC¸?đŔ\AŠ _Ă@Q‘ASëRM?đŔ\4ScG‘@QŽÄĆW??đŔ\m> ˙Œ@Q‘–*˜•Ď?đŔ\˘ßgPSS@Q“*Œß?đŔ\ٍzž@QŠükŚ‘?đŔ]ߡ>ˆ@QŒmŹÜŞ™?đŔ]BŻ˝ôťN@Q†Œć+|?đŔ]UDG6.Ž@Qx˙$7ü?đŔ]6°tŐňƒ@Qgw_űnc?đŔ]&ü•ßő@QZ†îô—f?đŔ\éÇ(˝@QQ [ĐL×?đŔ\śŢΧ I@QP™‰bŮ?đŔ\yyÚ^ÉŠ@QN¤UBI?đŔ\g¸ŠHF@QB2đ×á?đŔ\cMŽŽ…š@Q06Ň?݆?đŔ\HŠĆ‡ @Q ^Íę?đŔ\{ݝŽ@Q oą`Ż$?đŔ[ÝSăaË@Q"đlƒˇę?đŔ[´q‚„Ä@Q%€˙œ3?đŔ[TÇv[}@Q'ČŇŕB=?đŔ[OĆlé@Q,ßS‡_B?đŔ[$őՀž+@Q8C 8Ł?đŔZőكK\¤@Q<˙´ěh?đŔZË12`¤p@QFóňü=?đŔZ°râÓڕ@QXĐ “?đŔZ“ŐsĘ}*@QPfí+Ňę?đŔZllńo:@QI-jĘî?đŔZDŞć‚'@Q?âçLJ?đŔZQĄQTś@Q9AľdjŒ?đŔYădLţ†@Q4† †[?đŔYą¸Ěźő…@Q6PĚt?đŔYT€oçw@QD  ¤ŕ´?đŔY1bî@QWŽWM ú?đŔYżřŠؕ@QOěĐŚ?đŔYÄjô&pŮ@QW.<Š8??đŔYŐ`kƒyż@Qe!=Ég?đŔYľPކ€@QhƒÜžĆˇ?đŔYÖ&´[P@QsÄę“?đŔYXÓj{@1@Qoy  „Y?đŔY:T—ôŠ@Qx˜ŇhŠj?đŔYOŃÍŔž@QˆÚ 1&‡?đŔYy(ÝHŇÝ@Q’Š8Ë8[?đŔYśÇŒşŽË@Q˘mŠëҸ?đŔYÚ.‹uľŤ@QĽĂăfl?đŔYţýZ¨7@QłMŻ=͆?đŔZť˘ZE@QĂč›Wí?đŔZÜ|KA@QÖäá0z?đŔZW;ž‰Ż@Qé eť>ś?đŔZ3Ž9P§H@QúdWč?đŔZA˙ë> @R sűq?đŔZOƒłýĘŞ@R^5ZŐ,?đŔZZ‡×Ě7|@R0JĽ]_?đŔZvŇ~ďq>@R@šű(Ś-?đŔZĽV Ě{ń@RN&‚Ń?đŔZĺ [†Äć@RQYŚ?ü.?đŔ[ #UŞ1@RF>Öu×?đŔ[ąĐG@R1Ú́2?đŔZůš!@RťĂoˆ?đŔZđ Č˙Pm@R 6P§?đŔZŰPć€@Qű+Q„Ů?đŔZësťBöW@Qí ťň(˙?đŔ[ i20ˆ@QđÚWŐí?đŔ[”™(§Ń@R—`_?đŔ[' r¸@RŽe`/?đŔ[8%HJöc@R&óţĐbë?đŔ[‹qé,@R1e”ĎHĘ?đŔ[‡9l@R!ͲĆ?đŔ[˝$˝°ZJ@RĎŘ:~?đŔ[ă˜)32p@Rţ2Űý?đŔ[ít´}ë!@R¤[z”í?đŔ[Ôšétá@R( ]­Ňă?đŔ[řĂ3Lę˙@R6šVŮŻ?đŔ\60Šaľó@R>6 Ú˛t?đŔ\b.†ô›@R.Ěőľ0?đŔ\Šz§Ü@R'!7Čá?đŔ\˘qđá|@R'<ĹwkLŔU7Ë+Ź ›@5Řn#×ë-?đŔU#ÂÉC)ő@5ß=ŐË,?đŔUˇ ƒ…;@5Ű ńžŠĘ?đŔUlç@5ýČ(^ô?đŔTóˆoU@6+˘řAőw?đŔT߄EěŒ9@63•Œ¸ ?đŔTĎSŸŽ?đŔRŞśVö@4 4­ľž?đŔR‘7­˛łU@4*á.ZžŸ?đŔRžĎSźýś@4\r˝٧?đŔR­š˘=ßj@4î„ţ?đŔRŔżŮS|e@4ŹĎ[WÂ?đŔRÔsü˛ň@4ł”tz”?đŔRé ŹŠč@4Ćé\š~h?đŔRëTÄ?fÎ@4ýóŹW˘X?đŔRýŕ rĽv@5›c`q$?đŔS ćtĂÓ @51§Ť(8é?đŔS"ŢWôR—@5?qíŞş?đŔS1úz^†2@5V÷ԁ.Ř?đŔSD5‡bÔ@5…%_ą[?đŔSOĎÔ}@5˜+ՍŸ]?đŔS^Šx#"@5×Ô 4ś ?đŔS[ŃĎ;NW@5Ŕ~Şş7?đŔS^ŘxĘőI@5˝_Łćá?đŔSsŕ‰=ř@5á׊ëÄ?đŔS‚F@Œ@6â×čč|?đŔS’ŕ•ąHˆ@6-ş› ¸?đŔS¤=k#¤Ç@6N”1žš…?đŔS´4bLě@6_thĹÂ?đŔSĘš\L@6cˆgş?đŔS܁ćA'k@68T…?đŔSęhŚę˜@6ľ¤MíýĄ?đŔSůÎ*"Ŕ@6ß˝Áúwć?đŔT rÄç@6îĐ˙É?đŔT#^#@7 (-ÉÔ?đŔT2xfV{€@7°F}œ?đŔTHę hÔ@7Xš>_?đŔT[C4gô@7€3ç°?đŔTlš†×>@7'ZR˜ČŸ?đŔT€pş˛Â´@7,Á¸ŐCt?đŔT”Ą×ʤ@7(řg`=?đŔT§`ŇsÁ@7 ß>+ř?đŔTźo Ţr@7”˘j ~?đŔTÎĄq˘î@6÷ ĚüŒĘ?đŔTáD|Pf3@6ÚrŠP?đŔTô§e*Ə@6ŔŐ˛š?đŔU*|/F@6˘˝ÂXF?đŔUמQŐĺ@6kś#Óe?đŔUŹęX“Ÿ@6 ČŞś‘?đŔUmÝvu#@6žŒ~ˆb?đŔU2Ő[E/Ÿ@5î,ä@n?đŔU7Ë+Ź ›@5Řn#×ë-ŔKáx‹üuG@IĹX<Ҕ?đŔL ‘żŠça@IťژŚ÷?đŔL>dG>]@Ił¨ÁČg?đŔLd™C @I™˜˘ŮAĎ?đŔL~qPëi@I{ęqMŻť?đŔL ČçĹÓ#@IUđ&IÎ3?đŔLş˝í(oÝ@I9ˇNBďą?đŔLβpţ˝@IÉçËS?đŔLĺ4ďU@@Hô`9ÍÇ?đŔLđ˝´ -D@HŃ0…?đŔMÁ…tÉ!@HąĹż‡yÇ?đŔM`Lź' @HŸ9Đűč?đŔM){‚r@HˆŠç^ń„?đŔM_˝žšŠĺ@HY9˝€eô?đŔM‰řBŕ­î@HK…p:ž?đŔMGş`'B@H>™sˆđ‹?đŔM`9kJ$@H%‘/ˆq?đŔM‰?#C@H e˘ě>?đŔMޤmâ@GďŽƒŕ?đŔM•nŐ?ŹH@GĚßćWԖ?đŔMWNąpŮ @GΊ„<Ë?đŔM'ِ˝ý˛@G×ʙg‘^?đŔLň 5ßDl@GԊ(—Ś}?đŔLş<•Ä$/@Gχ`Ř?đŔL†(Páö@GÉŇ°ňą?đŔLUŇoeëŠ@GË°÷§ĺB?đŔL_ÜŔŢ@GŮĺULŠ?đŔKîh oěű@Gë˜kú?đŔKćňüA@Gß…‚w6?đŔKú^‘üvĘ@GĆČNęDä?đŔKŕSş¸ş‰@GżzČkü?đŔKśuŮÄ3@G̏-“9 ?đŔKŽÚŁsű–@GԉNJ§?đŔKsˇ˘ÜӍ@GρoÄť?đŔKšëAźČš@Głäj*!Ź?đŔKťŰó0qô@G•÷“H?đŔK폺‘î @G„ë|P˙!?đŔKÝćłPŃ@Gpaď× ?đŔK¨‹2ň"Y@GyL/|Oœ?đŔKˆëťúz @G”RţŻŸ?đŔKT˜q‰­@Gś=Čg’ ?đŔK9u´)ŕ@Gť˙–’?đŔK śręş×@Gă bpŒŰ?đŔKßöÍí@G䢯ńć?đŔJńť¤ęyţ@GźdĹäť?đŔJţFő€„@GŸIoć¨?đŔK,`Ěo@Gz$ąŠ?đŔJüě0ĹH€@GnPu.ƒS?đŔJŐŇ˝ŒÁ@GŒeŞéž’?đŔJČŻ&Yĺ@G„/)tÍ?đŔJĂÔÜť˛@GaT´a2?đŔJ‘•äҌŽ@GXÖŔ.˙?đŔJr}Ń (€@G|ŽŠó ­?đŔJg芡€ě@G+Ďę‚?đŔJ[ZXVŽ@GÎ,Ŕŕ T?đŔJˆ i .â@GžŔŁ-۞?đŔJš;Tś0@GÎ / ŒŽ?đŔJ€”;Ďů]@H˙#Ź”ű?đŔJŞ3ö+†@G÷m͖Č?đŔJĚ]r† Ŕ@GĐla\˛?đŔJçśVkl@GćOJ!C?đŔJ塧*@H RŤĺXÍ?đŔJÁę‡9°Ç@Hu„ÎĆ?đŔJŘŮö[@H@÷ó(i?đŔJˇ}_Šľ@HC"ps4?đŔJë><˛h!@H8ť–şI?đŔJĺiáOBÚ@HI?—ÁŐ ?đŔJ÷(ŠŘ.Ł@Ha6÷U‘Ś?đŔJâVŃ kł@Hó4"?đŔJȊN~Œ@H yG5ő?đŔJ˙.Ô¨ 9@Hˇąd2~?đŔK3•]6Đ@H´Tž KĚ?đŔKb•ŽSäŻ@HŽBĂq,?đŔK˜ÓrśŃĐ@HĽsĄÇŽ?đŔKş÷­ŽŃ@Hľ}d_ÝË?đŔKđ¨U“Ÿ@H˝…;bI?đŔK˙čŹ&@Hω!ď ?đŔKŮ´Eép:@HńN›7 ?đŔL GoČEÁ@I ¤)Ą?đŔL3Éß ’ú@Hö' ţŞ8?đŔL]7KFY@HÖ*R]űő?đŔLg˜ë"ă@Há9ľT÷?đŔLYÎâsĽ@IPw>PŻ?đŔL;˘4=Ţ@I(™‰´Ď?đŔL‘ŕôO@IDöw/H?đŔL"VRÄ?@Ig璝ô?đŔKĺ' ąć@I„3mň?đŔKűíd:@IžK|WÓ?đŔKë7ŮĄĆé@IŤň‡’JŰ?đŔKÁM*Ü^q@IżˆŐkJ3?đŔKáx‹üuG@IĹX<Ҕ@fÚ –:źŔCÓ*>fˇP?đ@f΂1î“ŔCş{%˜ŐÇ?đ@f# „ř|ŔCšë¤Đľi?đ@f-Çđ­ŞśŔCŠŻ„q¤#?đ@f9ą˝¤ßŔC’ś°kŕ˝?đ@f=ź„ŃpŔCé’aľÖ?đ@f>ƒîO˛]ŔCeşźm?đ@fFZšŇOŔCMô°Š`?đ@fJplGEŔC,Ձ—vP?đ@fKšs+ŔCĎşoÁ•?đ@fOvĹqQŔBßÍcĂź?đ@fEeůˆ‘ŔBČPŽŢc?đ@f:nšîËŔBÔYŔéé=?đ@f2ĚŤ śŔBď7›M4?đ@f&É"ŕ3ŔB˙4˛ `&?đ@fÉ,B?ťŔBöfďšu?đ@f3ŁŔBćé?^Ĺf?đ@f!ĐpĹrŔBĐŞôŸ%ç?đ@fP3L†ŔB¸§|Ń?đ@eüٍđ];ŔB“uÍöyW?đ@eů›Ť2Ŕ-ŔBm…é^’?đ@eńęw}œŔBP7kك×?đ@eď–O|čęŔBgháŻwu?đ@eńů“ĚţŔB“ź& _‚?đ@ečːTEĹŔBƒşg€Gj?đ@eÚě˜a?/ŔBoĽ3/?đ@eŘČlÚŤíŔBSęä„Íp?đ@eŘ㎨.üŔB2°SpŮ?đ@eÔçĐíÇŔBbťy|?đ@eĎ dI÷ŔA齡j?đ@eЇ,É2"ŔAÍľo;ť?đ@eɈˇ—ÖŔAŠqpŢęľ?đ@eÂ?ź™GÁŔA—Ţ€nCü?đ@ešPOaâuŔAƒťÁ§`ž?đ@e­ŰŤń¨ŔAv­VíIřŔC‹ÂœŐ?đ@e¸Ę€uÖŔC¨!Z|Í?đ@eżš¤ŔCÄc˜§?đ@eʓŠy8ŁŔCŇýÍJ>?đ@eÔ-Ž?0ŔCęwGűí?đ@eߐnÓc8ŔCů-‚UŇc?đ@eçßśÎo„ŔDŰ4d?đ@eçPr”rŔD3ž,Ś?đ@eä 'ńpŔDY:G•8h?đ@eÝĆ°§M7ŔDzËxŁş?đ@eÖĎŢł09ŔD™şn5‚H?đ@eŰÇŹe­qŔDިhVŻť?đ@ećÄ­P°œŔDòéľ"?đ@eń?`ÚŔDŔ%‹đ?đ@eúýűŰŞIŔDŠĄ-ŮŐć?đ@f„ˆ´—)ŔDg“?đ@f-í­ăFŔDlôçűU:?đ@f^Ď}oíŔDKú;ĎB?đ@ftŠ/–ŔD,Bˇß1‘?đ@fžzş€śŔDzk3˛Ž?đ@f |Mx'–ŔCৡ+ĺ?đ@fÚ –:źŔCÓ*>fˇP@^9]ÉŞ@2yĘ9Ô ?đ@^€ť¸Ś!@2S)ä/[?đ@^l7Ű>™\@2U­S?đ@^\#á Ýť@2v "8sż?đ@^JÍwGŒ“@2™ĽCT,?đ@^7ë V=@2˜Ż‡úŠG?đ@^&t›Źá@2u ŠԞ?đ@^ XUÔÓ@2(n>Ă d?đ@^SľW@1ßZzŇźö?đ@^ş˜“@1˜φ@ ?đ@^×d0Ô@1N?ŸM&í?đ@^É­Ł˘Œ@1ëŹL0í?đ@^śÄ§Ď@0šnĄęüŽ?đ@^őŽĂr@0tŒ;#ëk?đ@^űŐšÓ@0(ŻI­^?đ@^ ńg˝@0LÉżĹb?đ@]řŚyĚ9Œ@0I?ęô‘˛?đ@]ń˛§‹çđ@0P>(ă?đ@]ů1áR"ś@/0úmě?đ@]ű ť=Œö@.ţş$ńÄ?đ@^UrÔu9@.s˝Ë†'Ž?đ@^˙‹Ć@-Ű z.ŐĘ?đ@^m-˝@-‹ú7 /?đ@^ó7'‰<@,ű€^ŤuÂ?đ@^&ŮĐ>˘@-‡öWŠiß?đ@^8–Xb@-d¨ĐţjĽ?đ@^9EOMýÇ@,ézŁě?đ@^))ŔVv@,y\:iŕ ?đ@^'u8S˘@+őVŕČŤL?đ@^01+ŠĚř@+şć*Ő+?đ@^?ąwE›@+k44\Ať?đ@^SÜq†Ă@+DI­O?đ@^_˃$‚Ä@+ĄŤ”Ďż?đ@^rëĺ}@+Őć5ú?đ@^ƒĘ÷űs@+ŒuĚ6Ŕ?đ@^’ Rç@++ú#äÚď?đ@^ŁóÔ2˜–@*™2ÄĎ#J?đ@^Ś­>¸ă@+ ˝ąƒłX?đ@^ŸĄjśŒK@+˛šm˛—)?đ@^ŽFL÷ľŃ@+œˆŠZ†N?đ@^šĄ´×̨@+0׊\§=?đ@^ĘKs3T@*Óqř„x?đ@^Ň_› @*OšśO˙ľ?đ@^Ý7ˇÖ×@)üjüĐăt?đ@^ô{Ž‹E@)ĆB‹wšu?đ@^úF§şĽĂ@)AîŒ@Ď?đ@_oˇ‹ „@)Fâ4_”?đ@_Ăp…@)öc$k˘?đ@^ö )ß—@*2¤ę{5?đ@^ńŁÜ˝ÄÓ@*˜#ó˝ű?đ@^äę˝{*@+'ÔšJI?đ@^ô”Ű;oU@+v[€čŒ?đ@^î;5 ú@+żćÜrŐ?đ@^Ú˘ÂP@+öFSR?đ@^Íí R´@+ĆWŰy?đ@^Ád;ö3'@,#ťwz?đ@^ą›…Fţâ@,“‡>“?đ@^ t˛á…X@,Ÿ‘ŐÂáo?đ@^‘zĹą‰@,CÍ,S?đ@^‰DâĐ=¨@+ć-2Á‹>?đ@^vĆkřM@,$‡íôŮ?đ@^mźÜüSĽ@,ŸĆ*M?đ@^iQÜĚÝĚ@-?>ŘG¤l?đ@^gă›^S@-ądn˛’?đ@^_śHžÚŘ@.9ó2Šâ?đ@^[ :ů˝Ú@.źáżšóe?đ@^eTâd;@/P‡’ŹS?đ@^fŤ’Ů ‡@/ŮJm ěZ?đ@^|´Ą@0%âRć ?đ@^‡7Ž~(‚@0'˜8OpG?đ@^ŽMz_zË@0eÄükâë?đ@^–úČËĎ@0­š%č?đ@^žŽ†]@0ň/ĹëjČ?đ@^›ôeM‘Á@174§qC{?đ@^mCš@@1iH´˙žÝ?đ@^‰ąĚE–Í@1łŤ˝!'”?đ@^‹ź#@1ţş×óť?đ@^’jTĹŞU@2B¨‹˛OŇ?đ@^9]ÉŞ@2yĘ9Ô @eĂ+°ęT0ŔDÇLp˘ĺ?đ@eÄŤ›”7AŔD˘‘çs,?đ@eÂ{šáŃŔDi×üü?đ@eşę˙ăoŔDŽ“Kgi/?đ@eş čÚÍÎŔD~ĺýňřą?đ@e­ŰeÜG%ŔD”Ůúœj?đ@eŁ#‚TŔD›_‚ož?đ@eŸˆŒ¸:ŔDqđŠVD?đ@e–˛'C˘EŔDW¸2_fU?đ@e–›űáaŔDFܔŠŢš?đ@eˆbgXŒńŔDc.˜^?đ@eƒŒçHŽłŔDökœiď?đ@e‚ßY“5˘ŔD¨c3ô%ˇ?đ@e} vçžŔDĘR¤Enć?đ@erĖDžWŔDâ(ę¸g?đ@em*‡őÄíŔDţ8EÓ?đ@ei›ů^ő™ŔE"Fhâ\Ÿ?đ@el¸n…$„ŔE2‘;i>?đ@epçÇňßŔE-œVä“[?đ@edƒ>óßjŔEGÉĂą÷j?đ@eaO< ŔEjň‘<“?đ@e[˘ú ŔEr śđĎ ?đ@eOü‡ŮŤrŔE‡qÉÝD?đ@eH5ŞŔEœx4ŽÍ?đ@e<8ë“1ÖŔEźP$ví?đ@e1ĂEÝ-ŔEŃČ\5ZŇ?đ@e'S™ˉŔEŕ!hSł•?đ@e!˘Ä(ˆ×ŔEöWE– í?đ@e…35˙űŔFˆĂYEë?đ@eJgYV•ŔFm0s`y?đ@d˙~9|"öŔF1뀶ÄZ?đ@dů:JŔŔFR_nó0A?đ@dďěœŘ#ŔFmG˝Rép?đ@dćsˇgMŔF…ŔŠÜú?đ@däUřžŽíŔF˘;Î<Ş1?đ@dŕýóÍ"KŔF°ÖD‚N?đ@dŰŰx29CŔFż$îÇťč?đ@dŮŞ˘NnzŔFÝÚ}e|?đ@dÔ׾s ŔFůG7đ?đ@dŮMAv8cŔG ¸+¸ň‹?đ@dĺŚ%^ĆŔG ś3dŠý?đ@dó“‚ îŔG;ŕÂX?đ@d˙TRŃŃŔG/Şp†Řë?đ@e )Ü6ŒlŔG=ŠvđŠ?đ@eŇ ‰“|ŔGJlŁ´ž?đ@ezˆ†!řŔGQĘĽŚA?đ@e,*(62 ŔGPž* g?đ@e8 2BŻąŔG>Ôü??đ@eAxOŢ$uŔG" 4ü‘ľ?đ@eIwHŔźŔG¤BǗy?đ@eUdMŐŞŔFë@ýG!?đ@eXr‹´ŔFĘĽ&Ť?đ@e] ŃE•œŔF§“:ˇ€˜?đ@e`óÔ+SŔF:Ç"Ű3?đ@eYX˜"Ö?ŔFmŹŹěŘ6?đ@efkłń/ŔF\ŕőĘŻ?đ@ehPď~ě˛ŔF7Ę+ÖqX?đ@ecĆ°mľŔFŽâŹĆ?đ@ed˜DĐü?ŔFIÚA%ž?đ@eo׿bpŔF€b•Ň,?đ@ezŠĘÎŐnŔFí†Ďâ…?đ@e‚ŕ :ˇýŔEë-v^@?đ@exĎUĚ#ţŔEĚŚ@Ÿ[ă?đ@ep SÎ nŔEąľz@śA?đ@ejˇ°t;gŔE 7?*E?đ@exŇ­\ťŔEÉßÎwď?đ@eƒ! ĎŤˇŔEá,ů` Đ?đ@ebp÷ÉŔEćD’nOR?đ@e”ÖBŒťÜŔEëşCŽĘ?đ@e >á€2aŔEă‰/ÓE4?đ@e˜jJ2„.ŔEɗJ‹ľ?đ@eŒPT}ˆżŔEźţöŸH"?đ@e†="œâ-ŔEłŤ^Űm‚?đ@e“#…ŔEŠűĄ)+2?đ@ef=ŠÂ@ŔE Ô΁˛Ź?đ@eš„€ç_ŔE—[ Öj?đ@eĽ@oL.DŔEŻgʕ?đ@eŹUčéňŁŔEe ‰áťŽ?đ@e˛2žs"´ŔEAýdNó?đ@ešľkuˇŔE&é3ü!?đ@ež…ż„¸2ŔE YIÓ¸ľ?đ@eǁ!˧ŔDĺ¨&טĘ?đ@eĂk˛žZqŔDŐi; °w?đ@eĂ+°ęT0ŔDÇLp˘ĺ@[‚6ԘHÔŔ•–j°:?đ@[“ AlކŔ  Íˇ+ä?đ@[¤Ă!M“Ŕ Fâ=ĺ$ä?đ@[ľţM=o Ŕ k…ţPŽ?đ@[Čb'PƒýŔ ‚.źý?đ@[ÚďÇYó[Ŕ “ú7ĽS!?đ@[í`Â2[Ŕ ŁČ0ąh?đ@[˙!Ř1†Ŕ ™á@EYp?đ@\DMĺWéŔ ŽÁNŸb?đ@\$r Ô[Ŕ ÔD$˛ˆß?đ@\6Ż9PßŔ ÇaĂž@?đ@\H ;( ŠŔ ”đCvń_?đ@\Yç‘ŢVĽŔ şÂońQ?đ@\j˙ ňçŔ öß{Úpâ?đ@\{Ĺßůý†Ŕ!*MϗĐx?đ@\Žn‹kŔ!AěéÁtź?đ@\<ŕŔU Ŕ!=ŰYł?đ@\™WÆ7“Ŕ ogöwRń?đ@\œÁŸQ:Ŕ´‘NV˙ó?đ@\’¨ÜV#kŔń.)¸Y:?đ@\€ĚwsŘłŔ¤;!ü€?đ@\n9áťg4ŔŰUú5?đ@\[ŚeínŔő+Ÿ WË?đ@\JÍ˙ÓŠÍŔéBنT?đ@\9‚éčč˙Ŕrń‘Ţ›ł?đ@\2œj<+ŔĄźľi<í?đ@\+GQfŔąLNj7É?đ@\"”í…ÖÄŔą­Ëż?đ@\GÔ-:¨Ŕ•Z7 Ä?đ@[ýí hMŔNtXd3?đ@[ě0%ŽčoŔôÝúeo?đ@[ۘöéwËŔśőћĺ„?đ@[ÉbčZŔ•bywF?đ@[ź¨Vú 2ŔžĆ­Ţˆ ?đ@[ŹboČŔ+Řőćř?đ@[¤ÜZRôbŔBŹR??đ@[–J] ą$ŔĘźřřFë?đ@[„ľÚúç8ŔĄK¸Ůhˇ?đ@[q‹n°PŔ¤H>?đ@[_;řőGäŔdšşý?đ@[L‚IŮa=Ŕp´}ŢR?đ@ZzýֆÍŔ+† ąH?đ@ZtţÔ¸ÜŔ@ĎŹ;E?đ@Zk9_Ý|ŔqSőÍ?đ@Z\ö›ăK_Ŕđ˙ Eľ?đ@ZVa'íŹ ŔHŠ:’ä:?đ@Zmî 9nŔhgn-?đ@Z€;6NŢÉŔb.˝ş?đ@Z’ŇW ŔŢa0›°?đ@ZžQ ]yżŔd[Ź˜ü?đ@Zžpň@"ŔxDţNçV?đ@ZąáŚ kŸŔľgÍbüń?đ@ZÄżíJŠYŔÍF•>¤?đ@Zל´ŒÝaŔü”BŠÖCŔŽ#dŚ<ď?đ@[Aý=ÉÚŔŃŁS2óŕ@J[; ˝?Œ?đ@aˇšßŧ2@J8ľjh?đ@aľI:GxY@Jë˘[?đ@aśËۑA\@Iđň‘Î{?đ@aşďc%@IÓvź)Ů?đ@aĂë#Fă@IŻc9¸ƒ?đ@aÇŁˇDR:@I‹ | áÔ?đ@a΁;Ť@IgI8ˆ ?đ@aÂKáö“@IB2űŢ ­?đ@aÄń_ȁŽ@IŹęü~?đ@aÄŘy°*!@Hřł# 1?đ@aÄÄ Úç@HÓýq Ă ?đ@aÂ⇚֖@HŻTN kU?đ@aÁ Źž#›@HŠÄ#ÁŁ?đ@a˝ŁqŐ@Hfšęş`C?đ@ażxÁY{I@HCĹWaI?đ@aĂůŔOS@H!—-Ĺ܈?đ@aĹڊě/@Gü,č’ę?đ@aŔqÔĽA@GŘá˘DŽ?đ@až˙ÓnJ@GłŒ[’ž?đ@aÁcžU´^@Gp÷ÓĐ,?đ@až:˛ Ą@Gka w­(?đ@aş–•ÝçŰ@GGą‰?đ@aźwž pÄ@G"ˆ(S‘š?đ@aÌwM… @GO;)H?đ@aĘüśf~@G69‰HK?đ@aÓţečiđ@GUXďgŚI?đ@aáI)¤‹Í@GKƒÉŐÍč?đ@aęΐ>đ@Gó!@GXrD&h?đ@aço2:ł@GevEňp­?đ@aá}ďăć3@GŒ;Ę N\?đ@aÜV"Ś¸@G­ÄmI9X?đ@aÔÜUă˘]@GÇé]SńE?đ@aŃYýć č@GěŽ Ň˜Ŕ?đ@aŇďџ@HŹW‘ť?đ@a×lˆďB@H4¸5Ęß?đ@aŰ_[ů¤E@HWÜö0?đ@aßeĆ@H{n˛łî?đ@aäżIşř@H›ŠŒÁw?đ@aďՉ>ňy@HŞĄ(öŒf?đ@b ăhJˆ@H  +œű?đ@b ‰œ×n@H‡FW¤Č‹?đ@b—u“Č@Hj z5?đ@b‘¤rGÎ@HcŽMĐ ¨?đ@b ›xj˛¤@H‰řkÍ?đ@bř‹ŁŒ@H­:H§?đ@b Ćštż@HŃW÷Űĺ?đ@b:jG@HôÄc5šČ?đ@aü.IÚş-@I>CšVY?đ@a÷ŘONŹ@I:P/źą?đ@aőŒÎť“X@I^ˆLŤ'k?đ@aňŠÁQrĘ@I‚ŸĘ1‘B?đ@aďYłŻx@IĽŽ+<áh?đ@aę\Ňäâ@IÉÄt€ŇS?đ@aćÖهÝU@IîŠţ/í?đ@aär'•&W@JęąeBű?đ@aĺ‘ÔUˆ@J4aŻĐ?đ@ačřsď$ü@JE^á5ťQ?đ@aęáYX<@J}1şŮ*?đ@aćŸ(ýԚ@JŚÚmöč ?đ@aá˜N%ůŔ@Jǃ^ Ż?đ@aÝßě˛(Ń@Jçkľ5f?đ@aŢĂýűĘ:@KOôŞ)r?đ@aÔ#ƒü=@K'ĎŁź!?đ@aÍŔh"ká@KÚmš?đ@aŐą<\X~@Jń,ŸÉ?đ@aÔ¸á‹l@JÓăýăäg?đ@aɎBKC@Jˇ~&ĘŮK?đ@ať¨DJŁă@J°M€p‚?đ@aşľƒŐÄ+@J˜t ‘)J?đ@aźŒá•U@J›d´&Ĺ@_[1ŮM8Ů@#‡}Í2q?đ@_[2ěžĺ7@#&2ľĚ.f?đ@_`gŕ‚ĺ@"–„eq†ć?đ@_]S>†ň@" ĐdŕMË?đ@_Jt=ÓP@!äEmg9?đ@_6#“á@!ŰOדţ?đ@_0ŃŮÍ\@!2-řĚ­?đ@_$ť˙[1@! ‰ŮŢ´p?đ@_NÓÁÖ@!š¸ vî?đ@_ œO’Yl@ y]bô™Ü?đ@^óńyo]j@ \pŁŕ?đ@^öž!żs@ eœuTŇ%?đ@^ó­xlp‰@ ýšd’„ ?đ@^ĺa¤o@!Hýʞńů?đ@^׳mGJl@!>đ›4ž?đ@^Ĺż”&@ řÜÎ “?đ@^˝=ňmť@ tlţ'Ô?đ@^ŹhfkŰ@ <÷8šŚÍ?đ@^š;ŮMËŐ@ qŘS ę?đ@^‹qeeŃ@…0iKŚ?đ@^†ă K˘@lě˘ęŔť?đ@^ŃÔ*@RŮĎ?đ@^zᇈä^@<ŇSŐ˝?đ@^‰&T(Á@Üt¸Ű$=?đ@^’7ÓlÜ^@út'Ď ?đ@^›ű„ ý@ Cž"iĽ?đ@^Ľ|GŞ*}@ń&l?đ@^´RF<0@S.Ő?uŔ?đ@^Ĺ%˚2@WM F¨—?đ@^×$‡ŰaŢ@ôˆoqĂ?đ@^ŕáLx?@ŞßđyŢ?đ@^ňŁ†čk@ó*z*Q?đ@_ác@IV@dńŽ2“Ý?đ@_ ŐqLw@dŸv5ß?đ@_ÉeÁżD@`o…#Pś?đ@^˙ÖIÁ8@Dˇć=?đ@_+|p*@!Y›œő9?đ@_ †pš/ž@t„.ƒ?đ@_XékMˇ@tGż˜â.?đ@_)ގäć_@č§3ĘF?đ@_;ŒĘX˝‘@‚~5LX?đ@_Ij?@˘ę™Ě?đ@_O€ď—°@ÁfN/×?đ@_Q2x2d@¸šÓ5p?đ@_]ęNr@˘cžË*`?đ@_h%p~ÉĄ@™îćFj‹?đ@_kË0łľ @łB}…/đ?đ@_e4ĺÝŮ@МjŚí]?đ@_ZC‚ć+Ü@Ť1âźÚN?đ@_`W˛ €Z@ÜFłÁ&Ě?đ@_ođ‰Ć@řE iŕm?đ@_|cŁ‘ő–@%GŠ+ą?đ@_„_ĆUĐz@[ËŮb?đ@_‰H`Ô_@Ť1¸(€C?đ@_Ž2˜ůa@ťţp!ĺ?đ@_I—7Ň@ZU_ÓĽ'?đ@_›~ěh0@ ĽĆ˙3i?đ@_Ľâ…é@änŇ!?đ@_Ľ[Ś‚Î@1´Ç% ?đ@_GU‹h9@.V^$?đ@_›‡›żˇ{@ 8‰ě3)?đ@_—¨jŇ؊@ ˇxŐĚL?đ@_ŽdCړ/@!,4Â43?đ@_“HűIh@!š§\ĄŻŁ?đ@_‹™x*W]@"bě\ ˛ů?đ@_~Ý'Źř@"ĹâŢnÔ?đ@_riˆüM@#tÎ9Ä?đ@_că}îŁz@#sŞç/ť´?đ@_[1ŮM8Ů@#‡}Í2qŔ-§MŠ“@P—ÂnĆhš*@PX ÁN_?đŔ5‚OƒćŕĎ@PiHÚŠlč?đŔ5gPCÎw@PzŠĘ}×?đŔ5śžĺS'@P‡dHţŢű?đŔ6>ücFGĂ@P–˙Xf+?đŔ6č°×bf+@P›Y‚˜?đŔ6ąi‹i¸Ś@P“č;3V?đŔ6ĽĄbgţ@P.Ţô–?đŔ7<‚ľĘ\(@P†wPÂ>?đŔ7‘޲W@P}hó’?đŔ7„Ź‘0ťŤ@PqšĐ9=?đŔ7Żz|4Ł@Pl‘&e–?đŔ8!‚vn‘@PdůaĹQ?đŔ8ŃI|j@P]œ0—Ďŕ?đŔ7vćÔi‹@P^ŒĎŘŃ?đŔ6Ë(XőŸ@Pdl/G?đŔ6$|G‚Vœ@P_J÷Šš?đŔ6b—ś^Q@PPÎEX?đŔ5ü§÷|´@PH-îÂ'P?đŔ6@|kBŻ@PBˆ„ŞŚ?đŔ6éđD@P@6­Ę˜H?đŔ7˛wÎ ľ˙@P8 ą+Wý?đŔ7e[92ćÝ@P3@PXaŃ$ž0?đŔ,c{~`A0@Pe×fĘ ?đŔ-DéJ/@PqŸYVmŻ?đŔ-Ë2Öh#ě@Pƒ•Ĺ—Dó?đŔ-ľDTlĘ @P’N:äU€?đŔ-§MŠ“@P—Â.?đŔR>KfM“N@3ëbB ?đŔRQbäI@3Ţĺ8DÄlü ‘Ţ?đŔQŻ6@2`ôvЎ?đŔQĄî Ű@2B(Tzďv?đŔQŒ]ůÁE×@2@•<\Ţ?đŔQ|„kŻÂ@2maŰî€?đŔQhą¸‚@2nę*Ŕ?đŔQU)Ý f[@2nnC› ?đŔQAü ›Ů:@2g -֔ě?đŔQ1[‘B|@2Eżç˛\?đŔQ#˜Ęš†@2TľÄĆű5?đŔQ"ĽÝ+=@2“ ÂMA?đŔQ#Íľ8Ň@2ÍN Ÿ;™?đŔQ3†k’Ć@2ůˇUÚŰ&?đŔQFn+źđ@3œ°. ‡?đŔQ_Źw!@3‹8 Ý?đŔQQG­đf @3={í Á?đŔQX ]§°@3Seńč;?đŔQllŐ_@@3OɁ´(#?đŔQx8ÍţY@3‚➃l6?đŔQ„˝ńŁ @3Śěyš^?đŔQ—Bpfj@3ľ`g A ?đŔQŠęxˆ&@3ɖŢë­'?đŔQź‰â}eî@3ç*-,!ż?đŔQĎň9_ß@3Ů6>œYÉ?đŔQ䞧†˛@3ă6BůZ?đŔQôŹ\+›@3ˇßqSçű?đŔR†-v×ő@3źJş…č@a˝ŕš`E˛@FÁ—“%†h?đ@aˇTwő‹'@F´T­ľ€„?đ@ał†q]ţ-@F“źđüÓŁ?đ@aˇôpűä@Fp . Ô?đ@aš…Ň(@FK1VWđ?đ@aľč;Ă@F'Qž,š?đ@a´éáWS@FM›Ą˜?đ@a­Ě]ň%0@Eăé߲T?đ@aŹq]‚#@EŔäT„˝Z?đ@aŞĎ´Œü^@EžhA°Ň$?đ@aŸź—)Ö @E˜ ~đn´?đ@a5Ýy‘Y@EŁ}e|?đ@aŽť˛Ť€ŕ@E›ÂlÜ?đ@a‡‰Jv @Ec÷Fv[Ä?đ@a||˝5Œ<@EMaż°Ť0?đ@az =sK@E%¤ďZŠ?đ@asn3üś@EôúzœÎ?đ@a‚đŚ=ůĹ@Dćj‡(Áˆ?đ@aű÷'9<@DžÖFWľ?đ@aŒ{nÜu@DĹD´A­É?đ@a”łźú\@Dá9ŒŠ?đ@a ¸0RČć@Dߛ3ĺ?đ@a ý­|Ë/@Dň“ˇh3?đ@a—3Sƅö@E §ú?đ@aŒ4ŽŻry@Eś Ď?đ@a‹ŞĐ´ˇ@E;‹´Vć?đ@a•÷l­@EFwiš?đ@a f/ź*@E/Ňývˇ?đ@aŹé6™_Ä@EEϚ¨Š0?đ@a¸ń˝Ĺ@EKĐ;źYH?đ@aĂő÷@E9 I1ŕ?đ@aÎJŰýŸ§@E$9]Ź`ä?đ@aŮ^\9—~@EßÉ3&Ä?đ@aćęaWřl@Eľ|Š N?đ@aëěVŐą0@E+îöěC?đ@aň‡›ýbÔ@EL8šRő?đ@aűŒjkÇ@EfűnD?đ@bŸżŚ<†@E{Űř?đ@bOłÁÍ}@Ey4Jg¸?đ@bˆ†Ż&š@EƒR0Ű ˆ?đ@b1?‘C•@EĄƒ÷Ćł?đ@b*d0Ą–'@EކřÎ,L?đ@b%uçsƒ @EĎóÚăÝ?đ@b$SĺÜ@EňnaŽľ?đ@b*k‹@FŞöŒÎ?đ@b% Ň̝ @F4‹I.r?đ@bĹ‹zh@Eý\ĚVź*?đ@b­!ß`\@E÷ůŁ5ę?đ@bă~3‡ę@F >qĘŢ?đ@a÷ÜÝƏE@F)ĆŔĐ@?đ@aí[řlľ@F)c{Î?đ@aă`ó˛„Ę@FA91E?đ@aÚ=úŻçŢ@F[‚ĐŠ9?đ@aŇ´Ąť´č@Fy¸ĐŢa?đ@aĘřVű@F—Nyt.ň?đ@aÂdĂ4F-@Fł>ÜNdż?đ@a˝ŕš`E˛@FÁ—“%†hŔ\-Źi€@S zĺlŇş?đŔ\l+ý¤ˇ@S˛´ëë?đŔ\Ąšä‡@S“9 ¤?đŔ\Ř+‹Ç@S3Tů)0?đŔ\ű¤(šŻó@S ů"í†?đŔ]&§UůŁ@R˙zőŸ ?đŔ\ے*áČł@RřD=ëNE?đŔ\đ[˙pCe@Rő,څW?đŔ]=hՔYÜ@Rí.5ˆzp?đŔ\ń"ĺ1Zę@Rçó´W?đŔ]âQÍv@RŢŢ|Dä?đŔ]\łçćœŕ@RŘp”S?đŔ]J,•˛˙o@Rʗ@c^Q?đŔ]S§‰@RĹŘÄf3Ń?đŔ\Ăäř<ÚZ@RĂÜŇgĺ?đŔ\ƒ0Y’{A@Rԓ­Ł„Ů?đŔ\q6v×+@RÉ@•‚ďĄ?đŔ\)Ř\‰d%@RË Ł"N•?đŔ[Ý\RzV @RĚKpó".?đŔ[ŮꒃÇa@RÄÄf "é?đŔ\ćI`–K@Rż€óľ'u?đŔ\VŸŠ13@Rˇ¨Ă‰ůČ?đŔ\Ž^ř˝”P@RŤOŤáë?đŔ\cą›ŹD@RœFgÔÓř?đŔ\ A„Żţ@Ršă|KűP?đŔ[ŕ§Qu>ý@R˘KcÓ\Š?đŔ[¨‰ÂTí5@RŻ*Á僠?đŔ[síB‡˙˙@RˇA[Tb?đŔ[0#Q;™@Rż@rke§?đŔZď…_L%@RżBN˛@IçźÚÖĺí?đŔ–@É~Ű@I󂕊§˛?đŔôčĐΙ@Jőš“?đŔÚ"ƒ@J@ß98?đŔ?äŚÁi@J›1Ƈ@?đŔF şź˘Ř@J7OC÷ąE?đŔ­¨H_Â@J[çMYT?đŔ%Ą~U"@J-Ÿ'ž?đŔ{)ľË@J§ŮÎ#0o?đŔ“ĄŹýŹ?@JČT"ľÉ‘?đŔ/U’ŒA"@JěHÜ'5X?đŔĽń.ýsĹ@KůdŒ<?đŔ ‘9ÚOE@Kg6Ż<Î?đŔM~e@K8R ÍäŇ?đŔôŸ-~@K[Ľú$ú?đŔŸ‹tí@KxŘHX‡œ?đŔŚq<×>Ď@K–Ç+)B?đŔÁŔšů8@K“\ÜéĐ?đŔŸŚĺ Ć@K§uĂ`Š'?đŔTš‘s @K¨bó…<ŔR?>á÷ÖŔR-ɐ5 ?đŔQň‘šíłŔR*ˇęä-(?đŔQ´(čPÜŚŔR*żo…?đŔQx…ŽđÕŔR']fKĺĐ?đŔQI’3›…RŔRqľ8u?đŔQ!*OQŞŔR¸[ü?đŔQ5BϤŔQüéŻâ?đŔQź3O1<ŔQę}ö{˜ĺ?đŔQ Ű ć ŔQŘŞíu?đŔQ§štK-ŔQŚsžß?đŔQ=%¨3ŔQłKŃb´ă?đŔQ ˇť`ÄŔQ ß[gë?đŔQ9QW=’ŔQ×Cj?đŔQJ=hśŇŇŔQ~¨,úÝ ?đŔQUüc•ÚŔQlĽ´ f~?đŔQfwÎU:ŔQZŇáÓÖv?đŔQ:]AŔŔQKí’H40?đŔQ‹ä“S2ÎŔQ8:7ůD?đŔQś^×wůŔQ4Îó™şÍ?đŔQĺ"¤ŽoŃŔQŔRĹGC˝?đŔR4j5DcŔRĽ¤‡ôz?đŔR4@ŔË@ŔR%v˜+tŠ?đŔR?>á÷ÖŔR-ɐ5 ŔQ"XĐŔ9ŔKj$™F•§?đŔQۜ3PŔŔKl…ŮÝR?đŔPătç'ŔKq"'óî?đŔPÂü`ůźEŔKt˙TśG@?đŔPŁV‘ÚYŔKüXNP?đŔPƒ렆GŔKyPYĄ)đ?đŔPdxz`~ŔKvc-ą8?đŔPNĺĎp­UŔKb„?{­Ÿ?đŔP[h|ŠCŔKRć… ŽÜ?đŔPzR‹AőŔKOĘ.2Ĺ?đŔP–ÎÇČŻŔK>]“ “\?đŔPŽ‚?ł›uŔK%´Ü ™?đŔPČ0ď]đŔK|/Ŕł?đŔPŕ$laqŔJ÷›­&§Ń?đŔPňľ5.uůŔJŰ÷űd˙?đŔQ…ÝéŔJź´œž!?đŔQ€ľ÷LřŔJ”°đl7?đŔQ/)ŔJuˇŤżřZ?đŔQ&+y’ă:ŔJV v1š‹?đŔQ<“šŽ8RŔJP#ĺŒ>‘?đŔQWŔvţňŔJEvď0<ď?đŔQi†h 3ŔŔJRi"ÁŇ?đŔQŠa()üŔJgœFŃé”?đŔQ–Dˇŕw‹ŔJƒâń $?đŔQ›ą47˛üŔJ¨Ĺ Ç.v?đŔQ„ŸÚh)[ŔJľi!y¤đ?đŔQ_^?Ő§NŔJłtˆŽŞ?đŔQo(ĺCĽŔJĐ ;‚§?đŔQ‡ä6dĹĎŔJĺĽÁŽ?đŔQ1ę™ZŔK ŕÎV|Â?đŔQf÷#ŞçšŔKsüÁ_P?đŔQJ+C§ąŔK0ÂĆ}?đŔQNłŚ5S ŔKFĚ.Ć<ę?đŔQUL-`PŔK?¸UéVę?đŔQo— StŔK4pěČţ?đŔQˆŠ{“*ÄŔK+yŤâF“?đŔQ°żI—ŕŔK.öîÇž?đŔQ›U"= ŹŔK7Fgßş`?đŔQ°˜hŔK9¤<4ä˛?đŔQÖß˝ˇż´ŔK8X̙]?đŔQóiÚC­AŔKA,‹şd?đŔQęÇEd-ŔKP`ű•ř˝?đŔQŃWćm‰ŔKNםq,Ü?đŔQąů™ˇ8ŔK\`Ü?đŔQ“rÄdĽŔKe^A†o?đŔQuÓ$]ŔKb š‹"?đŔQWŠŤ”ÝKŔKqĎ ýbĐ?đŔQ7ř•Š}ŔKoź‹đ?đŔQ"XĐŔ9ŔKj$™F•§Ŕ\ŻPŠóčŽ@NuËÖ@@Ŕ\Š§Íw:@N}€­G>v@Ŕ\lĽĐOďn@NŽéŘW“—@Ŕ\`-ÇÁˆ@NŻťŐ¤ş@Ŕ\>âsŸ@N¸@(jL.@Ŕ\dŃl—c@NÄ^UšĂ@Ŕ\ěďž)x@NŕиqŠű@Ŕ[čƒEb?@OéáĆ­Í@Ŕ[ÖÚé¨Ěn@OH'í—@Ŕ[´îŠ]ëô@O/嚃Ś@Ŕ[’R:ű@O5q6‹ŁŞ@Ŕ[Š<áFY@OA¤÷éŮś@Ŕ[žĄÚUƞ@OBŸŰ ç^@Ŕ[‚Ý\2 8@OZxgEž@Ŕ[§L ƒ@OYE<Ř3×@Ŕ[Đ˝GŐ÷™@OJŰ)X#@Ŕ[ߢ\3]@OBšňřĺ×@Ŕ[ŻŞ =€@Ocr5@Ŕ[Œ:ІÓh@OhŃҢ`@Ŕ[c0äř]@O`_Ýr)@Ŕ[LDaÁá@O^Ô¤şŸ_@Ŕ[~Ž˝wFT@OwLš– 9@Ŕ[§˝á˙C@OvUŹâ°@Ŕ[̞s^-F@OeĎe÷ @Ŕ[ă î‘D×@OHÇ:›|@Ŕ[ř.ë6̈́@O)Š=&`H@Ŕ\ÜLOB@OÝHôúQ@Ŕ\<@bi&ú@Oä2˝H´@Ŕ\a~Œ+ýŚ@O C @Ŕ\}ĺý¸“–@OĆçńëÄ@Ŕ\‚–…\Ó@O/ű́t@Ŕ\Ä]Îj˛œ@O@ŇŔRó÷@Ŕ\č*Ťi}@OU@üwö˘@Ŕ\÷uŮ_÷˜@OPžý6GK@Ŕ\×q&ÎÄ@O4łyęłX@Ŕ\Ć)ĘŇâx@OŚ­Ź Z@Ŕ\Ż–#V{@NđÄŐwQ@Ŕ\Α­–5Š@NౚŰ}Ó@Ŕ\éƒJiŒă@NϋE;đ@Ŕ\ůúQd@N­~‘­B˝@Ŕ] l?ŒůH@NŸăl(Ť@Ŕ]1°ăćb@N ĹwäZ_@Ŕ]R?r=@@Nšp.•O|@Ŕ]]^ÍPJ@NšfŰşła@Ŕ]8`|ŻţĎ@N„ćŽ @Ŕ]ĆqTä?@NyŠŇß°@Ŕ\ň‘a5a#@NlQ¨~@Ŕ\Đëö=@Nm^Xœ @Ŕ\ŻPŠóčŽ@NuËÖ@ŔWJ~˝@S(˘P0Ç?đŔWJĘŻŒA@S!{Ú.' ?đŔWPšËTEn@S+ř"7„Ü?đŔW€|Č^yË@S9řɔĘÉ?đŔWʓ×Ĺž@S@ĘDřł?đŔXM8Ôş¤@S>„ ş-?đŔX$~ůÝHő@S/ź‰ŚŐ?đŔWóäJáä@S ŘŞ[l?đŔWŔY0ӐC@Sş–î?đŔWfăŔ˛@SX›¸Bž?đŔW2™ÓéXl@S ;4bI?đŔW1uëĽ@Rúk#˘óŤ?đŔWrU€|@Rčp‹ Ě?đŔW.-Šß@RÖ^“&-?đŔW 3[ň#@RŖ6„œ?đŔVřŒ&Ť8@RąWéŔ?đŔVÁâ|˝‹}@RŽPŠ­ő6?đŔVƒŽŇa@R¤y)Œ°.?đŔV5Ź: Í@RŻŞÝđľő?đŔV -“E%Î@R ĚY"?đ@'e0´iҚ@SĚĄ*‡Ë?đ@'ŰőTt×@SşšďWܐ?đ@(0,śĹ T@S§Ď‡jé?đ@)’ Đám@Sœdčč$?đ@+iŰ5ĎźČ@SCŠM?đ@,ů,cŠ˘Ž@S›ž\e“?đ@-ŇńŞ­@SŤ´j´†?đ@.ĘcqÔRđ@SŹ™ěU?đ@/ⲝ*o@S˘3!`?đ@0” 2˘áŰ@S¤›DuHS?đ@0m^4@S•řîô5E?đ@-ԝýHJt@Sˆö6ô\?đ@+â¨.‰˜@Sń¸Ç?đ@,“Bľ$A@Spů¸X3?đ@/}ř°ô›Ť@Sv.‹ŻŠ?đ@0‡Jy+?ľ@StVVŔ’i?đ@.§ĎÝEŸ@SgNÔöt|?đ@/oQӛj@S`tśč`ú?đ@,ƒI -ŞŔ@S^˙üj÷?đ@-1FnšT@SLCĂn°9?đ@/hťQ fJ@SB*™6úV?đ@0œĐŽŕi@S9S¸Ě?đ@0ÇT3éó–@S+-Žš6+?đ@1I˜̄K@SBˇŚx#?đ@1śŢŢ5@SUX66â?đ@2-Qť:Ć @ScÚęüŮ?đ@2m$ÜĚĎ2@Sw„†pżů?đ@2ßňGúÖ@S‡DxúT?đ@3*‡„DDO@Sšé+Č?đ@4'đźŕ4Â@S§óNßv~?đ@5-…”CÎ!@S˛30`,t?đ@3ę´ĂDš@SÄ_pu?đ@2ďŔ%čž@SФŢ"ëü?đ@2 Š°T@Sá°Ůš(?đ@1š'F@SőWŮކŚ?đ@0dŹš¤ĄŤ@Sü–ÎęBĚ?đ@/w)đ]ňs@SěŽršŔr?đ@/ÝxG´@SÚq“ÝĄx?đ@0:QÄ:…>@SČUÂŁ’Ď?đ@0ŽQXϝ@SćyŤŕ?đ@.÷ćΙ@SŘW_Đ_?đ@./‹xÔą@Sę>1m. ?đ@,Ž÷:TĎę@SëM]X…Ŕ?đ@+BƒH9@Sá†{šÖ?đ@*&I?¨Ľ"@Sô1Â㄂?đ@'Ą Î˘@SďcĂĹĂ'?đ@%ëe´o…é@SĺPÍx-?đ@%ÄĘÍőÂk@S٢œŽ>"@=. rŤśŔŇsŘx@@=9f‹Ŕ:PłŽŸ@@=&;ĺëý]ŔE.ŕ.đ@@=ţ×;Ą‰ŔwKN.vv@@=!ˆÖfąţŔŸť˜ƒQ@@=Bc•¨śŔŽŞ#O!V@@=Y"Š!5Ŕşş˜çy@@=81‚/lŔÇ=öÇ”@@=KŚŃ…ŔÄߐmžŢ@@=m…ęĎkDŔŢZ‘‰š\@@=ˆY‘Z`Ŕčć—}@@=ˇ.Ľ’ŔқžLđ@@=ńšŮo<ĎŔv*''aä@@>&ČüöŮŔ=(f&ĄŠ@@>6]2aŔ]ěĽwö@@>QË0d›Ŕq}‰˙<]@@>…(C°ŚňŔ (O¨iü@@>‹Ç(Rł1ÔŔ!%AŠŒ @@?T¸éMýŔ!~Q•ó@@?*ŠK}JPŔ!$aűţU@@? &Łn5Ŕ Ľąç ů@@>ęÉ}2”ŒŔ )BGŹ%@@>Ƨƨ!ŔB ‚€@@> Ÿ)ȍąŔ9’va>š@@>’yÁ ‘ŔÜň\Ć8@@>‡¸Y.BŔŻŐJš@@>^żłšÎęŔę0Žą@@>*}Ö!IŔ ¨1Iš@@=ć>TŁfŔžćŽ&*@@=ť†-A¨+Ŕ˝Š|Ť=@@=ß‘ˆZÍŔÍ7nŸˇ@@=ĺFŻŁŔɕĺG” @@=ĆO‚=CŔ¸{Ą9Śk@@=ĚÂsŔ‘ű§c@@=ŁŒßË+OŔ’Ź`1§Ő@@=Ąë•ŢýŔr>˘lQú@@=™ˇ˙î%ËŔYš 8Oę@@=xKIúđ•ŔK‘6É@@=[Sˆe˝ŔqH8n-Ň@@=FĽmţ)ąŔ €Ý4WŤ@@=$Ćř$řyŔ Î[=3ď@@=Œă %ŕŔ'bPžN@@=YÔĺ Ŕł źâž@@=. rŤśŔŇsŘx@[\PTrC@KŘŰü1ę@@[NéAti=@KÂ.Nš5@@[K7K}“~@Kœâ´§“Ź@@[>•yźýk@K{4›6í@@[2ŮgOĂJ@KXÁÉ`*@@[$JŁ§M@K7ˇ3ßZ @@[Z>ĘŚx@KŃ]Î8@@[ ţŢ9A@Jô "Î.@@Zňĺěˇé‘@JÚw+˜c˙@@ZáU@ Ř)@Jź[3b|@@ZĘR˜ÉÝ@JŁgĆ-@@Zś’dÁ†Ą@J…dĄđz@@ZŠwEÜ5e@Je¨Wţ$ů@@Z“­b{;@JMHąÍôá@@ZzđřDž@J7ÂL`f@@ZjDîŠ@JăFjž@@ZUśl­@IţŻ5ÓT@@Z:6łůČ2@IďFkOF0@@ZŽę@Î@IĺŔŠÇ@@YúI*X@IÜ73}ă@@ZŮă€IŻ@IÇźT+YJ@@Z 8-Zăw@I˝‰MÎ@@Z<€¸Ăv@IÂčƒúö@@ZXĘňç‰S@I·ƒžp-@@ZuîŇ9‹@IÜrh+ď‚@@ZˆŘöEú„@I÷đSüš@@Z‘Ş ł`˛@Jůš\Á@@Z§A™^áÎ@J- /Ę/@@Z˝ž´a’§@J;w¤ŹÇ@@Z֝†ň/@JPŚ<|ť1@@Zó-ĺĆë@J]ň4‹P/@@[ šô0Ź9@Juy⢂@@[ ľË=Ĺ@J“5K„yš@@[4ŽöůH@J¨\ąŻ´<@@[2X_Ľgí@JÄhó c@@[9¤BŻšŃ@JŢLđ†ţň@@[L1+ŞÜŔ@JÝR÷Ŕu@@[ZĹÄŤč@J˙yĘČó@@[`˝ü:P”@K!ńŹŕŸ˙@@[aÄĘz<@KG\pDI7@@[jäą@Kj/F’Ť—@@[pd3Ź*Ň@KŽ_1ň -@@[uoSƒ€ń@KłW"ć@@[q&?9>÷@KÜkn87@@[\PTrC@KŘŰü1ę@L8^8ş> @RŹ!çK?đ@KćV21Ç@R˘"6Ç)ă?đ@Kś ›_Ěm@R’:xo&?đ@KŞkx.šf@RˆĽŚî•?đ@K?Ďg˘›@R}(ÚU˛Ş?đ@KżÍäűŹ@RmÔîg˛?đ@Klö%N@RiÉę"ó‚?đ@K7˙i ľŠ@RZiňZú6?đ@KćQHçÓ@RW8úŰŰ?đ@LWљ;Ą@RSašvď?đ@Lƒż„ ˙@RaÝbý?8?đ@L˜ŽŽéqw@Ro­đČĄş?đ@LëÔć—h @Rw8nËßÁ?đ@Lřâ=Ýq@R†ŠÄŁtn?đ@MO˛ťœÓ@R’n T€?đ@Mgf›Iě@R˘A€š˘ë?đ@MĐś|wË@RŹĂÇi?đ@N*Ćĺąň@RťŒŸĘh?đ@NaHƒš@RĆö÷ţśš?đ@NËDů˘ž@RÔOnJą.?đ@OKΤď`@Rŕ0Šœž•?đ@OŇ'˙2÷@Réń3Q“V?đ@P,Î ń˘@RńqŘĂŕV?đ@PnĹůY@RúƒĆË"?đ@P°˛aéč@Sjá…ń?đ@Pń¤€Čbš@SY¨Téź?đ@Q“ćq+@Sę†ę &?đ@Q8’˛ý%@S+áćä'Ď?đ@QŠ_łż@S<" €W?đ@PÉVĚŽ@S=ůS?đ@P‡ÓUTęß@S1Š]ýŠ?đ@Pbj̸Ď@S"tp折?đ@Pă^Sƛ@S:Eœˇţ?đ@O–ýHBç;@Së}ÁĚë?đ@OÚ݈qţ@Së Ť…M?đ@N‰ř(čo@S ŞmÚ1V?đ@N1AG ՞@SŻm_U ?đ@M”ř'×@Rř+ŚĄŻă?đ@MƒPOCĘ@RęÂ_ÁČł?đ@LÇjű6‚@RÚď^ńÉ?đ@Lh*šüM@RЧńg‰h?đ@L*™´@RĂC9‡ ?đ@L(÷žËő’@Rą"Ś?đ@L{Ť€>;W@RŹnĐÍŒ?đ@L8^8ş> @RŹ!çKŔ^Ďżľ\7Â@PFX4 c‚@Ŕ^§Ňӌ§Ť@PAýCľ˝@Ŕ^yŠšß˝@P@ö+Ć´@Ŕ^dy†ôˆ@PQjNÖŕ@Ŕ^K ćL@P_o÷=‘u@Ŕ^ rb‚}@Pb4=Ü$@Ŕ^(˘ šs@PO­N&Š@Ŕ^NЋŹŐ÷@P<‹au|ő@Ŕ^6O“Űż@P="žÓƒŒ@Ŕ^ökQ‹I@PH×\6ŕž@Ŕ]íš÷&ʘ@PWąz9ať@Ŕ]őŇJ5ÇŻ@Pj+źŽ@Ŕ]ӊ— @Pršśʜ@Ŕ]ź‡Â˜ú@Po3nqŽ‰@Ŕ]€ÓCëL8@P€Ő­mä@Ŕ]o5Ş@PŽ‚čĂlx@Ŕ]l葑UŻ@PĄą_.­@Ŕ]S6-TY@PÜžˇq‡@Ŕ]°“yźQ<@P• ôQ8@Ŕ]ĺTćšc@P•˛gi@Ŕ^ěŠpŠć@P›9ن @Ŕ^UäáĽ@P¨sąy1/@Ŕ]Ô‰lo@P´™–4!ę@Ŕ]č'ъ…Ą@Pż ŕTĹ@Ŕ^…$ڈ@P˝ŰšC§^@Ŕ^@ZŁ]ß@PˇXž?§@Ŕ^f\,&i@P­ˇŘZ–î@Ŕ^–B¤c@PĽ]™GZš@Ŕ^Á9Ćjôł@P b;žY™@Ŕ^éř$ˆo@P™ŚŇË@Ŕ_,ţe.š9@P‰ŘóÄŽŠ@Ŕ_ WßşAx@Pˆ˙8–*@Ŕ^ÖĽúVG@P‡ź‘‰ř@Ŕ^¸şÚBŽŇ@PŤTݔ/@Ŕ^ˆŽz4R$@PjXČŞv@Ŕ^^ď)‘›@P‡ÎŤm/ž@Ŕ^cĽ6AÉ@P|¤°˝{@Ŕ^š—cę`@PDhţ"@Ŕ^•´O2M@@Pw{Lcž@Ŕ^ăďQô@PgážB@Ŕ^łęřö˛V@P[]IˆÖa@Ŕ^Ě%;Î:@PMâA…@@Ŕ^Ďżľ\7Â@PFX4 c‚@?­yŕó)ŔmŞkÜ=S@@?˛I…ĄŃ]Ŕĺą"îţ@@?ŮčŰúćŔZ)óeG@@@i8´'Ŕ6sŁĚ—@@@" veă™Ŕ´ěÖŃĘ@@@Dü‹N}ćŔĆ÷:ß6k@@@aIĘÝÎŔ#żÓě}aÄm@@AUčĎ@üżÁ[RÖ˛őň@@A-Ą-Á tżŃz§Qkp@@A_‡ˇżÄ ž°ó@@@˙.ËţŇ>?Ą™íu&PŢ@@@é|‰çH?̚?áýŒ@@@ĘLETÝ?ÎÍlC@@@ŻOĐj˙č?×˙_ZĺĘ@@@d^rLK?Ѐ^”sT5@@@s+an?ŔŢ$`6Ďf@@@Q ĹIFŹ?ΔÍBŁŔ@@@-…Î'ůJ? ŸĽžá@@@ B,'ÔżŻJŚvć\@@?ůŕŰ2żĎÇÎ\1NË@@?ס}ţpżŕŸŚą";'@@?žP١Ćżé|eľŘç@@?ÓM˜uďżđހĽŐĹ@@?Ń9ľţć żőů˝ťü@@?źňşýŞ9żú ĚďľtP@@?¨#ÎyŔżţ˜bĄ.@@?­yŕó)ŔmŞkÜ=S@?rˇľáFë@Hé)ӞS@@?™7°@HÖőAZiŠ@@?ňÇÔ#­ă@HŔŽœŻ—ů@@@'mňs@HŤ.Ôö“y@@@WÁxj@H”ĚŇŇj^@@@Š[¸F“@H„Ć )'@@@żtń>@H€śHM|@@@ëçíڍŃ@Hk—˝Ě+Ö@@Ao0˝â@HX­ hî@@AJˇ[ČÄy@HDŹv`@@AÂP@H6Önaa@@AŤŐ:€@Hâbá˝@@Au˙ŃÉĚ@GîÎýťűT@@A?éfß@GĚrü#A@@AEŻ“îmű@GɡŤąí@@A‚ ŢŐ@GĆż!e@@@ř Ԁ˝č@GŞÚ˝9:@@@ŘíöĹwß@GˆŔšŁ[B@@@źřŘAΜ@GlaŢéÄ@@@rEŻKEx@G[ŻźnD@@@‰÷ŃÎ(Ü@G_?đ@bő"8Ť”ŔaŞţ"Ú?đ@bíÓRĚÄÄŔ˝Ý3bç?đ@bĺyŔEODŽŚ?đ@bŕüśƒŐŔ8څL?đ@bÚĎ\çĚŔé”ú7X?đ@bŇréOł.Ŕ˙J#ŢŹ;?đ@bɲܡČŔÍaVb8?đ@bÂć #ՐŔŞÚîݑE?đ@bĂÔd(&ŔŠq_´Ĺ?đ@bŔÇ-~ăŔ‚@aÇȟ?đ@b˝ň˙ĽŇŔ¨Řj6łŔ?đ@bśj&‡ëoŔŮÖxç?đ@b­nǜ>sŔOŕ^§g?đ@b¤…âŸÉIŔ.Q‚°ć?đ@b›bŹćŘŔ=ĐşŇ?đ@b’(ązýŔ,ŁłS=?đ@b‹YöPúŔMçůűt?đ@b|Smń°Ŕ5¸y‡Ç?đ@b˜–:XĘŔ”QlÝ°?đ@b zŒEŃJŔ?FfŰ­%?đ@b§#úűdŔdžMčĄ|?đ@bŻ˙>3dSŔĽžĆíϊ?đ@bˇodńŚŠŔ/1ŕŕĂě@@A(˜g’ŽŔ$źV$d€_@@AZĐü3Ŕ%I‚Ś00@@Ał´űAkŔ%ŕŢ‘=É@@AĹ]ƒ˜TŔ&sZQ^îh@@A%Ÿ™VŽŔ'˙pŤŠ@@A˘ śuŔ'ŒľxyV@@A ÖŘÓ<¨Ŕ( Ťaâ@@A—źwOëŔ(žČ÷`g@@A*ÝăÝ~Ŕ)âȂçP@@A$Ó٧ťĽŔ)­1 C÷â@@A+tZH2Ŕ*6­*šĹ@@A,.FŽ;Ŕ*ĘKL‡­D@@ADă÷„ą'Ŕ+?=ą´ä@@AI3OňŮ>Ŕ+ĂÝî6çÖ@@ANq{‡ďoŔ,P#¤/˜B@@Ag5&<łmŔ,X APÜk@@Ayç•üwŔ,3žHlu@@A˜Zi¸ŮťŔ,pPŻĚë@@A…ÔşAŔ+ƒwlhD@@An |Ö,ÉŔ+38P)-@@Ahű„zčŔ*03z:Y@@Ad_t€Ŕ*rSŁŇ@@AeşIŃ$Ŕ)v+€N¸@@A[Ůk8šŔ(ćч…îČ@@A_¨eMŔ(T‘şE @@At1ôÖˇńŔ'ۧ‚%íŽ@@A{ĺ̌Ŕ'KĂĚ4\m@@An~ôĹŽšŔ&Ç Mä@@AW”¨/ółŔ&`pA(îń@@AP͌!ËŔ%ŐěŸ,y[@@APqsËŔ%C‹â_.@@AI¤ßŒŔ$˛Nž—5.@@AB˙űXL’Ŕ$Ro Ť @@A/§>‰çŔ# Ufë@@AO‡(Ŕ#5â珧@@@üésîŠ_Ŕ#"RCĂú‘@@@ö2ą \GŔ#°&­ ƒő@NÎżÁZjÎ@Fi!ň– @@N蔤Ŕ"@F‡-E^bđ@@NțŮ9$@Fœ‹ľœ @@NĽĎđtćŮ@FÁšŤś@@N†¸ôĘ÷Ŕ@FŰĎÎ%ę@@N…J-¸ý@G˝gˆ Y@@N¤ŠŠo˝v@G ˘łúK@@Nź”ZIëď@G>—Ž6Ăc@@NÁşĚ*c@G`Żč;žś@@N€°QdÓĘ@GLkđF@@NK>ÉőJ@GZ@ĽœĎ¨@@N&ämœƒ@GVŹxRQ@@Mő$%˛ę@G?ĺy†@@MôÔ\űűP@GGŤ;™U@@MÂÖňĐň2@Gľç\d@@Mž2ÜĄcÜ@FőydEq@@M¤L26ä@Fř‡u?@@MmŹ&6ťK@FůN ý@@MPҸŮË@FÜ3!%›@@MA,ř–{ć@FšG!Ó`‘@@M,Žž1Ł@F–˝Ďţ˙@@M >aĽ@Fsx¸ ÜĆ@@MgMú>Ů@FNSMâˇb@@MÄâLG@F)OŽ§îÁ@@M/ţÇů¤á@F::Ť´’@@M6R₃ś@EÜÝ4‘%Ë@@Mnt[L@EçWá^ =@@M‹5?Şéž@E䳁<@@Mš…J˜’@Eŕ8ěĹ˝Š@@MÜ%xm˜.@Eɕ }Ţ-@@Mř„8pŢÉ@Eťfn@@N(1ůD‚h@EÉUٚą9@@NWĔH”—@EÍH8Râ@@NzÚçę@EŢÓÂ>Ÿ/@@Nhbž6ËF@EýÇĚkľö@@Nˆ"}}m@F Ůë÷Š{@@N”ŞŤYD@FDWŒ•bÜ@@NŞ!ŸnűŘ@FUŮk•§u@@NÎżÁZjÎ@Fi!ň– Ŕ]íŘOĽŽQ@RŠČ^|đ ?đŔ^:ď…[Ť@R”Kqłi?đŔ^Oş7ŒÂ@RŸč26çM?đŔ^‘”W@Ržú;Jlk?đŔ^Ö1AËt,@R›ž×S@ƒ?đŔ_˜ĎŃ@R”~§rĽŞ?đŔ_ÉOä”@RxLĆCí?đŔ^üägć’@Rpń.9b?đŔ_U¨' @R]ľŒśU?đŔ_*䁃F¨@RL:}Ş{?đŔ_1ɡEŒc@R;6‚Ń™?đŔ_BXŽ¤5@R( 5§x?đŔ_\šÉx3Ô@Rĺu'~“?đŔ_pÜw" Y@R.l×á?đŔ_Ks2œ¤ @QüsdŤÇR?đŔ_yDŔěQ@Qń$Ąä ?đŔ^ôRGvOý@QäčWÇa?đŔ^ŢóAÉ #@Qӈ+'ô?đŔ^šŠŕę@QÇó¤ b?đŔ^†Sž2@QÓBŻI<7?đŔ^[¨Fkć@QÚźöjQ?đŔ^$ݗ^>K@QâWľ‡Ńű?đŔ^%“˙ŠH@Qôfö%˙ë?đŔ^ Œo‚ĺ@R gŘO*?đŔ]ĺußXâŠ@Rż'5Ő?đŔ]Ë:ŮŞ8@R#ĚŮJrP?đŔ]Ł0XéŮ@R1…[ŽŮŽ?đŔ]qî†M­ť@R=ŤtG•?đŔ]?Ir÷Zœ@RHÝît?đŔ] C}Ë˝ó@RR•‡ő?đŔ\ŢoĂjŻ@R_ÄĹË?đŔ\ýŸwĺ@RpNuŠ?đŔ]&žžĹ°@R~í kĘŕ?đŔ]U‹Ď™nŔ@RŒŒŁżz?đŔ]—WĹDž@R§áâş@?đŔ]̈́>Ÿ1Ď@R†é4Ÿ¸´?đŔ]íŘOĽŽQ@RŠČ^|đ ŔTĘÄ0äB@@P<ÍŇą„o?đŔTáyő­Ý@PGË:´ěě?đŔU)ށ”˙@PP˜”qă?đŔU//w¨@PVU[ Ô?đŔUI–ńě‘V@Pcˆňtw?đŔUV}°EĹ@PtK‹yžN?đŔUsPî]1@PušŁ|X?đŔU„AK^2@Pdljĺ-Ü?đŔU‰pŮlŒ@PR™ ŻKa?đŔU‹ÉŮ/j@P?‹iŽů¤?đŔU’Çm”K˜@P.“‹m?đŔU˜ău°@P@\–ą7?đŔU“ âI]@Pő|Gš?đŔUłfXڗ@@OřJu98?đŔUÇçM<.@OÔ{™~t?đŔUŚwl:Rˆ@OĐşŇCĐX?đŔUylŞ­łë@OŮŞŹúŤ8?đŔUgľ I‡„@OÄZj÷ŃÔ?đŔUf‚ 3ĺÇ@Ož\ýąO¤?đŔUH˘°âŃ@O“Ŕ̋Ő?đŔU' —ľŸ-@OŞ!+d—?đŔU6íĆ9Ą@OĘ7vŸ?đŔTďÚËé@OâŹÜXęX?đŔTâ•)ˆ ‡@P )?đŔTÂCŸShB@PĺA?đŔTžá-DŁ@Oîo#@-[?đŔTŒ}MÍÁ@OŐËż5Ôş?đŔTd̕<Ö(@OÉĐ,Őçř?đŔT= í@OÁ‰Í?đŔTy÷ڑÓ@Oۃ[TR?đŔT!€łu|@Oó=Ž/‰?đŔT>WÇ°š@P˘EŠă?đŔThé˘OI@Pa„š?đŔTooöÂĚ@P 2†DK@?đŔTrÉŐé*ô@PşŁ.Áŕ?đŔT‹ôsˆu@P,ŽrđW?đŔTŻ}wD.g@VűŜ"?đ@TO‡ż+@ľBů­IĆ?đ@T` Ç˙@N§FŽŘ ?đ@TmÂźV̸@`Žçt?đ@Tu ™˙ Ý@%F.¤‘Y?đ@TxVühJđ@FçŰÝő?đ@Tu\ uą@‘ř–Ě ?đ@Tm¸&"X–@€żÁ­?đ@TgşÉ­@OńMďí?đ@T\:nžşP@ @Ř0ft?đ@TV f//@ Ő5"ŇĽľ?đ@TL´őţ|Ö@!+,B\e?đ@TBœ–w”*@!Ä~űgń9?đ@T9iÔĹĄ@"!§ÉÖ$Â?đ@T1ůœ4Ś@"‡ŕ긺?đ@T"͈:Ř5@# z˙źű?đ@Tá\W@#l˜ÄŇéf?đ@T+߂‘@#yy…o?đ@Ty5ťç @#PŮ)ŇŹ?đ@TwŘg@#\śő‘€?đ@Ti„‰˜@"˙†É…đŞ?đ@Tţśyśŕ@"ęĎů/ =?đ@T;Î#ű@"V'ˇŠC ?đ@Sý7DŞé@!ĐmP“Čâ?đ@Sú”ťCKČ@!8 ďŚm?đ@Sőc‘­™'@ ŠČ%¤X?đ@Sđ&–@ @úhÖ¸j?đ@SńŽů6D@°+zb?đ@SňĘÎ×7@pďsÁŕ?đ@S󄎽ąr@ŢŢL{iü@`.ŕţ–?Ń[NžŤĂ?đ@`şlŚ¤)?ÜŘŃę?đ@`¸Ů>˝?㎫Đ=­H?đ@` ;Ż8Dş?ę &™ c?đ@`Ő^áö>?ď÷›?đ@`ąJjÝś?ó@­.ˇ×Á?đ@`á•.څ?řy8z˙ą?đ@` “ ?ř4OiÂ‰?đ@`‰8}Ş?ôçT÷2úE?đ@`ükQŻő?ń˘ąGđl?đ@_÷ĐŐĺœ?ëÎôŚ E%?đ@_ë۞ˇÖ ?ď Yń3ię?đ@_ů­šbd?ó)>ľ÷é¤?đ@`yŠ_Ó?÷6,¸„ß?đ@_ţĘł˙D?ű‘…ýĽŰ?đ@_üž^jU;@…"đíL˙?đ@_đß[Ô{?˙řF(?đ@_ĺô€´˙r?übܞŒ‰?đ@_áf_A~?÷ĆšÖ˛¤?đ@_Ű/kŚč?ňŤüľąź?đ@_âáý?í”ĎŮoŤm?đ@_ăXŒ ‡œ?ĺ“%¤ßř?đ@_çMĽÓ+)?ŮŤ‚Q ?đ@_ěp3ő?ÄJpž Ü*?đ@_ë{ůIłnżŔŸĽř8Í?đ@_óń^š ożÖúŚ˝˙î?đ@_ţĄ¤Dżă!%ÔZůą?đ@`á0ŻvÇżęĽÁ,cł?đ@`0ÇX÷†żćnÓ]ţb?đ@`<ŻźŰrżÝ6Ż ý“Ą?đ@_ýš"ƓżČrRľ÷Ńä?đ@_ů°`éď?ś}˜’Ŕň/?đ@_ü5UZ$?ŮMIô ž?đ@` 8M?ÚĽŁëfKľ?đ@`ýĺ]`Í?֜á•éĂş?đ@`Ňäč~?Đžăwl…?đ@`.ŕţ–?Ń[NžŤĂ@b~’˙ÓňŠŔDc=”{œ|?đ@bwx—ăĐ#ŔDn¨Ľ+m=?đ@blKh_§ŹŔD|FGÎ??đ@b^f¤˘ô ŔD‡€Ö9"s?đ@bUÇë:6ŔDw†Rn?đ@bI›JYNŔD”CY"×?đ@b=فqtpŔD‡áFç/¨?đ@b33[x6¨ŔDtx Ÿšx?đ@b'Ř16H„ŔDe8rî˛3?đ@bu:OěŔD[đ×)ß?đ@bišęĽ‰ŔDp0çé?đ@b ŕZCŠŔD’7Fć?đ@b‡ťyăŔDľjÖćŘL?đ@bó÷îYŔDס2ä.‘?đ@b$˝¤+œŔDőăśSÝ?đ@b+ŤíŔE%ç×Ěť?đ@b'ţ˘…úŔE>mWú÷?đ@b,ëTˇŔE^LĎb=¸?đ@b2rNˆž’ŔE~ň( â?đ@b;I˛5ěŔEŇĆňë?đ@bBԍËqüŔE˛oAŢ;?đ@bLœ-U˜ŔEÂ*˛-Žţ?đ@bW—XăŽ%ŔȨM!ČĆ?đ@b_IŻ“,ŔEšYŽ~?đ@bc^;†"ŔE›ŒQ‹Ć?đ@biŕOÇÂŰŔEx„šŽś&?đ@bȏFŕŔEwA(Ą?đ@byß#5h ŔEŠ çć ÷?đ@b}÷8“_ŔEvyŽÂî?đ@b}Ł‡‚kŔER•2, É?đ@b€ ă`ŔE0ď‡ŐŽű?đ@b‡ kż˘ŔEćЇăE?đ@b‰ ¨BŹŔDů‘,ˇ–S?đ@b‰eƒy(ÇŔDÔÍ7Ä?đ@b‰x}]Ú-ŔDŹJj,z?đ@b‰Q˘őďŔD‰§´Ąb:?đ@b…\ĐÁlŔDja2 ăÍ?đ@b~’˙ÓňŠŔDc=”{œ|@RäŰŞM@G)Öƴّ@@RrŤuPÉ @Gţ^<ŽĎ@@Rh̒@ í@F÷qŠNHĹ@@R^łr”@FŘR˘…o@@RkŹ>ńr<@FśŘlGÂ@@RśďŚUQ@FdƤ'@@R‡ËŇŕČG@F¨ß#_@@RŒŁÓŽdč@Fˤţ š@@R‘•ü|¤@FĺŹrńw@@R›IDůk@GPł–@@R°S„ Ý@GŚ¨˜c?@@RÁĘ/­•ü@G4rží¤@@R×j{ă!@GAjN{@@Rĺ1SzĆ@GHmşţx5@@Só6“ @GC!vU@@SžłŔŒ@GEäQŮ!ś@@S6Čz@G>~iEœ@@SPƒčvd@GZÁŻ˜@J |ËŞ˛á@ŔXCƒ7Ŕ>V@J.}Ľ>¸~@ŔXMADˆ&@JSú(6ÝZ@ŔXXhüŮ÷@Jw,yľ@ŔX_D-ÎCĽ@J™ŘěoÇ@ŔXkÉĆřÂ*@JťĆs@ŔXwźÁÓ@JŢăJŽ@ŔX~U —b@KJ 2L@ŔX}3Äop@K"c€ĹÁ@ŔX†I­ĹpE@K&œ2×0i@ŔX˝únՉ@J˙Ľ_ź Ż@ŔXŠMçýé@J姊Y–@ŔXšća&§@Jč .xĐű@ŔXÄö•rŕ—@JŔĄƒ ,@ŔXĚFNT°@Jœœ÷EŸŒ@ŔXśßyc˙D@J‡Âżăąě@ŔXŸéŔvŤ@J†ŽŰ”'Ř@ŔXŠzCŹ˘@J} bqýœ@`wqɧî8@@Hdř5Šë?đ@`~ƒgƒ w@@h˘ŰžA?đ@`~G' R@@ƒÉ×säb?đ@`x†é/@@œŰÇÔbâ?đ@`s…ę@@ŻúW!í_?đ@`s,y?€@@Ν•úý?đ@`fűH4Ď@@Ě Ś´*?đ@`_÷ôv]y@@ć4-ÔmŽ?đ@`[3q"q@@ő$nĄ€?đ@`P×ÉĄíď@@ęYÖé*[?đ@`Iň9%¸@@Đhľę@g?đ@`?›öť÷ä@@Ŕ.Ď/ß?đ@`7˘ýU'ľ@@ŹZö1ňZ?đ@`6IwpŽÚ@@éŰi ?đ@`9ÖtÂ[P@@v¤€mz?đ@`D8h@?jÓĹâô+?đ@`KőÍń@?z@?•žf?đ@`VÇHŃGĺ@?™áű"˙?đ@`XţdłČ@?L˘¨cC?đ@`Zq×ô$š@?š÷úĹ?đ@`dľ¸ZŃ@?`ˆ(žO?đ@`líŁ b…@?ŠI"ĺĄ?đ@`në2B‹†@?ŇĚóë œ?đ@`pëäšhŽ@@ §wázB?đ@`sĺ÷Ź.&@@-2“T„m?đ@`wqɧî8@@Hdř5ŠëŔTmpřC3{@E8ÉĂ<ßK@ŔTy8b|é@E%ÝŽoŒ@ŔT´‚Ša8@E$€lB@ŔT¤K‰ářR@E]Řń6ë@ŔTŔ:áwád@EńV†š@ŔTżB:đZ@E%yއŽ…@ŔT˘œśVo@E*⌠Ň@ŔTŁ‡f‹ţÇ@EEj•H)+@ŔT˛˙¤Č?–@ELą0hť<@ŔTŔ Wô2n@E+ýÉŽÍs@ŔTĚ9ŹR›E@E yŮň”@ŔT×°˛÷öd@Dćľş(+×@ŔTťôI›I@DĹŠä!˝@ŔTąäö ő„@Dş?é{&†@ŔT0=Ći@DľŞ(5ľ@ŔT„^Ă9ť@DžÎĐżžF@ŔTkţƒ–QŐ@DĂŞCůçˇ@ŔTW§ý> s@DÚ<0Čź@ŔTA˜UqŁ@DëÓM/@ŔT*TËP V@Dř€Ű*Pj@ŔT7łďžŹ@E Bç|eŢ@ŔSýŁÂÂQ@EZsď]@ŔSçŐđ‘@E*…\Âőâ@ŔSÓž$p¸@E@Ď˙I¤é@ŔSÁfŤąd˘@EXđ{盠@ŔSšnO3O-@ExŹç$Šˆ@ŔSÂô3•@EzîZđ@ŔSŰD†Ž@EníĎ䨀@ŔSôŘő>ˇ@Ejŕ¸˙y@ŔT—5Aź6@ES¤ĎoŃ_@ŔT‚ÍĚąđ@EH×ű¸f@ŔT0Ö+ ť@EPŻáŔM@ŔTIi°wqX@EUmÄW#@ŔT`šŹc˛@EIC9˙D‰@ŔTmpřC3{@E8ÉĂ<ßK@YŽGëÇA_@L eÖaœ@@Yzhîí@LşŰ[í†@@YdXnybę@K˙˙ Ě@@YiąYŻ @KęM;íŠ@@YwRŹ~Ą@KÂ5t~@@Y‰řnc~í@KťÎÜ$6@@YŒÝ`ť]@K—Ŕęlç @@Y”AQÖŕj@K›2hô3@@Y•B]yű@KžŃ}żkß@@YĐmŽ@KŘKLží@@Y~Z㝏@KůŹĺ&?@@Y—Lť›+@L (˝•}I@@YłÚ*6@L “öSA@@YÁ٤ň@KěLäçŇ!@@YË6÷^ŕş@KÉ"3ĹZ+@@YŇăÔĚí¤@KĽ™˘—!‡@@Y͔r9>ž@K‚`îoק@@YÇJnŢĎ@K`Ť€/D{@@YËfÝŁŞ@K:F˙Üéđ@@YŔâU-Ô@K„aőúB@@YÄéáä§@JěĘűĂ30@@YĘŰ=*X(@JÜš‘ŐϜ@@Y×đÇh_@JŠLôz@@Yć#ôţí&@JÄô›jz@@YŮ°¨BO@JܟžU|M@@YĘéCÜ @JţnÁAK@@YёŠľŐ@KvXÉ@@Y҄ż'@K<ŃąŻM@@YĘ"ň—’G@K_; ™ż@@YĐĄŔGłb@K‚ROLDö@@YÔ÷Ď÷ĘÂ@KŚ>˜…@@YΛ8‘˛@KĘŤSE@@YĆš´1w@KějżşÍ@@YťąŻłŠŔ@Lô™…L@@YžhrÚ@L#čEDˇ@@YŽGëÇA_@L eÖaœŔ_č7wnÂŤ@Ie„‰C×?đŔ`…âMɘ@Ilƒ`]3\?đŔ` >˘ôú@IUĚ^r ?đŔ_ţ¤Ó<­¸@I=É ËpS?đŔ_ě;&¨ý@I<ó{rűˇ?đŔ_čÄÇľ8ž@I€GÓMö?đŔ_Í}ŸĘIš@I*eŇ&Í?đŔ_ˇ÷ž6R@Hô ¸Ž?đŔ_Ą>Ýđ—(@Hߕ qJO?đŔ_—2Ţe›ń@HÍŰň“íí?đŔ_—qvTŠ@H´€JˇŐ4?đŔ_{óâŠęm@HŞđ ƒV•?đŔ_nрI˙*@H‘—ŹÝć?đŔ_XTź6’6@H|ßQĎÓ?đŔ_>yoĘŁ@H‚sšú›?đŔ_7(‰*@H‰ét/4+?đŔ_BˇCÓ@H`M‘Ź?đŔ_$řúƒń@HHKH@ül?đŔ_ €0ŰŽ@H:Œ´÷É?đŔ^ňWëç—@H,îw ÔJ?đŔ^ÚX ějű@H4É]ů ?đŔ^ßč@—c@HS1gťĐ?đŔ^íҀ,á[@Hw<™š~–?đŔ^úŻ˙3ó@H•(RÄü?đŔ_ĺ6ܲű@H§çču×?đŔ_,uýu8B@H¸¸$)?đŔ_:Âđ3…@H֟r2<—?đŔ_IÚ˝ÂJ@HöŽ+ƒW?đŔ_W6áˆxV@IJŠqc?đŔ_iĎúéŃ@I-Ě\űD?đŔ_…ľ†Gs@I7š>ô g?đŔ_˘dĄŤÜ@I?I‹??đŔ_˝ŻVŤž@II @Í?đŔ_Öů„š„ű@IXMqô/?đŔ_č7wnÂŤ@Ie„‰C×@_N.ĘúZćŔ"ÉüH0?đ@_^[Ĺd]ŐŔ"~ą­Ď?đ@_p ÉPŔ"U$lYĹü?đ@_Ż—‹FŚŔ"$™cAëŞ?đ@_“Ě:;6Ŕ!ó Bî ?đ@_ŁČÉŔ!ˇą‚Ü˙ž?đ@_´ČŃŤŔ!~Ftťěć?đ@_Ĺ4‹[X8Ŕ!;  JŻ?đ@_ĚÚ'ÉŔ Éiçu”Y?đ@_śĘn&ě‘Ŕ Ŕ„áÎ?đ@_¤€e†ÁżŔ éńˇó?đ@_’I @€ÚŔ ďמ YN?đ@_ę Ŕ!şŞ”?đ@_me`͏Ŕ! ‘Âoƒ?đ@_[;źŘ /Ŕ!&CĎň?đ@_I~t8žäŔ!\ŹĘˆ¨6?đ@_=ü\ `žŔ!ÔlŻ…XŠ?đ@_.'űw6:Ŕ"#‘—ś˙°?đ@_ş(Ŕ"`ş—eP?đ@_ é+„W$Ŕ"‹Ş•…qÓ?đ@^űęLJŔ"Ó˙˛Ů¸™?đ@^íŔ­ŚŻşŔ#;ýŢ|ŽÉ?đ@^çޘöüňŔ#Čŕ˜\Ę?đ@^č5îEp@Ŕ$B!OŇö?đ@^ć>Q‰WÂŔ$ľvÄ_Ź?đ@^ú“ MN'Ŕ$˘‘˘ÔQ?đ@_ WƊŐ)Ŕ$`ÖĺĺŻ-?đ@_ĺ˙#gëŔ$Ťc¨@KWŐš:Ň@@H4C¤@K<Ćbde@@H:IMbá­@KPZ…F3@@HgŠÔ‰­ë@Jű|°uSL@@Hoú5Ţuů@JڎmŘI^@@HŠwřŻ=@Jś1ő§ć@@Hp™*ú—`@J¨T+l–@@HvęL˙z@JŁëÝůwS@@HÉwŸť-ő@Jśf}ˆ*p@@HŸŚŸbž@JŔ~ů{í@@HœOXZĺ.@J޲ŽBw@@HżŐ ßI@K ďÉůäŽ@@H”Á9¨@K˝oْ†@@HfI/ňűs@K Ś•KćÝ@@HD™a–e@K) 8ů@@HvHNAwq@KF6žiWŰ@@HzßVýg@KYÚű|ŒWŔJZ'îćjŔT: E+Œ?đŔIźáóƒŔT7ÜéŽD?đŔHăPżÝlŔT1—×›’Ď?đŔH ITO{WŔT+ÜßUŽ?đŔG5şŤČmËŔT%J5ö7|?đŔFxşi¸Ţ#ŔTbšKei?đŔF&ĹP ôŔT Ô  H?đŔEŇ'Ť”yŔSţœŽíˆ­?đŔEŹí.ř|¤ŔSęŞŮ‘p?đŔFáyR{ŔS×ÝO5˜}?đŔEçK“áľüŔSƒ87*ć?đŔF}RČóŰŔSśZßJE?đŔF Ż??łŽŔS§űPŚţĐ?đŔFšr—Ş1ŔS”Ľ}.G?đŔFxvZí?^ŔS†/’—ÝC?đŔGu)ěasŔS}îÖI?đŔGżö´źúśŔS}fWńŐě?đŔHPF˙E5‹ŔSˆr "&j?đŔHĂşŠ˝IÚŔS–űĆš‘ö?đŔI_–†7ŔS§Ă Ľ—ü?đŔI<Ôe@ńŔSşwyv?đŔIPQż@†‡ŔSĚj6č[?đŔIRç•vŔSß ĂĄR?đŔI–ďőmßŔSđ [­ ?đŔJezkĐŚŔTää2Őč?đŔJ™ŽWŔT Ś+ýž?đŔK+#g{˘‹ŔT˘OáŐ?đŔKi=şšnőŔT,™ŕŇ?đŔJîff‡yyŔT: s,ôŞ?đŔJZ'îćjŔT: E+ŒŔY“8;L@RwÜŻžN?đŔY(Žż‹tR@Ro–jń@ž?đŔY?~kOZ@R`m•h.˝?đŔYÉÁY@RRôQ?đŔY`sł†@RA|qW`?đŔY$˝Ló'@R2 łTĽ"?đŔYWS7'K!@R2˜żť?đŔY„zÝőÚ@RAZhŁ]4?đŔYŤĂ Z@R3ś•č?y?đŔYÎŃîžÁ@R#góŻk?đŔYht#[€^@R#ÉŞś?đŔY6ZmÁŚä@R ën}ÜH?đŔY€BOPš@QţÓD˘‹c?đŔXíôxEżÝ@Qďć34[?đŔXŐđ}ľ§@QŢŤréÚH?đŔXŽx›9@QŐ •?đŔX‘Zż!y@Qě'eőë?đŔX`Q>Ě5@Qé3‘ây?đŔX.NSŕ@Qö‰ Ľ˘-?đŔX& Ţý¨x@R5) ĺ ?đŔX#~Dš[Ż@Rˇ5Vű?đŔX/rP•/@R)Íf2ů?đŔXMYH%H@R5llÁľë?đŔXˆě+1Uš@R>őpMԝ@QŰb!S‚?đ@Jî'käü(@QÉ<$ú5č?đ@JÔŸtp@Qś@ÎPĹ?đ@KCBk@QŽ„+ŽĐ?đ@KťüŢä]˝@QŞ5.0Á?đ@L"'Éqš@Q¨îňG?đ@L~(‹äO@Q¨bžü@?đ@Lś˜@Q°:ŸČ?đ@L`E/˙A@QžĘ5Ú"?đ@Lă)h3@QÍŻĄ<Ž?đ@K휿ëÜo@QŢÉÖ$=?đ@KČ*<*/T@Qđe}†Źč?đ@KąKŒŚŽ@R'<)X€?đ@K˛3\3=ŕ@R"?XRą?đ@KĘ=N@R%ˆn6d=?đ@Kń-%Ąeć@R6„đX?đ@Lâ,Í@RF<9Äč?đ@KÇţúú,t@RT—ŽAM)?đ@KO˘@~;]@RWq8 ¸?đ@J×ń fő@RPqŠH?đ@JŸßźD @R?ÓČňć?đ@JV~ÜXŒ@R5ąCůç?đ@Jl ž÷E­@R&&ß6?đ@JK^lM‹ @RŘ=Ź= ?đ@J HúaJ@RúźńĆ?đ@Iš“+lM@QúîíˇŇ?đ@Iľ/[bĆf@QđyG_ÇŰ@FG8 2’‚@HT OËľƒ@@Fd‡Ľ@HvyMŤ!T@@F}ă¤EÍg@H—fNĄŒ@@F sď#L@Hť|5ú@@F¨`{¨ú@HŰÎ'´AÂ@@Fˇ%J˙Yý@I#Śi“@@@Fŕ°|Ś÷S@I×hľ“@@GĘ^IŇ@I#q\*•@@G$éP ä@I&Ď,˜.@@FńčČ+qš@I3X€ˇ\@@FéCN'Â@I[ ¨űIŤ@@GÓ ľ@IzŸ€Á5@@Fóeâžź@Ipô­­Ą@@G ŐŹ€ˇ@Iż*ÁĆG @@G5,’x7@IŮ#˛dV@@GWâŮÂ@Ić…˛Ă@@G„Ç–đĄ@IŃ#ńŠf¤@@Fň+îŽĎ˛@Ił§ą%0Ń@@Fë¸ôňma@I‘V⎶N@@FřŐżL^@Ipłim›l@@F×>gkŸŇ@IRóƒŹbx@@Fâ+ay@I.€n1#’@@F˝žíßU@IP@@FŠSj6E@Hěďá%}V@@F‹ťrm_@Hȕç"ćT@@F}Za[Ť @H¨ąGuäÇ@@FjxĚös@H‡sËO{@@FNeÂ=ł{@Hg\k;)!@@F<@@<.ďOÂ}Š@NŠĆb@@<’‡ł—MO@N§ť)ŘŮą@@<ľ3°ŔŽ˘@NÉPúŇR@@=x Ě@NĎaŞi P@@=—Žx~˜@Nć>‘Sˆł@@=°´''Ś@O 5¤ÍC2@@=œ%ň0Ć@O9ՊpC@@=B™°qń(@O N•l„@@<ĘŐľ:@O¸™`°F@@<2Ńc´|@O!h7Áţ8@@;äŇçzK'@OL$'×w@@<{ƒŐ| !@O=žÔśš@@<@^LÁ­˜@9˜rţÖ?đ@^?}–;“@8÷&úb Ő?đ@^5 Aȅ:@8ľÜŽ•Ŕ4?đ@^(šP‘­@8}‚{t”?đ@^Ć!7 @8<ƒüb˛ł?đ@^őŤg¤@7ű~ş?đ@^ ëÓNŠü@7šáŰĚyţ?đ@^nLe@7mŹëi#Ů?đ@^Ŕtői@7E-†śé?đ@^ ‰Ţ(D@6áCZŘFĄ?đ@^Ţ_ƒ3@6”üŘŰ5ö?đ@^ ÇĐđ@6g^Ľk^ű?đ@^0E­˜~@6 |7(Ű?đ@^8z N!@6G XűsQ?đ@^>ožúóƒ@6ŽźČrJ?đ@^JT$qVę@6Čäî8Kł?đ@^TýťfĚ@7ußxďŁ?đ@^[ŹćĆ˝Ů@7Jk đ˘?đ@^` °Ľ@7”gPAě?đ@^e4Á}@7Üż|o!Ű?đ@^iî„obĚ@8$cľ}T?đ@^rŃáőŽÝ@8ibÓEM?đ@^u¸Ż:°@8ŤŔ„@ ?đ@^yž(1ĘC@9+ç1?đ@^jŖcĄ7@92™›î§?đ@^Z{ˆő@9/­SÚ ?đ@^LÁ­˜@9˜rţÖŔPĄ_Šé@K\Gžœ@ŔPď˙ź+Ł@K@3Eůšš@ŔP‘&]Ç@KJwj‘Ă@ŔPLNVÚ;@K7ÄUŠ@ŔP@Ěeˆţ@K ąÝ@8@ŔPTýŚ–ŞN@Kęű_ĄY@ŔPqR˛ąSŕ@K*JÚ4Ź@ŔPŒš)A)@K>)–7`@ŔP”GԞŒ@KTĐńi @ŔPŻ@$=”@K{löx×@ŔPĄdńš@KnSŁ[Śt@ŔP¤ęlŰŽ@KL/fĽ)@ŔPœ‡ŕ?1„@K$vBN’@ŔP—Ţv˜Ď@K1śÄú#?@ŔP‰yîœĂÚ@K.ĄŠ¨ŹĎ@ŔPqçIgź˛@KöA4ş@ŔP\‚:uĽë@JůBDΗ@ŔPSVö˘kż@JČËupšC@ŔPNÓ°ç@JÚbpĘ@ŔPBÔ+Ű@Jî¸ř”@ŔP&ł#ź@KňP';Ť@ŔP ÁÄ°Ę@JúÉ_ö@ŔOÓľQŇ@Jôç]j@ŔOŁňڝčM@KPíŞť@ŔOźW‘D9@K €îᏍ@ŔOěSUŒžI@K~Đ#/@ŔP m{@j@K.šŇE˜@ŔPř‰ /@KP(°Łm8@ŔPĄ_Šé@K\Gžœ@a‹_đq"ţ@RśFÔü?đ@a­YírĹš@Rź9ţ ĺ?đ@aËԊ=@Rš×ŢR!?đ@açBŔ@RżŒĘšĐ?đ@aĘÜhńšÁ@RŇřv(Ś?đ@aĹAţœ÷@RćFalÓŕ?đ@aŘޅ§ü@RçĚfOġ?đ@aŐp[ żš@RŇqLgP‚?đ@aëˆ^ćĘ@RĹáʭɧ?đ@b $őÖÉ@RĆBc7€?đ@b暿{>@RÖűđăŤ|?đ@bÖŽˆo@Rç $6ż*?đ@aú]Ä@Rô<ˆÁƒQ?đ@a×(˘›,S@RöţÍ×?đ@ať$ÇKn@Sb"á ?đ@a¨Ôžů|‘@S@é'?đ@aźJPý”@RđŤśâ˜\?đ@a1ćó@Rí›Pú}ţ?đ@ay1gnž˘@RűI ŚôĆ?đ@aWżĂŸˇ@S ]=˘űŁ?đ@a<Ő΁T@S‘ShŁ.?đ@a-Eôëđ@Rňל'†?đ@a%96ąÉ@Râ@:6?đ@a"~’Źao@RљÍ(ťś?đ@a5€ě$@Rž ]Ę?đ@aKpŘ˝Š@R°Ó™ń^?đ@al(°uş@RąpÜ2`–?đ@az1Gžć@Rť *$ ]?đ@a‹_đq"ţ@RśFÔü@dœ8ĐOŽ…Ŕ4ŸŤűmMB?đ@d”§‘łmŔ4nŽëć„?đ@d‹ŠűÓ7śŔ4H’!Éż?đ@dƒĄF3ů{Ŕ4.xaľ9d?đ@d]÷“&ŽŔ4:‚˘ ďr?đ@d…čÓÎIŔ4x Sđ1ę?đ@d‹Ň’˙ÄŔ4šŘ5‡"?đ@d’ýŔ[ŐŔ4ď0îŞăŹ?đ@d™Ń^ŕťŔ5J{ZŕŃ?đ@d UÉ‘3Ŕ5Yĺ,0?đ@d§œ¤ly[Ŕ5†ÜDŢąČ?đ@dŻîŁF9gŔ5ŠöΛď ?đ@d¸…ÝĺâľŔ5ËÇ@ç?đ@dÂ{œyĺŔ5÷á˘÷’?đ@dȂÇQ´ÎŔ6%ßM-˛Ç?đ@dĐŹ:ËoöŔ6E(ąRqé?đ@dŰh*BIŔ6[˝1ňćK?đ@dßcăý€™Ŕ6/c˘IˇŸ?đ@d×ĚcP` Ŕ5ü=>QÇŹ?đ@dЉ ¤űˆŔ5Đ~φޟ?đ@dÉN.÷Ź2Ŕ5Ł"‚¸?/?đ@dŔřq~MŔ5w*Lq>?đ@dšJ`ĽŰŔ5X™í÷Ę?đ@dą9$N˝÷Ŕ5)IŠI?đ@dŞÝ`U kŔ4í?ڐ–?đ@d¤Cť-Ŕ4Ŕ,˙ŚÁ?đ@dœ8ĐOŽ…Ŕ4ŸŤűmMBŔRű' í@F5öXS(@ŔS˙vČî@F(UŔ0Őâ@ŔS'kčxź{@FěA%Ë@ŔSL6Î˙P@Făşžů@ŔS?ś"˘šż@FDT G@ŔSMǙs‘š@Eő”Aß~ą@ŔSf•PŹ†ń@F ”)Ş@ŔS~lś°{­@EţÜoI@ŔS—şů Ćq@E÷Y˝œ…{@ŔS°ő+š6@EđĚ°jiŸ@ŔSČ1 9áł@Eä˘ÜE'˘@ŔS݊ů}e@EĎp1LO6@ŔSí+Âśœń@EŻŮĚ$l’@ŔSߣĘj„ń@Eš|!ú˘@ŔSÇ}0źŐŚ@EĄ)ʎ@ŔSŻ]Ż/žŁ@EŹ Ą˜˜K@ŔS–*îœ@@EąU“ÂÇß@ŔS|Č.üź@EŻ<ň-ȗ@ŔSdG›ńţÝ@E¤;äXň@ŔSI2\‹$ů@E¤ál‘ @ŔS3đ‡ž€@EŞ0|™b§@ŔSZşĘvŐ@Eżi¨CŽ@ŔS ´ÓÂú˜@EÔL­(šÍ@ŔS ¸ŚÜÂĚ@EýDßnF3@ŔS.ŒNăô@F˘mŤŚ-@ŔRřXÔU@F1P˜öîŰ@ŔRű' í@F5öXS(ŔH9>íDçżĐžěĄvwZ?đŔHS  PĊżÎ§ůHç?đŔHwƨÔiżČrBŕNcĂ?đŔHœWIÜĽżĂÍ1Rns…?đŔHź•Ö>9&żÍ”s:ÜŚ?đŔHăöWÂ^pżĘä'R\ç?đŔI5›ëüżĂcą‡ž?đŔI-,°Đ%“żŔŢ"śˇš?đŔIMÚˇ P żĎ‰R˙ÔIĽ?đŔIVŽŃ&őLżâŇđňFˇ9?đŔIcE=X8żélĎqA*?đŔIP´÷9đżđć5˝6ź?đŔIX9ŰŐ/˜żňe œ‰ ł?đŔIdŃűĘFżö­"4ʞ?đŔIP9Myošżú͎3>bƒ?đŔI7lՑŚćżý HęˆP?đŔI$ʛ•5+żúšœ—Ň&?đŔI˛ę3żúĹĐ6F?đŔHţZalżűŔđÖjW?đŔHŰ3Úpyżűj-CC ?đŔHť”°ľ%Ůżůuíď]?đŔH–ůđŰxżřcCď`ąP?đŔHuQŞśl żöGZ-CÓ?đŔHhuş˛ríżó1.!?đŔHMęĐÍúŸżď;NýnV?đŔHA—YĘĚŐżćn%VĄÁ?đŔH4;:WVżŮʊrŮÓ?đŔH9>íDçżĐžěĄvwZ@`š˛řćŔűNˇŘ]?đ@`'{ fŔ.ŁôqĽ?đ@_ú7ŃÇIrŔ ŘLĆIZP?đ@`ÇŚĐŔ žíôg……?đ@` @×tÜ[Ŕ #üÓŻIÚ?đ@`~Pîâ¤Ŕ |ŢŮĐy:?đ@`H‚ţ˛Ŕ 7TFœ,?đ@`#PٌŞŔ ďÜ*ó˝Ľ?đ@`,†‹q€hŔ u)‰çG€?đ@`3j]uŔ Äŕß%hń?đ@`=sGĐĺŔ Hú)Ů?đ@`EQxűKŔ \Jš"¸E?đ@`M†›ĚŰŮŔ ?”çcőě?đ@`W*ÂL!Ŕ„˙Cą€?đ@`[ L¤›ôŔ ś‹{-?đ@`Vçd’ŠžŔ &¤ŇÎL7?đ@`QĹgç=łŔ %üˇĆ?đ@`IäaCżŔóâUňć?đ@`@5ŠSĆŔĐžłH ?đ@`8$ń5ďŐŔý&3rý4?đ@`.Ä>Vx8Ŕt čvđ?đ@`%.Ęç;ŔCł-ří/?đ@`ß ĐBŔĆ~t˙W%?đ@`§ťN1‡ŔŇü›K?đ@` `*ŢşŔáÓ_Ő'?đ@`š˛řćŔűNˇŘ]@^N˝˝˛Ŕ Š&ˆYŃ?đ@^UšęR Ŕ ś˜ú:ţŻ?đ@]řč"{ěąŔ ö޸h>?đ@]÷ŻÉá6AŔ!ST’?đ@^ â!œŔ!š_é Đ?đ@^G ţaĆŔ!›í[ĄÄ?đ@^/~’ITpŔ!ŻĂPŤęŠ?đ@^@Ţ° wčŔ!Ůa¸‹žç?đ@^T¤§ZŔ!ż›W…†Ž?đ@^f}Š&ČŔ!˛Î?Ţ@?đ@^w€ ™CĚŔ!ąË0sĐJ?đ@^‰hŇž`>Ŕ!€Io…wO?đ@^œ`wEŔ!sjŁ|Ó˘?đ@^°Y/–Ŕ!4&ý˙†ˆ?đ@^¸ěm…MxŔ €4ݛ4ľ?đ@^´~„’ăśŔ  âÎŽ×D?đ@^Ł]ÎĽ:Ŕ îŢE –?đ@^•žŹŞ§ôŔ!= *§Rs?đ@^„ĂbcwŔ!Ŕ—kut?đ@^suä‡~ÇŔ üĈŃÖJ?đ@^b\2í Ŕ!n­Yäç?đ@^P<šŔ öߊ¨D?đ@^?;ԒˇDŔ žƒîx~?đ@^+ôŚ4ˇŔ –üĘĹŢÄ?đ@^ýTHţşŔ ˆďÄúĎ?đ@^N˝˝˛Ŕ Š&ˆYŃ@/-ŇęüYű@C#š˘€vŠ?đ@.Ďľ‚¸ë@C&°ö?’?đ@-üą.Šî@CëÁžI?đ@-KąŮžü@C Ŕ.ĚCŠ?đ@,•8RœĆ @CĎĽĐ3ł?đ@+Ţ|Őťˇs@C]Ů8´?đ@+*ú1qŤ@CÝԓŠľ?đ@*uPţ*@CĄ&Ô5K?đ@)Ź v×ÇL@C t˜˝°¤?đ@)Ú!qŒ—@C?gŠ(Š?đ@(ú‹9éů@BŢĂÝ?đ@)‹ŕZă÷(@BÉMeAćp?đ@*= >ł°@B˝Î!ĘC:?đ@*ŮmˇT{@B¨ösĆŁŁ?đ@+w}çMwň@B–5ĎëU0?đ@,"žŁ\t@BŒŒęĽIœ?đ@,ťpJ/-;@Bzhbôľ„?đ@-7ĄnLą@Baš_3?đ@-調’oĚ@BXČRżř?đ@.D]ŠWÜ@BiŃ.ˇœ?đ@.‚׍­[@BŽ ćŃ8?đ@.Eâ mI@B­?J×Ze?đ@.]–ĘâĄÖ@BŃY+2ѓ?đ@.ŠŰľ4Ÿ@BňČ/‹2?đ@/œqaoN@Cl'Ź ?đ@/-ŇęüYű@C#š˘€vŠ@ACĆj> D@Ory$›ć@@AfŽóó@ON :@@A‘ŰŚlź@OJ'šiňÇ@@AĂzŽ°`)@O-H.ó .@@A—îÁÄ2@O)¤ęŐ!@@AVĐîG@O/ŮôŢşŢ@@ATů¨ž:Ÿ@O¨*N̝@@A6ِŻ@O†ýÓp@@A ómAߏ@O76ebpś@@AnHŕ‹@O1ř€ťß@@A,źcgh@OźXž@@A D@Ory$›ć@bÚFq‡ú°ŔióS“oF?đ@bÝ2čŘéYŔI" úű1?đ@bĺ’Ě•…Ŕ7ďĐŇĐ?đ@bí^>njłŔż˛Aš?đ@bôňŘmúŔ Í÷QĄ ?đ@büFŔÍ˝ĹŔ B×Ě7ű?đ@cűQĽRŘŔ ݑ^óŹ?đ@c Ż+{XŔ Š,­.Ů?đ@cg4VŔX‚É:Ş$?đ@c úÇ*Ŕ¸â==ř?đ@cm…IŔáW_â?đ@cŔLÖŮ3Ŕ˙˜•öÜN?đ@c!ž´<łŔ™s˙;Uœ?đ@c#;[ppOŔ€řaî ?đ@c śŐję‡Ŕ|,ŮJ?đ@cjŽŕ3ŔpŠ0ę?đ@c€§ ŐÂŔ>lzOg]?đ@c <Ş ¤ÓŔ śPÇ$@?đ@cőAŒ Ŕ Űë  Ŕ?đ@býءöŮOŔ žGnŢß?đ@bőéWɘýŔ¤Jžá8?đ@bíěžĂŔjÖŽżZk?đ@bĺ”.SŔŔƒÍĎ3ë?đ@bÝäîzČŔ2˙oԉ•?đ@bÚFq‡ú°ŔióS“oF@]MGYDŔ Ár„n>D?đ@]DÔjš­Ŕ Ý4ů§űŁ?đ@]4ůď¸~Ŕ!4`w–?đ@]1ňs(ŁXŔ!Ňmn•Ib?đ@]=é'jU›Ŕ"'˜Âą@€?đ@]OآÔzŔ"ĂSâד?đ@]ba70  Ŕ"׏žź?đ@]tLv{‹2Ŕ!Ů^{OŽ?đ@]†(˝ZÖŤŔ!¸Żř~#?đ@]•ŃZƒŔ!i’ŰägŰ?đ@]›pD?-Ŕ!‡EégÂ?đ@]ąkźœÖŔ!šíT?8—?đ@]ÕÍrŔšŔ!Zž—äĽ ?đ@]Ŕ‰pÚ œŔ ÎD˝ý?đ@]ŻVŢĺ‹Ŕ Ň,ŇxŠ?đ@]§źƒ<ŤżŔ ŁĐţť¨?đ@]”œ2ŤÍîŔ ĄŮēi?đ@]…˛ŢË9Ŕ FëA{JO?đ@]r|Eâ!ÓŔ [ł§ă˝—?đ@]zďTjUľŔ ×6é$€?đ@]Œ X‰Ŕ!nł}ç6?đ@]ˆíî"Ŕ!TɢVň/?đ@]v/t1ö€Ŕ!aśť;ü˝?đ@]got= Ŕ üłÚ¨‰ć?đ@]WŹ~<:Ŕ ݐœÝ3?đ@]MGYDŔ Ár„n>D@[bÍhø×@3čÇüÝ5 ?đ@[Y‰eb(x@3ßÝYM.D?đ@[N,^ąSQ@3ŠŇ[đ^?đ@[-ţi–^@3]›\#G?đ@[)8ŠŁĐŻ@3!h yÍ?đ@[*ˆĄă@2ՍyĺŁ?đ@[.Ž>\;@2‹4bĐQO?đ@[?ĎJKVŐ@2b˜ "?đ@[QtÁÄę@2LdľžĽ?đ@[fĽË™t@2;ěiL*ˇ?đ@[yţ‚ÜI…@2fş`ޞK?đ@[…žgYď@2|㤠§—?đ@[–÷žVƒ‹@2ŽÚN_Ŕ:?đ@[Ÿš|ĄŐ@2ÝE€č.?đ@[¤B^^3Đ@3)UgŰ´ĺ?đ@[ąĚV(Ĺ@3é•.‰ř?đ@[˝ď,R…@3ŚS˛ 7?đ@[şđ7„žŕ@3đŞ]“Őż?đ@[§Ăía—@4 Ą3GŔ˝?đ@[—2éđŤ@4l™ˇř?đ@[‚Mv“đă@3řƒçrĽ¤?đ@[p %ś[@3řđ8 4?đ@[bÍhø×@3čÇüÝ5 ŔWŃ"wĺÔ2@R}xe‡ŽR?đŔWżLŐH)@Rq‹Žľˆi?đŔWÓŇɒş­@Rm Ťć#?đŔWčĐľ]GG@R` ‡ˆ?đŔWćv:Œľ@RKÖm‡ŕç?đŔWé­ç +@R9%D@}?đŔWÚ*Ř{m'@R(Ł×ŇH{?đŔWËĽ&bâô@R,(ź‘ć?đŔWŔßFőÂI@RŹ§f?đŔW‡a­9@Rˇ*œí?đŔWieb;Q@R‡Źź7?đŔWzâĽ(­…@R,•wČÓĹ?đŔWMśpÇE@R1Ôr@ ?đŔW ßß­ă@R0R0őî?đŔVéZÎĚ@R?Óžč, ?đŔVÖűś˛€@RPR_,ž?đŔV¸yu>ťz@RaťÄ÷6ň?đŔV—Źi0s(@RsŠ‹űő?đŔV˛čĎĘ@R}˙–Á˘?đŔV÷šh ôŒ@R´âţ%?đŔW&Ś_"<ě@R„ŚŘ?đŔWišŮźÜ@RˆŘě˛ŕť?đŔW§á×.o6@R…ýwű–?đŔWŃ"wĺÔ2@R}xe‡ŽR@@lŒ˝¤@7ÖÍ♠‹@@@aÉX‰‚@7˜5­ŕ@@@f|čßŕĄ@7zufäýĺ@@@g.qF@7D‡?uÝ$@@@P€Zt+6@6˙’=˜Nž@@@>źJś}ă@6żÓběÎ3@@@UŁĐ@6şƒ(ĺ^@@?ö|Ç>ZÂ@6°ţŽ‰@@?ťűľaö@6…ŽîWI”@@?…ž>G.@6DĐ8œu@@?YkűüĘ°@6 oG'ż€@@?4ŤŚ˙Ă@5Çzh%k@@?,#Š3áł@5¨ˆq&Kr@@?dm5Ÿ,˜@5˙ĺkLÇŰ@@?š?"•k^@@?ŇL¤?Ö@6dá˙ÜźÜ@@@p›Žňç@6›ć‘Ôw@@@$ő”[w}@6›Ń,FVl@@@Gš.ijŽ@6ÇCj%@@@_gžVţŽ@6ů¤{ńąŁ@@@xfŸű¨@7 /Ž ĺ@@@{”„z@7VŮ€W@@@zß @ô@7œœc*}‹@@@sڐor@7ă”aôP$@@@lŒ˝¤@7ÖÍ♠‹ŔY#ß˙]zm@S%ŘYąäd?đŔYňG›Ľż@SŮhç?đŔXű:Ţ5@SyvĚ-˛?đŔY$9Rˇ^§@S˝Ňl.?đŔYeîEŚsĽ@S×p`‹K?đŔYrĂRdľÇ@S äIŚ˜?đŔYV˜sZ@RřżW¸¨Ĺ?đŔYmN9 ˝?@RőCfČ;E?đŔYšp*áői@RíFeŁ6?đŔY•lS0ä@Râ¸@Ęc‘?đŔYG%{@RćđA?đŔXĺ&9n@Rë{ŻźĎĐ?đŔXü™›qÄä@RăDŃ?đŔYˇrů?ĺ@RÔţćó4‚?đŔYƒĂ,ĆŐ@RĂAúĂE?đŔX̡C÷V]@RÁżBô„˘?đŔX„ Đű@RƂŕ¸>†?đŔXuľ,Ő÷ŕ@RŘŁ ř?đŔXY0?wŤb@RâŽ]ޝ?đŔXk;CŞčK@RóŤß&?đŔXdOă?NZ@SqžŘ˙?đŔXpEâ*ć@ST Ě0Ő?đŔX° ˝Šś@S#ŤdŐYł?đŔXď͟‰Ö@S&gř‚RŁ?đŔY#ß˙]zm@S%ŘYąäd@"[g˝Ů§@DšőSR˝€?đ@!ë•j˜Í€@D‡â4--ř?đ@!Tqd˙ţ]@Dq6Ÿ  ?đ@ ƒ*dC„@Dn‘ż×Ű/?đ@ mš¨Ć7@DMˇ P:!?đ@ օ‚TG/@D-݁NÔ?đ@ ß{ăs7@D kâ)5?đ@ űţśŰŤ@CćU­švç?đ@ Ů[¨Á҂@CÁ(zźĂ§?đ@ ŐÎŁN@C—€ÇěmŽ?đ@ űX—ěoŇ@CŰe„Ś?đ@!‘=Č;}ć@CsŐŠ‘ q?đ@"ć1â×Ö@C”UúíŠ?đ@"˝Ůۧ!)@C•œŕ0ŹÝ?đ@#,݂ÝęM@C ć?Źë?đ@#JPŇôŕ^@CĹŸŞ Ł?đ@#^e­p}#@Cëm1Wؒ?đ@#ZËö…@DŸŰ˝z ?đ@#vƒ5ńď@D0bO&äŰ?đ@#‚G…I @DQÍĆńQ?đ@#6÷Ň1Ný@DvfëLj?đ@"Ö|@D“‘s7ó„?đ@"[g˝Ů§@DšőSR˝€@`ÓÇŻ N˛@A ‹Š§Ć?đ@`Ě÷Ü]1@A Iť9Šˆ?đ@`¢̖b“@A-†5‰‘¤?đ@`ˇ)k™—@A!šĆ4?đ@`ł„›¸Ť@A ­Ă„hŞ?đ@`Š<Ë4 ˜@@úJtia?đ@`řE§N@AwˇN~|?đ@`–ŒÝn¸@@ćř”Žqö€Y@@9Á1ł"č-@NŁ-†!ŞZ@@9ž˘ ţĺÓ@NÁ6 më@@9ŠĆľÝ@Nć-WˆČL@@9ÓŞý\`@O„ę×@@:@ďžůJ@O1pN¸üÁ@@:ź5[ŕ˝@O>Ť .Ť'@@:÷śeFF@O\~eސG@@:Ôg…ç¨@OvęÜb@@:‘"ÝĘM@O^y]Ł@@:9w´mv@OBž_$ f@@9öÄ ž–É@O?ÎřŠ‚@@::^žz@O]=ŕ-c@@: g)Kg@O{ŸáŰSj@@9“w•Ůô@O‹âQ ĆŔ[ž!zÂ@MJPUD@Ŕ[ž ­×Ď@MVĽŒŢ@Ŕ[ˆ’âPčE@MuĄˇÓ¨/@Ŕ[hô–í#:@M†%Ę ÷˛@Ŕ[Fš×m@Mą‹Ľz•@Ŕ["Œ4K%p@MŮŁazF@ŔZýˇ˝č–@MšI˙‡ă@ŔZâ?,‘@M§Tˇ%Ÿ@ŔZşŮdöš×@M˘ĺX˛I@ŔZ’ˇ2˘Š@MĄ2ǔœ@ŔZšňĚĘöö@M¤3Ńžźű@ŔZ˝ ÔËÂ@MŠŒAö›@ŔZŕśóOŮ}@MąA ŕKT@Ŕ[VF׉3@M¸Űţzę@Ŕ['czç‰@M´Řň­Ś@Ŕ[=˙ąoW@Mżsj:S*@Ŕ[_?l)űő@MÉŘ Ď 6@Ŕ[wšÜĆ3(@M°ÎžŕĚ@Ŕ[“C :J­@M•÷A|#ô@Ŕ[Ź3śďŇ@M}śîyƒ@Ŕ[ÇCsuçS@MaŻW/´k@Ŕ[ž!zÂ@MJPUDŔ]š–ç`>Ó@SUĄ˝U{’?đŔ]ŕ<]2ýÖ@SK•K˘Ę.?đŔ^ Q…éý@S<ƒÄçÇ?đŔ^: Š.‡@S-ňZIP?đŔ^iÝ_Hy@S+2ÖA?đŔ^¨ě›úÉ @SČŁu*?đŔ^¤ŃJÁľ@Säœňí?đŔ^FJ'‰@S˜[+t ?đŔ^!s§Ťai@RüÄ”ź¸?đŔ]őHP~g@RúštŠž?đŔ]ÚÇƈ f@S D˛>5?đŔ]Ž;‹˜ .@S;mi§A?đŔ]žë†<}@S-JsBˇ}?đŔ]yťăaĺé@S(Ősȓ?đŔ]jЪΝ@S´Úߡ?đŔ]9te˙š@Sů7?đŔ]<´Œž@S-˝”{7?đŔ]” ‘Č1@S>[}żĆ˛?đŔ\ó˘ŢÔ[@SOĎđ€˛ô?đŔ]¨ş@S^…ăA)ł?đŔ]<šĆ]P@SY’ޏ‘e?đŔ]~V˜wa˝@SV߂=ĄR?đŔ]š–ç`>Ó@SUĄ˝U{’@UčŇkd@GÜŁ($A@@Uń$ś#Ď@Gď+ ě;@@UĘ]ůĐX@Hęˆëąl@@TďC|8@@H%Pçŕ€2@@Tčżýč@H:´V¨,¤@@Tßv¤/Mˇ@H`Lŕ%řh@@Tď~ÖŮ@H{.kŐő@@UP‹Č8@HÍUbn@@UyZ’s@HŞŮDS1@@Tő4[Îü@HĘŢS˙Ť@@TäćaŚRU@HÍť<+CŘ@@Těi űMş@HşUę+ď@@U˙ݘřÉ@HĽ…Ö_˙@@U­˝6Ý@H‹|3!t™@@Tć}…Włî@H{wB=ř@@TŰ{fH'ť@H[ˆ>úCŠ@@TÝçć9œ@H6@ŰÔŹu@@TĚď8kK@HSm‚Ż@@TŇđ6D@H ĘKs[@@TěĐÎJí@Gü?5÷×F@@UÖĘŒ€@Gç×ňý֕@@UčŇkd@GÜŁ($AŔN5â!Ď@Gv)\^ Ĺ?đŔNQ‘˙p’V@GzňŸ[M?đŔNyęÔú‹ë@GX–?Űć?đŔN‡ݚ1@G;RóäH?đŔNŹHđ˙Œ™@G×3ž?đŔNÁ1óCm@Fúű_o?đŔN´ţťNĽł@FÖ5ň/ ?đŔNŽĚ`Ž@FĘŻ|ž?đŔN\ ĚXć@FĚȚŒĺŸ?đŔN'›[<*6@FŘI—§ą?đŔN7LĘ@FďŘvš0?đŔMôZIëöë@G}qtů?đŔN.ÚşHgG@G÷`ö?đŔNJ–—Ďvo@FüiĚ’Z?đŔN] A)l@FŢĹŔjĽN?đŔN~ô­z|@FăOÇÓÍŐ?đŔNv}&,ăv@FýRŠ?đŔNGá?Ä@GZH ą|?đŔN;Gli!@G7iAwžĚ?đŔN,(#/ň@GYW䢘¸?đŔN5â!Ď@Gv)\^ Ĺ@.7jj(î@*€żmC@@-ŃłŃÝPa@*@׍)\@@-L"Ý/@*}ćcڏś@@,¸t•Ęë@*fĎYŤLŽ@@,a jŔž@*ľQ ăA@@+ţT/ąNź@*ÁjQ™¨Ź@@+—Ľ|(ł@*ö…“ÔŢü@@+§ÚŠşŮŃ@+Š,$ŒZ@@+1űŤxČe@+č ‰@@*œ]ĆE™Ě@+¨ÍŚŇH@@*źÍëV6“@+ƀBT@@+ éxś@* ['6@@+wď\gzÝ@*7¤iPUć@@+ŤŰĽP[@)ňmÔŽĂ@@+ľppE^F@)vˇ¨ž@@,, lë@)çö˜žs@@,‘ŹŰ“;@)DÔ#ch@@- R˛­Ě@)ž2,€Ő@@-‹ŤŽ”Żç@)Ç'~Q“x@@.){]ĽĽ[@)ä|“ţȎ@@.7jj(î@*€żmC@:LVoWhn@AŚŇ W’?đ@: öç†@AœŸű„ÍŠ?đ@9łϢŠŒ@Aœ1ß6J ?đ@9{ěwĚ@A¨’Ą"ą?đ@9Ÿâ`ÖÓ@AŽ8{™_×?đ@8Ęa>-ąœ@A´Ő?ɏŠ?đ@8iĒRˆ’@AŻc‡+?đ@8 lÜCŻ@AÂ%L%d?đ@7šmR?ݸ@AÉâÄ?ź?đ@70˘Ď´ @Aˇ“ţŒŽË?đ@7­´łŠsa@AŸ/9Cě?đ@8 >Ię@AšÄ†řßź?đ@8dqT_–@A•rvuRÜ?đ@8ˇ-őńö@Aƒ#…VĚ?đ@9ěÉLőĘ@AxŁ:œ7?đ@9[Yę@Ż@A}6{WŔŐ?đ@9ľŔôD˙ä@A€ĐKĺ3?đ@:=1Îg@A‚A2@łWś?đ@:LVoWhn@AŚŇ W’@8_TŜ…@Tc¨M7`?đ@7¨´ ëĄ@T ĆdŢ1…?đ@6đl˜œ@T¤°Yn?đ@6_M t!Ç@Tą6]?đ@5~ŤTWl`@T |H„š?đ@4HÁňĚN‚@T я6č?đ@3˛”mŹÓś@T'!o=ď?đ@3íiz@T WI§4?đ@2cźË‘ŰÎ@T%CľÝ÷@%čÎÚÜ?đ@^Ä'lT@%×ňvü3?đ@^źcíĆŰ@%ciŽƒÚm?đ@^ś8řĆß@$Ü.j97?đ@^ľP óř@$<IwH,?đ@^Ľ‘…BÖ&@#óŞ“v?đ@^š×Î9')@#‹kéř3‰?đ@^˘ş™ŐŔ@# ~hŢč?đ@^ąÔvĐn@"ľ.…¨z?đ@^˝yÓh3Ë@"9Z2[{ň?đ@^Íъ]@"?Q2ł]ę?đ@^ъŽ<@"Ä 9†jż?đ@^Ę2˝TŘp@#Aú$Ěź)?đ@^Ěś´$ÚĹ@#ŢĆŹŒĎ×?đ@^Ô;$ô$Ş@$gä^̗]?đ@^Ű r/¨´@$ńáŽcâ?đ@^âĽĎ§ăd@@Y+ ˆĘƒ@R’ D@@YBˤĐh-@R€!Ę~@@YWé—çj@R{JĹZ™@@YI}î“đ@R‘‚Zć@@YLůĘÁ&4@R™ÝľnIx@@Y‚ŽÜ*Če@R–ž,agt@@YĄżýk"z@R Ž„uŁŢ@@Yȡ›ź¸@R¤}p)™…@ZwtĄľs^żřrĹŤç?đ@Zp„ľ5wđżú-0L?ď?đ@ZhŠ TCćżú1"!ľî?đ@ZYR#6#6żúŽP˘Śl=?đ@ZMŹP˜şżż˙[Ş2VĄÚ?đ@ZX’€K/ŔęőhoBt?đ@Zk=3lÝvŔţ†_¸Ă?đ@ZuIóĆ°ŔČeVő(Ó?đ@ZzԓYúŔÍ2ŸdӋ?đ@Z‚îž’‡ŔŁ&CŹüˇ?đ@Z”ž”ěuóŔzăj+p?đ@Z¤qÜ!Œ^Ŕ˜mx™™-?đ@ZŞ˙śFšŔĹΉՐ?đ@ZŽČö"/§Ŕ'_Ť*n¸?đ@ZĽܛ“hŔ řý“ŔV?đ@Z”M3LäŔAÉ K?đ@ZŒ/Ű)Ŕe~  ?đ@Zˆ°§ß´żýŽŚf?đ@ZĹÝš¸żůe¤YőöÜ?đ@ZwtĄľs^żřrĹŤçŔ_2‚`Âđa@LYábď@Ŕ_%]ż3Ĺ6@L@ÁfSŽ@Ŕ_ë)Ś@L˝ô°x@Ŕ_ 4’ą@K˙şˇżž@Ŕ^÷ĄŘƒŃâ@Kç%]Cú@Ŕ^ßŢö)‹@KĚWŚ$ô@Ŕ^ÎgzČŹ@KĽîîý@Ŕ^̏Nn @KŽ3 z{@Ŕ^ÜELĺÔß@K̆*l@Ŕ^îw'e<@Këí 4÷@Ŕ^ă˜ťÜ @LŃ Ńc@Ŕ^Â?ڄ(”@Lq–’¸@Ŕ^›žƒ˙…@L Y7 Ÿ@Ŕ^ŁznKć+@L|ç0é@Ŕ^Ä á…@LçՃŞ@Ŕ^áźrX™@LÝóŻ@Ŕ_Šoaé{@Lďà Ń@Ŕ_B™R"Ú@L,`W˜Î@Ŕ_&\Sű<Ý@LL iát˛@Ŕ_2‚`Âđa@LYábďŔY ŇÄŕÍŔR Q„Ü?đŔYbÚśL^óŔRšqťÚÍ?đŔY(RÖ2ĄŔRCK?đŔXĺÔ.„ßŔRýRW§?đŔXľ#ĺ@ë%ŔR ­1Ôç?đŔXtkÔ7‹.ŔR!0Šű’?đŔX:eť§ŔR#ňE6†´?đŔX¸ZŤ™ŔRČć0?đŔX•éő‹ ŔRh‹Lʨ?đŔX0 ăSŔR šŞéűů?đŔX&Ű 6A†ŔRöéđM?đŔX<żEŻKnŔQř* h)ó?đŔX\b¤_čÎŔRô°5řî?đŔX…"'=Ö3ŔR˛ęűo?đŔX§ŃŽsóŸŔQ÷FÁœ?đŔXĂČĽM{žŔQ˙ş=ü$]?đŔXäPeŔRšĄ˙?đŔYŸ(QŔQ˙ť–¤" ?đŔYNCŠÚ¸*ŔQţ2Ça9?đŔYĹU"Œ[ŔRčą$ˇ5?đŔY ŇÄŕÍŔR Q„Ü@BKZ6@fˆ}2EH@@Aő?äĹîŠ@w‡ăg›@@Aň˛6Bъ@M;)Ň@@A읢*E@Yˇő]@@Aô°Zp@ !x€š™Ą@@BĎŕNş@ …-űţÄ@@BşÚĽc1@çNç@@B1;ipqľ@p$˜kMG@@BHîüőË@őěȗ@@BY:5 éž@ęŤ§vŞ@@BJŽţľZl@7ćx%’@@B/(J†-°@ĂĽ0-čÖ@@BČĄúĽť@ ̑xĄÜ—@@BŘęĂI–@ +ů‹`¸@@B ńÉ=/@pDŒÇ!č@@B ŘD_@ŕ.”?´-@@Bű ˝(@9o4ů@@BKZ6@fˆ}2EH@>ǧwő‡@NŰöŸBĹ@@>hƒ`6Ő@NŔŚI“ˇ@@>T2Eó@N rď#1Ü@@>4mš´6@N„ţšj|ý@@>w˜†•ź@NeŻőŸQä@@>¸‡i“T(@NC%{™€[@@>ô\s!Í@N"Ťî¸˛b@@?@(~‘@Mü›Ő¸q2@@?Ľ 1 ^@NNj9œ´@@@`3"](@N#&’Ó@@@L¨e(UË@N$Ő R T@@@băăAő@ND}1›A¤@@@dY?Ľű@Nh÷f…ZM@@@Cţň_€@N‰ü2–‘@@@Ď!^†!@N˘üŸÓńő@@?œˆazŞ@Nš˛LĹi@@?1ƒ÷L@NŇB*ť5l@@>ǧwő‡@NŰöŸBĹŔYôƒÚËG @S×"U›Ć€?đŔZ1ŕ勉@SՐ‡ßĐ?đŔZbP5š@SČńKĹÂT?đŔZ# ŕđ@SşőŹÇú?đŔYîzĹVŠâ@S­Ärü!œ?đŔZ^° őň@S˘´ăç~?đŔZ7&$§2@Sš/{o#ň?đŔYô™:}@Ů@S’[3ié?đŔY¤˜pBzÔ@S“N%2­?đŔYMÁE^íÔ@S‹Ÿ˘ S?đŔY'óVxE@S{878BY?đŔXÝŸűyţ@SvPŃą|Ä?đŔXʐŃ}ć}@S‡oxâĺ?đŔXíÄF]Ä@S˜ŇáŇ@?đŔXůc:=ń@SŞ!ËAś?đŔY<$Ňmy@Sˇ GpS?đŔY”ěÁľ(Ę@SŔ ĄŢ‹l?đŔYČNrě'W@SĐÓL?đŔYôƒÚËG @S×"U›Ć€@EŇÓNš?Ë@H˛a’ Q@@Eëî! |@H–`\źs@@EŕŻŸ î@Hx‡‹ćł@@Ež%f@H[Ří°Ý‚@@E’š0‘ÄZ@H? Dٓ'@@EyŰăĄČ@H{;o”@@EjĖO!ć@G˙w—Q;Ą@@E7׍`ŢĄ@GôÁvCÄČ@@EDui@GŰ!5'&Ĺ@@E==îń-R@GĐ3kv¤F@@Exá?Kú•@GášâŁb@@EŒ†ĐPwy@Gô.(ńÚ@@E–+=@HäÇ*3ţ@@E¸Ą+LĂ/@H8ýč Ć@@EÍuŠÜ˜@HVćŸ´@@Eânç=°„@HuO[ĺˆ@@Eô+ŚPŕM@H”HĘX b@@EՇŤżd2@H°‘)Ň@@EŇÓNš?Ë@H˛a’ Q@AKÚő”D@A×yÂٓŹ?đ@A5­­Wď@AĐRrdڋ?đ@A ĚT[l4@AżŰ`{¸?đ@@ău>Zé@A˛.őĎ\Ů?đ@@ˇk|´˜}@AŞďcŻ>?đ@@„J:Ú#C@AŹ†3¸Ň?đ@@cł{ ŕŰ@A–”)nÖT?đ@@3[ĺx@AŠdÁý1B?đ@@.űűË@An^ďLeů?đ@@MÇZJv@AVťdh?đ@@{#.}ď9@APUą8DÁ?đ@@§ž7đňƒ@A\ÂÄ~Ő?đ@@̙Q˝Nž@An źyŞ?đ@@÷Ć1j™@A|Lu/Ň?đ@@ú“ÖF @A—Ń?~ü?đ@AOÇLţř@A´}™yԅ?đ@A9ľĘľ/}@Aʋţ̒>?đ@AKÚő”D@A×yÂٓŹ@_„pňW@)#â*Ć=›?đ@_żů2X<@(Ҳţ×'g?đ@_žgŐ@(NŚ@Ä:A?đ@_,Ĺî3X@'őťŘWb2?đ@_:m6]"@'˜ŁĘdɈ?đ@_;ŕˇĎ@'-ţęs›.?đ@_<ÔkD¸{@&ÔN ĚĂ?đ@_KŔůű@&hfšiČ?đ@_e€ľłx*@&B™ęEžO?đ@_e'Œ@&şY8śĂ?đ@_^ť˘Ă˝ą@'Uż.˛Ÿđ?đ@_^K%×f@'á§ĐÔ ?đ@_\ó­/×2@(mœŃ`Ý?đ@_RŽîÁŮ{@(ÝžôÚüä?đ@_@ţnO@Ź@)Řńxžk?đ@_/ěćTçź@) Át}–ĺ?đ@_WN6ŸŁ@)ÄOÜĽ?đ@_„pňW@)#â*Ć=›@;NłîÝŔ1é­a´üŕ@@;Dšç/r{Ŕ1˛¸9ׄ@@;€€{_z\Ŕ1„Ńý-@@;­G°7JŔ1Aý¸\2“@@;î4J>Ŕ1˙ҕě@@<nrlÔyŔ0îŠĂŠ–@@@2~ŮĽ ’•?đŔS[ŹvRë@2wš%wŮE?đŔS‘Ľ0ť@2bZ]Ý ?đŔS’Çë ‘Ç@26Í*›P[@^zč޲é­@'ťĹŤ›‚’?đ@^đ]…Ą°@'hŐ_=+?đ@^„TpŮ´A@&ŮWąw?đ@^ƒŠ!őy@&EčcŠ?đ@^~ ß*œ@%˛‚Aż`?đ@^}lßMtÜ@%Ôrń$?đ@^…_ľń@@% ֍Uţ+?đ@^”ő#š‚ @%OŠ¸Â?đ@^§‘¸ă@%z_ü‹uť?đ@^łěPN”Y@%ßÓ1Ńßţ?đ@^Â12Éýf@&>‚@d;[?đ@^É!†Ěíˆ@&čahÓˇ?đ@^ťöÂóP@'đ“Ę?đ@^ކ —@'á$ńŠ…?đ@^™úźAśö@'_ŇZXŻ?đ@^‰´ŰM@'¤ÄţčŞv?đ@^zč޲é­@'ťĹŤ›‚’@]żA3Ŕ#QÎGľŃ?đ@]Ě!ŕ1Ŕ#x M0ŕý?đ@]Ţ;şĎŃŔ#‰xŮ\Œý?đ@]îôŁgBőŔ#š${1î?đ@]ţ‘šgŔ$ u0VęÄ?đ@^ U4†ŢŔ$oȎ ĎŁ?đ@^Řp>sŔ$ˆšg‘?đ@^0‘ŽˇdßŔ$KďKěŘL?đ@^.~  Ŕ#ÖŰĺÚ?đ@^!\% &&Ŕ#fŤˆ›Žš?đ@^Ô5 †UŔ#*=ŰP[ ?đ@^2AݤŔ" Ňŕáą?đ@]đľXHŽ¤Ŕ"ť-#s„?đ@]Ţ.ámŔ"ź^ű§?đ@]ËFLG÷Ŕ"Čü"zî?đ@]żA3Ŕ#QÎGľŃ@Xëp\[R@SŘYŘľĺ?đ@Xöˇ:Á @Sëj豟Â?đ@Xâśóś-@SüÍ´6Ü"?đ@X™ŢJeÁ(@SüďhG?đ@XkŔ¸˝E@S÷3Ř΢?đ@X=„+"K@T J#ť?đ@WŇz˜L˘@TDűśÓ|?đ@W–}7‰kŞ@Sö™ş#$?đ@WTÍZ¸Vë@Säv˜#Β?đ@Ww~i˘˝@SŢVžÎF8?đ@Wľsźď°@SČu}Ń?đ@X÷o›Ä@SŔÔ …4?đ@X]UÄE@Sśq_€ž?đ@X´˜p‹Ý@Słľ´ląż?đ@XńíP‡h•@SŔC…ˆI?đ@XÓ̖–ĚR@SĎ]8¸x?đ@Xëp\[R@SŘYŘľĺ@V˝ě|@KRv^Ţ?@@VÎ*6n1S@K6!¸7s@@VŰŁcLú @K[~Ę\@@VÜzMNęi@J=ö@@Vćľ.ÇÓŘ@JóćśźC@@Vć>ůŕ@K/5'ţĆ@@Vߍn•@K.v.{@@VÇQ˝ií@KL…œťÂž@@Vżš!ř=Ć@Kn¤-§AE@@VÔ~Eú"‡@K…€EŰ@@VňUý ĺ@Kj}Ӝ^@@W=ůs™Q@KŠČxOPY@@Wţž'J@KĽ_u]ű@@Vî5m]¨˛@K”†ŽŃx=@@VĎĽŢ6űE@K‰›Ý§R3@@Vź#46Ýe@KpÍ'őĄ~@@V˝ě|@KRv^Ţ?ŔX~GR‡ó @Qx°X‘Će?đŔX¸Ě°÷@QoAEY€?đŔX–Č^ţ@Q^č+aŽ?đŔX­zÉS4Ć@QNÍł(Ä?đŔXÚ*)Âg%@QCŁ=é,$?đŔXž`y)Ł @Q7´oÎŔ?đŔX‘~Ĺľ@Q0ŠiBä?đŔX[buJ@Q${=„ó?đŔX0y=§oÓ@QśFO`r?đŔX'k˙°]@Q$y]l?đŔWႠ…”î@Q/hJőćĂ?đŔWčői­Ę2@Q8Â(ˇôô?đŔXŮaüé@QHP[W#g?đŔX-šđV@QX\ůËÔ`?đŔXIO•°*@Qf%°ţÇ?đŔXcf€vË@QpאÝÇ0?đŔX~GR‡ó @Qx°X‘Će@W?ł6üPľ@+Žz¨ /?đ@W7á˙#š@*¸]—?đ@W5Ţ[ÔŔ@*'łqâř?đ@W1+ď4:@)Ž<)}†?đ@W.:D@)şŁ;Ël?đ@W.‰XwĹř@(r–°ň÷I?đ@W%öG+#Š@'ÖłŞ?đ@W)6ö“@'=ŇdQ?đ@W/Qňó$V@'_äL"Ÿ?đ@W1C˝ œW@'úśĎóQď?đ@W8Y0Ś]Á@(ž|#ä?đ@W=/‰ @)Â΃„^?đ@W<XÄ[ @)˝=ĆĎďź?đ@W?÷Kó'@**ŻJŞ‘•?đ@WB”sňAi@*źNôtI›?đ@W?ł6üPľ@+Žz¨ /@Y¤OĎ@b@Sv(ŚfR?đ@YS_¨˙Í@SŠ~ÄtĄ~?đ@YŞ‹Kĺ@Se,˛zň?đ@Z&zŒB@S“VŘň/§?đ@ZIžB:—@SKŃkzŚ?đ@Z@‹ ĚŮC@S°ĘsGp ?đ@Z€‘¨;h@S˝$eÇäĘ?đ@Y׸&/’˜@SĹČ=˘”?đ@Y¨)űG¸@SżřçĽň?đ@Yžď†*H@SÔĽż)űş?đ@YLƒ)“V@SÄŻéÉ?đ@Y20Ŕ@Sł;Ž7?ó?đ@Y ?w­'@SŁbN?Ä?đ@XóX¸¨?¤@S‘ˆýşţf?đ@XŮ;BÝ  @S‚bößč\?đ@Y¤OĎ@b@Sv(ŚfR@_ę˙V@&eŠH 9?đ@^ýƒáax–@&Amg› 3?đ@^řßś„^@%ś ”)mŚ?đ@^đX÷al@%1´Č˘j?đ@^çĺŰXÖl@$­zŽ›"Đ?đ@^ÝŘÝ@$)DU;î?đ@^Řl’^3@#ŹČ^”Ž?đ@^Ô÷œóƒ@#z=¸ĐÜ?đ@^ܙl‡śę@# rĂyb?đ@^äSϞóX@#”^’ďŤx?đ@^ë#YČP9@$dUC-Q?đ@^řČÄ1ř@$Ž´˘°O¨?đ@_pî˜B@$üíwš|?đ@_Ł,WœH@%’/s A?đ@_|‰Öŕ @&$žŻńrW?đ@_ę˙V@&eŠH 9ŔY"ë'śŽ×@J’í@e°@ŔY9rşaŤ@J_ř›DŮ@ŔY>ĎŨ&š@Ju qż'@ŔY)jíű™c@Jp˜ś\pI@ŔYö?ČíŠ@JaJ<|ň@ŔY´a\Ÿą@JJaÎ?)@ŔY ßÎ؅@J&Őu…J@ŔY’(š(ó@Iő=ÁŹóD@ŔXô€5Şî@I؇Ü>†ý@ŔXîe×đBC@Içö~üć]@ŔXó7ő"ś@J O\năü@ŔXďšŮ‹Ç@J.ěĄ*@ŔXëň™SÝ@JRĂů!G@ŔXń¸ĽQ{”@JtĘÇásÝ@ŔY3ƒÜ•F@JŠ3étĂ@ŔY"ë'śŽ×@J’í@e°@cW‡d`Ż8Ŕ:/.@>Ű?đ@cWpˆGDÇŔW;q ŠG?đ@c\Kâąp†ŔIćӐ/?đ@cbţîv­Ŕ ąŘt2Ł?đ@cf߉˙ҟŔô=‘Ň?đ@ckćŤĆHŔäG›˙i?đ@csržýDŔl &¸>Ź?đ@c|”—†píŔ¸Rš‘?đ@c{íoAą|Ŕć œŮČ?đ@cu Bo+źŔ¤7=ß?đ@cnHaë&Ŕd‡ŢuŮ?đ@cgî÷ąŔx˘˙A]*?đ@cb~ß€uŔqBżF?đ@cZ™ŇŘňŔ˙:Jm˜H?đ@cW‡d`Ż8Ŕ:/.@>ŰŔ`ł<=że@L,ˆ‰?#?đŔ`ŻŃÔd@L&Âi?đŔ`§ƒP{—@KúZpS8Á?đŔ`Ś9QpÜp@KŐ*t‡ŕP?đŔ`˘NPl9@K°\aV¨[?đŔ`™œW÷5@K›Ý™?Pę?đŔ`óŸk @K€ˇŁp‰?đŔ`‡ŽšGié@KcQ˙§#?đŔ`€5é2ĹÖ@KsKHô‘P?đŔ`ƒ>MęěÖ@K“_Q_?đŔ`ŒGOćÓ@KťNęŽ ?đŔ`Œ}÷dŚ@@KÓ3 Â/ě?đŔ`” €A)@Kô’qpˇ?đŔ` …ĘMxK@L ˜9“Š?đŔ`ŞÖY"@L'Ů^GPŹ?đŔ`ł<=że@L,ˆ‰?#@^ˇč‘7ę@R:LoY.Œ?đ@^ńˇK@R3&žšÓ?đ@_'p9A‡ @R*Qń_†•?đ@_Wœ5żú @RŸčM?đ@_ŠľX7í@R~§˜F?đ@_”={?Ō@R/ş¨-ę?đ@_Ł‚Žţş‘@RAAď?đ@_0d•&Â@RT›†¸ĚŒ?đ@_yi”Í´Á@R_âĚOr?đ@_C•îx@RiNI$š?đ@_W•Ă@RmlQóĺŇ?đ@^ٟí.Vl@RbŚmľ|U?đ@^ŢŃj ~X@RKK#Ô|k?đ@^ť-÷mź‘@R>ąBzi›?đ@^ˇč‘7ę@R:LoY.ŒŔPľźE­§@G~ښěK?đŔPY]śd@GaÖˇÇF?đŔP ŕ ŐuŠ@GH*‚ˆŚŮ?đŔOěÄi´9@G0<‘•„Q?đŔOĆ_ăuÇ{@GÇŚĄäŮ?đŔO,ÂOĎô@G‹ĹX-Ö?đŔOrƒŚý`×@G¤zi5R?đŔOCî"Đ-@G ň_}?đŔO aÁýŘ:@G.%0çë?đŔOHn ŽŢ@G:€7Š‚=?đŔOvĽŽ1#$@G6É3,b•?đŔOŽyǝ^@GşDŕŔH˘÷Č;¤?đ@Q4ĐĽ(ŹüŔHÍeM3B?đ@QI‡5˝Y1ŔHĘŐvř+?đ@Qg\Œm<ŔHĘÇS%Ă?đ@Qx˙ˆ—ćŔHŇř‰Ž…´?đ@QŒ/ëEZŔHÍ#FC×h@^ŔŒzˇ@*ď§4‰…ć?đ@^´ěK@*ŤIČź?đ@^*žšÁQR@*?ÁS˙%ă?đ@^1рžăü@)ł?ŹMŤ~?đ@^9Ś ƒ@)6ń˛•¸ ?đ@^D\G~6@(­šf?đ@^S ňôœD@(Ľ4tvá?đ@^]o r@(őĂ<ĚŇ?đ@^`DđśjL@)ƒý̙Ö?đ@^_šk ĺ@*#ŽG!qq?đ@^UÚÂxÍ@*–ťşŹî?đ@^DŤ?=z@*ŕl~–áÎ?đ@^3üí:9@*ů—ŽœG?đ@^ ťˇHĺ@+Š đ5Ę?đ@^ŔŒzˇ@*ď§4‰…ćŔT4Q@RlI“÷EG?đŔT5Ăžîˇ@R]ěŮr?đŔTÇkJŮ@RNϊP|?đŔT?ˇ#o‚@R>R<şé?đŔSÜfň-œŠ@R1Fáť ,?đŔS  R\ńś@R6ÁÚýW?đŔSbăvÚ9x@R8ćˆÝ”?đŔS"˝ÂŒnŠ@R5",“<ç?đŔS^ă†Ň?@R@Ü6Ôˁ?đŔS/źPĹä­@RQAËŻ‘|?đŔSTyL@R`0t{ť?đŔSŽľłřŤŢ@Rig<Ś?đŔSŃŒXA•@Rib‹pE?đŔTć×ßN@RnΉ÷÷v?đŔT4Q@RlI“÷EGŔRrľ2řdŔEŻŽ?iœf?đŔRjéğýăŔE•sŞ÷~a?đŔRe-ő´ŔEx ŠÂšĎ?đŔRkĂ˙j– ŔEXQqŽWV?đŔRnŔE=Üqˆő?đŔR] 9éb'ŔEłĺł2;?đŔRbO gxŔDô”í?đŔRyDbŻăöŔDë "ü?đŔRƒœ—yŔE˜%*3?đŔRŠÚĚYZŔE'Ł"!â“?đŔR‹úÍFVŔEL\Űŕ-?đŔR`JMé•ŔEr_Jyű?đŔR•¤*ÝplŔE–ťŽř?đŔR…gUÍUŔEŹœZn{Ď?đŔRrľ2řdŔEŻŽ?iœfŔNËh!uQŔT4Š ?đŔNJĄ)žł“ŔT&‹9?đŔN {@HŇn^ë@ŔYË!çŽD@H łŕШ@ŔY°t5â7ô@H P˘>š@ŔYŁžŢÜ,%@Gěƒ­o@ŔY“`qŰ@GÍNł™°@ŔYw´°”şš@GžlÔétě@ŔYSŠÜÚËĂ@GČ8EĆa@ŔY_äşÄę@GËÔĂý*Â@ŔYz#Šě‰@GČDŻ|ô@ŔY‘­”řT‘@Gčűő ną@ŔY¤uĎFQ@GôÜ\üţi@ŔY˛8\‰ě@Hâô—…@ŔYĚC_nˇ˜@H1Ü' C@fWŹˆ‚ň{Ŕ1đp'Ś?đ@f]Ä ŠŔ0ćĺÝ,B?đ@feŤżôsŔ0Ŕţ˙üGÍ?đ@fm •ˆKŔ0É˝Ŕbľ?đ@fz÷ÖÁoŔ0¨?Şr•?đ@fsNĂ?ÍŔ0ąž;h˙?đ@fsÓŘ/œŔ0’,ňÉ>?đ@f|Â!ó)PŔ0? ĺ‰y?đ@fu?bŻŔ0:őŔÔY5?đ@fm7QŽ7ůŔ0Xú< N?đ@fd(ÂŰ5Ŕ0n÷‰Œ9ô?đ@f[wÉ{ć×Ŕ0ŽÇ°Í ?đ@fRaŔř`#Ŕ0Ż;>m´?đ@fSĎŚ'Ŕ0ܤ'ŹĽí?đ@fWŹˆ‚ň{Ŕ1đp'Ś@aQTK0RţŔ‰ď˙Ž&?đ@aKľĂDRŔŻŁ vb?đ@aCrP†“řŔ3؜>DT?đ@a=ť&Ü~ŔšŹÉ?đ@a9IĐF§Ŕ š@ŹLŤ?đ@a5_6Â?ŐŔ œÜŐ-=ó?đ@a9­:ýo&Ŕ Č]͢(.?đ@aBţY=iÓŔ Çf÷$ö!?đ@aLDç×uŤŔ ÉVdŠďD?đ@aT:LňnŔ qgŘbÉ4?đ@a[oĄÓŸßŔ ‰ó’˝a?đ@a_KFć†ŔŠîJXŠ?đ@a^˝v’żéŔ%ü—|Ž?đ@aVoËÉOŘŔ~:šźn ?đ@aQTK0RţŔ‰ď˙Ž&Ŕc{íIN˝ň@4< \A?đŔc{Z^Ţđ7@4fł¨B?đŔcő]Ď%“@3Ŕ8^DE`?đŔc}f‘ŃA#@3t…|ľ?đŔc|—ĂŹ˛t@3)s’Ń)Ř?đŔcu‚ŒÚŒĽ@2ţa‡™çU?đŔcmĹI\Dš@3,öó”C?đŔce ˇă@3K üÄŠť?đŔc\ ’—f@3tđpáa?đŔc_‘ÉXp—@3ąśtĽš,?đŔcdŹÚdĺî@3îěWO&?đŔcm;ÇýW@4O˙şŸ?đŔcv"×Óŕˇ@42ľ˝'}?đŔc{íIN˝ň@4< \A@"žV­ĹH@E ą, ?đ@"•Q@D@EdJ<_Ľ?đ@!獤ĆUí@ER!wAR‘?đ@!JĎlł/@E7ˇÂČW?đ@!E_Ť@E{žĎč˘?đ@!hĆ,şÖ-@Dď;´T°ý?đ@!Ź|1 `@DĐu‘‚,?đ@"a Ie‰Ř@DźžL_ř?đ@"Ŕ˘ĽťŹ@DÜ7Ď}ł ?đ@"îŕq„ćë@Eśü€ň?đ@#ÔěČBś@E%蘟q?đ@"ú@W7@EKŹUz˜`?đ@"ďȧy3´@Eo?çšĐ?đ@"žV­ĹH@E ą, Ŕ`uáBŒ`@KžŞJj?đŔ`€ˇ$`Â>@KçVvcß?đŔ`‡ÝŐi@Jćç"DÂ?đŔ`Œ7ĐŮWů@JÖŠӄŒ?đŔ`ĚóDôĽ@KgGÁw?đŔ`š‘+@KE9ě?đŔ`˘ź­G @KBâ>?đŔ`ŸžsȔő@JÚjZ¸˘?đŔ`•× ˛hş@J¸7‚ű•?đŔ`’Ä,ňěY@J ;ý5Š?đŔ`…ţŰęn—@Jš& ý~ ?đŔ`}šťŃ#p@Jśü@F’ä?đŔ`|Zďť]–@JŰO:•Őŕ?đŔ`vÇŁŞžÚ@JýŔh8ńb?đŔ`uáBŒ`@KžŞJjŔQbůš¤IĹŔ.Á O>l@ŔQmĐeGd{Ŕ.˜C ˜<8@ŔQvč:/ŽÂŔ/ Nx}Î@ŔQgC§§Ŕ/s—ÄՊH@ŔQtƒ&Ik%Ŕ/Ŕí'¤@ŔQd PźcÓŔ/üłXie@ŔQZnťđŔ00ˇë€0@ŔQG@]ŞŔ0)˘2ÇžĎ@ŔQ=˜3ś/Ŕ0bşNYžű@ŔQ,CŰ ňăŔ0SsâÜj4@ŔQ5e>ŃŔ0č„jŠ-@ŔQ>ˆĄuŒŔ/ÇóëšÁĺ@ŔQLĹ.‚­ŇŔ/]-Ӑ)ř@ŔQY˙A=§Ŕ.ůΛŽľ@ŔQbůš¤IĹŔ.Á O>l@_(€˛T@&áňӎŕŰ?đ@_ƒ/ ť!@&`{Ř&ƒŐ?đ@_ ŸkoŁĂ@%äÝćĂ(?đ@_0z˘Šť#@%ĽÚ Oň?đ@_0şŹČ!@%ŰÔQhŽ?đ@_9źđÝ'u@$Tčq+ÂÍ?đ@_GîŃō@$’‘˛ ő?đ@_La ‚Ił@%ř‡ý?đ@_C,˙‚Ś@%Œ,*˘?đ@_BľÉ~ž1@&#“Â6g(?đ@_=Ł'0ł—@&Ź,‚dť%?đ@_-…ƒ':k@&­ĎÄv§?đ@_ńÍU;(@&ŕč`”x?đ@_(€˛T@&áňӎŕŰŔPĚÇU~Ń@2?‡˝tD?đŔPÇ݆d@1üŒç~Ëţ?đŔP˛đƒ ,ľ@1÷s×ACŽ?đŔPŸQ ŠÂ@1÷†ű! ?đŔPŒlVcBć@1ńꟘÖF?đŔPxíó Bo@2`UďKń?đŔPk7ŘĐN@2FłrŃN‚?đŔP}ƒäÇ8@2r{mÇ?đŔPhr–QÚ@2v&ˇ:ä?đŔPĄ“LœŹ@2|XîSÝń?đŔPľSÜJz@2}büĽ>Ş?đŔPČĄy—ű@2w  _?đŔPĚÇU~Ń@2?‡˝tD@fBFţÁ Ŕ2AMžA†?đ@fH{Óü¨‹Ŕ2-Ž“?đ@fQPýr"ÁŔ2†%xk?đ@fTRŒMôŔ1ě9éE?đ@fQpWĆĆńŔ1ĽÚ6í/ŕ?đ@fIÍ9&Ŕ1pœT÷ĎÇ[ [kľŔ/P ĺL@@>ńđşŠ]Ŕ/dzoG"@@?;5<ŕŔ/…Ý–÷¨.@@?ˆvo‰ŸŔ/nššÔƛ@@?ŐJ m3Ŕ/ogóÔj@@@ŢQPËÂŔ/\[ĽŤ/ß@@@B†˜Ř9ťŔ//žoU—ˆ@@@1Βę†ĺŔ/AOąžÍ@@@ mßľfŔ/-1„´Ú@@?Τƒ DŔ/7˛ˇl2@@?~šˇ2hzŔ/<Âd6˜Ô@@?5nB6çdŔ/V/—(Ž@@>é;<š…tŔ/KýÍm@@>Ç[ [kľŔ/P ĺLŔR­•ZšůŔI GžD?đŔR ÇĽ•šŔHô‚Ë\uj?đŔR ´q}ŽŔHÔ˘ÝH“ó?đŔRXĄ07„ŔHŤ˙;ç ?đŔRŸBaÓrýŔH„YÖR“Č?đŔRŠ7IŽöŔHbkFWü?đŔRźh`ŒsPŔHpžv\š…?đŔRť)ˆ>7đŔHšRóFD,?đŔRѨ{%‘nŔHŻ¨´qL`?đŔRÉ\žs­úŔHÜuÔ1ĂÂ?đŔRˇ'zBŔHŔ ”đ?đŔR´čx÷×ŔHĐĘÔvÎt?đŔRłtÄ;ŸŔHőÄęmÁ?đŔR­•ZšůŔI GžD@b•˝ b@FŔu}ői?đ@bSΏއ@FŹĚŻGŽ?đ@b€|d¸q7@FŠt$‡ ÷?đ@byľ7âđ´@Fš”p˘H›?đ@bp+€(„@F‚ ‹„~ą?đ@beĘŽ$k@Fd5Č+ż,?đ@b^SŔoŽň@FE\ÔE‹ň?đ@bb‹—Xůö@F@ĄžůÓ?đ@bkÜ` ľ6@FZTîüÉ?đ@bu.­ @FuߢYÇ?đ@b€“Y™Í@FˆB'¨?đ@b‹T‹H )@Fx!Ž?đ@b˜EfŔŠ@FŻă§Ş ?đ@b•˝ b@FŔu}ői@Žˆ‹učž@&¸Ěd˜s@@B0ĆÍ›@&jBŹôwv@@CéŚGÂĘ@&!‘~8ß@@ÁżŠĘ_ď@%Ÿ @\>h@@¤ÍPKŠ@%/ŽŮ}ž%@@Ŕü¨‹š&@$ŤcÌő@@ %‡wÖ@$ };x+@@dâŐ*íć@$.8ú+@@ Ö‚ôƛ@$¸ołĚúP@@¸ľoPŕ×@%>‡í„úR@@Íwkޓ@%ŐăƒÓá9@@#EŽ„@&Ia.ŹŠ{@@ýWnž˛@&‹[ÜťOť@@Žˆ‹učž@&¸Ěd˜sŔY-°ý˙Ç@K­&/6@ŔY˘1zť@JůőůôO4@ŔY8żRţ@JŰś G÷Ź@ŔY,–,–ű3@JŔ+Ō‰‰@ŔY ÚŃÎ@JŁůˆ>üŽ@ŔY˝î¸˙@J>k“2‘@ŔXçŠÁRv@JŽőZö‹–@ŔXŮ2ĽĂŐ=@J›Ž^ —€@ŔXëÇ.”ĄL@J¤LČőBŠ@ŔXüÔćn@J°,ÓÍĆÓ@ŔY¤]8ŕ\@JÔNŸ ¸9@ŔXîEżČîÂ@JórßLW@ŔXţ‹‚$î´@Jóčű Şm@ŔYZEœ*@KĆíWݖ@ŔY-°ý˙Ç@K­&/6ŔR@kt~ć@IŞŔËLĺö@ŔRT>wÝÍt@I˘Nd@ŔRk2C`~@I‰=v:˛ł@ŔRy M,ˇ@IpŻä{`é@ŔRFš`=š@I?[ů˙ˆ@ŔR¤ř蕵@I1ŹBo@ŔRuEU` b@I)Ľk)@ŔRs$Üzýđ@IEÔ{ş™ô@ŔRföŘĘT@IgŸ‹PĄ@ŔRQÚă'§L@Iˆ´çŁG[@ŔRU—‚—\Ű@Itƒ°ËŒş@ŔRJEp\Ş@I}Ţulú@ŔR5úz2@I–e)]@ŔR:(HRż@Išvţ÷\Š@ŔR<îĺRĎĘ@IĄü}‰+@ŔR@kt~ć@IŞŔËLĺöŔ`ÝÝŞLd@M*ˆ˘Kˆ?đŔ`ŮK¤IŁF@MIÉÚó?đŔ`Ö­ĺJ@LćöˆBÂ`?đŔ`Ď6"ąi@Lťˇ?O?đŔ`ĎŇç} @L•5€H?đŔ`ÂO/‰ň@L§Ö+SÓ?đŔ`ż}ľA@LŔâĺŇ ?đŔ`ÇAF›&@L÷őxżY?đŔ`žjcJ#@LÜÚô!ĆS?đŔ`žN5Ď?˙@LëůţSé?đŔ`ĆşWöJt@M ¸ÁńRˆ?đŔ`ÖbÂP÷@Mˆ)ăё?đŔ`ÝÝŞLd@M*ˆ˘KˆŔKEöéžĺZ@Q’Ě?đŔKNxŽű\@Q€ŞŢCs§?đŔK^ƒë3 @Qp˙&ţ3p?đŔKG„Ďľ@Qe6îŢ]?đŔJۑ˝@QaoŽ>`?đŔJřQł@QZí—}ť?đŔJ܁Ž†r@QQ„ĺěĎo?đŔJya#‘žÄ@QUľS~Š?đŔJĎë4Ř@Q^B!ƒË?đŔIű{ hĂy@QmfŤľ}v?đŔJOrT*<Ŕ@Qz­({Ś?đŔJ“?öĎş@Q‰0ŘDźÝ?đŔJóëOö@Q‘™ĺ­öô?đŔKEöéžĺZ@Q’ĚŔUvĚbě[@(+¤ŚÔç@ŔUz6łÁŒć@'Éś. ç–@ŔUvŘ%Ľ8Ŕ@'Aťú—m@ŔUnBvdŽ@&ľÎ2'E@ŔU^ákT'@&cYż%mĆ@ŔULŘm'Ś @&5Ž¤=ü@ŔU9Ś]Ýië@&‘UľvÓ@ŔU4(žÎoč@&…LŃ= \@ŔU>G0TÚ@&üä:^@ŔUJĎ.ü4@'lĆŇć(Y@ŔUZ–fY@'ğ–2Š@ŔUhäżĎÂü@(Ś˙cŒL@ŔUvĚbě[@(+¤ŚÔç@>›$b×?đýĹÉdmF@@>ĒÖF[ý?ôBôҝŕĘ@@>ő"{tNŞ?÷íބóa@@?47l—e?ú1$ńœĹš@@?^ěöhŚŔ?ýóĽ?ƒü@@?iÉ^ÂŘ@˛üűJË@@?F\-#ü’@wÎh<° @@?"k‡Ç?˙ŮĐ&Ůi@@>Ő`ó?ý–âząa@@>Ÿ<ťxm?ůâϟ}W‹@@>qˆIC˝Ţ?ö7Ę#I_v@@>{†qpŽp?ňŒĚôÁ˘@@>›$b×?đýĹÉdmF@WĂę\Ňë˘@TLĽąív?đ@W]y•KD@T@t¨š?đ@W8tWîÎĐ@T1"€ňÄ-?đ@WîgťiD@T `:?đ@W#@0@Tůí^ß;?đ@W,+gľĹ@T äŻ;?đ@W–BF'Q|@TĘLŇA"?đ@W÷VÜžéH@T €˙ˆ?đ@XKă°ő۝@Tr™¤’ą?đ@X\*šŐ^_@T)şţF?đ@XS.Ąbia@T7†+ň_Ţ?đ@XóĹĎć@TGCö‹×P?đ@WńŚđu1Ě@TQűjIË?đ@WĂę\Ňë˘@TLĽąív@C´VÚŕ@MŽŽJE˘@@BŃ%ˇÓ @M‚ůœő‚ @@Bő™?ëďU@Mm–98@@Bń›ŞÖ†ţ@MOîˆĚ '@@B¨:Ş+iQ@M\Aľ`×n@@BŻń y@MNščŞĎ@@Bâ‚4ě>@M/÷ďËJ`@@CŁ­ě¸.@MsÁ„(@@CRŢ)\yŕ@M›Ň:“@@Cz ;‘ůÁ@M2ŽËdţ@@CPńM^b@MM䟝• @@C#‹xL˛<@Mkjńćü@@C´VÚŕ@MŽŽJE˘@cĐÖ-bťŔŒwÂQD@?đ@c×Zś‚ˆŔkŽ˘üł?đ@cŢ0 ĚŠŔ ¤łăfň?đ@cć‹.7Ŕ XŠ*é?đ@cţ•Ŕ šî.ŽÄ?đ@cřČןŒŔ ôî7Á7^?đ@ců†–›ŽëŔ śŁXuV?đ@cňÇ”úQŔ JëړS?đ@cëїşßŔőťűÂ,ë?đ@câŽK–EłŔ?Ě/"Ý?đ@cŰsĽüŔÍ´ÍÔ#?đ@cÓr;˘áŔOdt?đ@cĐÖ-bťŔŒwÂQD@ŔRÁsĂ-š@Q ĺ ĺ Ą?đŔRŐoв ~@Q8/_˘ó?đŔSňű™őQ@QYľ ގ?đŔS0bz’ p@Q ńČŽ7?đŔSGÎćÚ@PüAşş@W?đŔSQĆçh™g@Pęf󩀨?đŔSIěÎhü@PŘr‚Őˇ?đŔS'^sYi@PĎ00U“Č?đŔR÷Pwönk@PŃÍ"ƒlY?đŔRĐ,=¨&r@PÜç$ß?đŔRĂżé×Ë?@Píזt˘ś?đŔRĹÍDo’,@Q>/ż6ż?đŔRÁsĂ-š@Q ĺ ĺ ĄŔJÂ@:Œ‡Ŕ@ʏ ľEš@ŔJşN’bŔ@š6,J{h@ŔJŽC3Ű^Ŕ@‘÷–.wő@ŔJ”žś˙v”Ŕ@wfŕ8@ŔJ{ľTΛćŔ@l+×ű”@ŔJZ -mNgŔ@dăjؔ@ŔJXŰđůˆŻŔ@.\8këƒ@ŔJyi‚NÁsŔ@@Ęł @ŔJœÜąę˘űŔ@[‘yĆ]@ŔJ°îEiWSŔ@w7Ę ˝ť@ŔJÍrŤ˜-Ŕ@’×9‡ňý@ŔJȀšŠ5&Ŕ@šFyRčÉ@ŔJÂ@:Œ‡Ŕ@ʏ ľEšŔWŚuüR…@HýĘôŰűH@ŔW§ótk„@Hčźőo@ŔWşę×Iˆ@HÉ.OÔ+@ŔWžq2XşŒ@HŠ \mťČ@ŔWÎAÎxu@HŒŚ!ÜE@ŔWÇzč@ţ@Hvt”}8Ç@ŔWŤyrĂÎ@HrqS1‚R@ŔWŽ…6y+…@H÷Ð=@ŔWŚ fÝöŘ@HŞ–pŕČO@ŔW‹çUM˛8@HŻ ‹ăńţ@ŔW“źÝÜ.đ@HË~ş—Ŕ@ŔWŸ‚<˘Gˇ@Hé˘Ń @ŔWŚuüR…@HýĘôŰűHŔcÖĎd}GœŔSňk˛}(Ú?đŔcÜEÇâ?ŔSá˜wvLŽ?đŔcőđ5pVŔSŃŽů×/?đŔdâœľgŔSÂÄÇžH?đŔd/˛ş¸°„ŔSł)éś(?đŔdZ[íđŠŔS˛´u.l??đŔdt65R{ ’?đ@_´őú9úËŔY´ƒwˇű?đ@_Ć“—nŔ rs•ř7?đ@_ĎJ,1t4Ŕ ť“Č7?đ@_ĹşýŔ +ů(Šj?đ@_ľŢ`'/ŔÁľŐő—?đ@_Ł<éÜ}×ŔŒĐ#|’ˇ?đ@_{—"7lŔ "RQ t?đ@_‚˜„Ü#lŔ ‡†ĎĂ(Ó@fečOXľ/@QˇúůňWŔf~¨oßţ@Q˝*QCä?đŔfbýŚ7%Ö@Qź]ÓqwI?đŔfFIŽ[Ü@QÁľ$¨H?đŔf3róđ^n@QΌńqľ?đŔfEé!'§"@QŢ=Pꡏ?đŔf`{ą’2@QäÚăNH‘?đŔf}pŁš@QâYtřó×@fk(j–O˜@Q×M˝ś?đ@fX~‚'Ď@QČŇt€?đ@fW{ËőćĎ@QšA3 O¸?đ@fečOXľ/@QˇúůňW@7ňÄ-Ű@CsyhuÇw?đ@7U?ŽŽřó@C^ŃčöÇ\?đ@7—[]‡@CBI"7š?đ@7çĹÂá&‡@C1}á›×ů?đ@8& —Ť7@CU7m?đ@8q›9E6ö@C.¸Ÿ•ß?đ@8b‹Sţ@CuúP݂?đ@85˛Ý @C5~€ëž?đ@8 …ĹÚ -@CS)k†Ăë?đ@7Žşů‹ß@C_źv,?đ@7j"ő]łč@Cv÷Ć^Ց?đ@7ňÄ-Ű@CsyhuÇwŔQ˙:˜t˛ž@D†1ĽĹ ?đŔRĺOE@Dƒ÷}ŢG?đŔR- KĘ@D~,|´7p?đŔRF#9xˇ!@Dz6°+“ĺ?đŔR\œzÖQ@Dv"ö¤jü?đŔRuĐ S/Î@DYV|>Œ#?đŔRe%†ô°@DPS§œîž?đŔRJ–"㼑@D\&4ş??đŔR0ô`éЇ@DdśŠěĄY?đŔR†|ç@Doő@O­ři,ŁU?đŔeViĂ9ą‰@O°ú :k?đŔeH0Äđ3ť@O Š’ÍôF?đŔe:˜—Lb>@OŠ:Űibí?đŔe0î3<\@O†cß ěŘŔBOÍCŔKoáŮŃ?đŔA÷Ëú?ŔK`žV;°?đŔB ÁöýՎŔK>8m9†?đŔB:ƒ§oŢŔK#/ţ˝'í?đŔBg×đʁŔKç° ™é?đŔBŁĺŞ^JŔŔK×t- .?đŔBčaź­WŔKWŮâ?@?đŔBŰĺ.čţŔK Çy‰j?đŔBވčçďéŔKJŢÖj?đŔBtăÎYŐHŔK/ ž•ÄÔ?đŔBC˛‹0’QŔKDŇß5?đŔB0Âz]xŔKdYĘëf­?đŔBOÍCŔKoáŮŃŔM˝PŒVHqŔJžą8‚¸?đŔM‘ô2ÄŔŔJ Ĺä ą?đŔMbć:ł!'ŔIú÷Łí~Ő?đŔM&Z8l,ŔIéî@őŽ ?đŔLňŻńO„ŔIŰŤ“/ž?đŔLö˝—§*ŔIÂĽôqO?đŔM÷Ăz°âŔI­¤EŠ?đŔM8błń¤ÝŔIˇKz~H?đŔMj$Ů7ŞŔIŠ´Ż›]?đŔM‡!3¤ŔI͔ú]ú?đŔM¨JňÔŚŔI㞢Pä”?đŔMĘƒ.U•ŔI˙’ŕ~Î?đŔM˝PŒVHqŔJžą8‚¸ŔX`Ojŕ@9ošęť Ź@ŔXj.NűKÔ@9J×)ň‹@ŔXl=0@8ţ&%´N\@ŔXlrłÔÔű@8˝všX\ń@ŔXqě‚@@8x…L WŔ@ŔXoő_@8&íXß´@ŔXnVቾÝ@8'“ÁśÝ@ŔXk‹ą”ţ@8qă b@ŔXg^˘oüš@8ş/có`–@ŔXb”T@9oÇ°Ň@ŔX\eyEx@9JE™ŃG@ŔX`Ojŕ@9ošęť Ź@S{db?Đ)@E[]– ń\@@SgężRYô@EWGA @@SO<đ\Ä@ESŚĽ pŁ@@S6´]…Łí@EKf<”Ęœ@@S&GśíÚ@E5ĺ6~˙#@@S-d’Y@E圁x@@SCâDL¨<@Eo9 Ĺ@@S]Ňyž@Em~d¤ż@@Ssřáí@E*Ź Ä/@@S‰ŐZ¤TÉ@EONTÝ~¸@@S{db?Đ)@E[]– ń\@^Á9Îzľ*Ŕžp5iŮÔ?đ@^ˇÔ$CĚĺŔPć0łŘ?đ@^ľJ9A_Ŕ{łMóô?đ@^ą¨ 2őfŔ—Ůô4֙?đ@^¨Ć—qĎşŔŚ÷ŰM3°?đ@^ŹçřXŹŔ˜›wyÜR?đ@^¸ÎŢUĺĎŔ˝aJFř?đ@^ĆN-QwŚŔ…ˆ¨?L?đ@^ÄôŽ—\xŔČÝzg¸”?đ@^žŤ?ţ"űŔ#úR W?đ@^Čb•€•Ŕ˙O ú?đ@^É1˝oSŔ$ ‰Š?đ@^Á9Îzľ*Ŕžp5iŮÔŔQę^n›uŔSĺ E?đŔQŹ´´Žb0ŔSćlp͚?đŔQrÚq’1—ŔSÖ_—ZŁ?đŔQHĄĆ ŔSĹ/ęJÖ ?đŔQýo=vŔSľ­Şhí?đŔPߥŚˆÝ‰ŔSŁšž[ŢŽ?đŔQđƒĂ|iŔSĄZü9Á?đŔQd–ĎÇŔSŹ^ÇřTĹ?đŔQŤgЃß;ŔS¸Ýö[^+?đŔQâR[x ŔSČ;;áb•?đŔQôĘ:xż3ŔSډT™âî?đŔQę^n›uŔSĺ E@(Řôěçe@L 6$ŻöÓ?đ@( _ží?@Kîʀ}g?đ@'NŞ.]Ů<@KíöÎńC^?đ@&;Ž]K @KŰÜň1Ah?đ@&I*Ů-@K¸ BĽ ?đ@&¨ŕű´Ť@KœŕŔÍí?đ@'¨ëçčO@Kˆ÷ÁU?đ@(T¤X!~@K–Ö¨ ;Ę?đ@(Ëţs¤@Kś#\?đ@(÷˘V‚Á@KÓ8ż9$“?đ@)ĘW„Ś@K÷ti˜ý?đ@(Řôěçe@L 6$ŻöÓŔQ*ýÓcŔKxŘă9řš?đŔQ6Ôo€JťŔK|lâ?đŔQZţ$kŰŔK†@łţzo?đŔQq>”ÝúŔK˜L{âÖ?đŔQYž~…—ŔKľiuď9â?đŔQV‘7ĚŔKĄ{Ă/ ?đŔQFZ™MhxŔKšóŠ˝Ä?đŔQ5ôz“Š$ŔKąěiE!t?đŔQq>w˙ŔKÇ$ú1Ţ?đŔQ1o„ŔK¨â'ÜŹ?đŔQ2ČeD8ŔKÓ'K?đŔQ!-#ÜŔKŠâŕÝÚ?đŔQ*ýÓcŔKxŘă9řš@bI¸!ň#i@RÝUžˆÎß?đ@bK?CşÖ@RËÎÜŐ?đ@bi˜Â&i|@Rż=kAäń?đ@b…ń_2î@R´†a¨Ńp?đ@bŠşň#+@R°äö-9U?đ@bĘüo9~ř@R¸Úm5ź?đ@bŃ­AŽoî@RČBŚ°p?đ@bŽ"Íťđ0@RĐTć0‚?đ@bÁ6ŢG@RÔJ#?đ@bm5o_Ë@RŮöbż?đ@bVYCC*@RÝ˝+ 9c?đ@bI¸!ň#i@RÝUžˆÎß@_Źąf†ˆ’@R!PDd2Ű?đ@_ŢÁ˝ěá@R-Š0?đ@` RŽPUĎ@R7’š ôš?đ@`Ÿ9jD”@RF†]7Ÿ?đ@`ŮVz=Í@RTE€Ö’ć?đ@_ĺ†5É.ď@R_2ŹSZę?đ@_ą™ľW˝@RZĺ]Ś?đ@_­R0”Ďť@RHPf:Ş?đ@_šSŻ}Ľ­@R6žx}6?đ@_–ÎăŔEŠ@R#Ůúov?đ@_žš@1@R8h[n7?đ@_Źąf†ˆ’@R!PDd2Ű@\ń*ż˝WŔ Zś>é?đ@\¨0usŔ žnp™ş?đ@\šüË+ŔMŔ ďő_ ‹?đ@\ʂ.ČDĘŔ!}[Ѝ?đ@\ŘÁ/gÄ&Ŕ!4)˜wDŕ?đ@\čľśvPŔ ŃEĺdĐĹ?đ@\Ţ2P7 ńŔ V˝ž!&N?đ@\ËŃř ]żŔ .<—Ł{?đ@\šô–<‚âŔ ]§ÚŸá8?đ@\§=ŠýH Ŕ A ÂQ1L?đ@\ń*ż˝WŔ Zś>é@TO!PGĆ@JóZëŞŃv@@TV ´úëO@Jý2›9Ž@@TnNO“ŕŐ@KíiŠ‡X@@T‡Ë2ŘzÜ@K0ƒĽU?@@T˘ ű8< @KEBĂâ{Ď@@TÄ(k͞Ĺ@K\Ś‘ĄŮ@@Tš˝9œ:o@Kf <ĹXd@@TRąYç?@KNöÉ´¤@@T…šřyDK@K4U=öŲ@@Tlá>2 @KŸF´qF@@TUÚ=ՙŢ@KQ•Äĺ@@TO!PGĆ@JóZëŞŃv@dU6Ŕ Ż˘\„Ż"ŔšóÎ Ë?đ@\I÷>ĚRŔÎŹf $?đ@\_{f×VßŔؚh/Ku?đ@\oŽÇÉüŔyýĆ˝a?đ@\~ţS\ÔOŔe¸ ĽF?đ@\}*ý5Ŕ‹eŞI?đ@\jz”^$*Ŕ‘Ů;ţŁ?đ@\XďĎŔ}9˝Şü?đ@\EO˒Ó}Ŕ‘ĽS?đ@\9ňT˙şşŔ—J&ˇ8âŔR3ÜöţĐ˝ŔGv…Ł@­g@ŔR aŠ ŔG\ÎaRÁĹ@ŔR /°ƒöŔGH,Ľë&Č@ŔQđů>€¨ˆŔGBŠź¨@ŔQŐCąBvĚŔGJPqCů"@ŔQÔXÔ2Ŕ ŔG9|6éőŐ@ŔQńSňvžŔG+k!O e@ŔRˆq˛ľŔG=Őç(b@ŔR#x˜ő ŔGHƒ{8<@ŔR,›5WŔGPĄĹň¨@ŔR68ľŘg—ŔGpL§ä–@ŔR3ÜöţĐ˝ŔGv…Ł@­gŔNm׼ŃÍYŔJčƅž?đŔNDţMąŰdŔJáJý˝?đŔNzřWŔIţńäŠ˙q?đŔMߍ{œŔIę&3Ůe?đŔMľcŸaEŔI˝˙ŐkYa?đŔMň,ŁmďŔIś#ó/>?đŔN6[IÔÚţŔI¸Ď'Ü?đŔN-.¸lIŢŔI×ę‘FD÷?đŔN8GîFŔIđtˆî§i?đŔNfŮÇęD7ŔJcŕžšt?đŔNm׼ŃÍYŔJčƅžŔWĆřéKj@Rćă2?đŔWôî7Ԓj@RŰŗp€ó?đŔX đ&Žţ:@RĎé ~?đŔXâżčŁ@R˝Ü`áŠ?đŔWŢS˙dýŘ@R˛E“.§?đŔW˘ą]—Z@RŠf™šŠ/?đŔWc‡­ö†œ@RŽ—=^ąă?đŔW_‹ę2š]@RÂ*‡4?đŔWkĺ—îŐE@RÓů˜C}Y?đŔW–#´Ě6@Ră§ubś?đŔWĆřéKj@Rćă2@``ďˆÝ çŔ'Ä˝F[P?đ@`gš˙7°Ŕ'{Ě=˜Š-?đ@`nĺ'FĚ2Ŕ'ţ6úŒ?đ@`k4ąsoŔ&†XóÉa/?đ@`dŠ*ËdŔ&¨% Éd`?đ@`Y†Č¨ŁËŔ&ź+ƒ(J?đ@`P˘źzb<Ŕ&•=֔śö?đ@`MŻ}ˇYrŔ&âü‡\;­?đ@`RJ\¤PŔ'aŇÉëJ ?đ@`ZDŃ>ÇŹŔ'ł§es¤?đ@``ďˆÝ çŔ'Ä˝F[P@KČ3Oŕ|@Lq3f‡1§@@K]ǔ2Z@LƒŻ§ý˝@@K;ňrĄl@Lœî*'@@KÄ|Čc<@LŹhwĺ/ű@@Kˇž;ďöƒ@LŐőĚń3@@K¨TCĹ@LÜ`oń ,@@KŽžÄŽTW@L˛ˇ]6Aő@@K}eäĆą@LĄžKűş@@KS-ĽÜ¸@L‹ˆ˛‹Ţ @@Kškú@LyŸđ܃Ř@@K ĚWe0;@LfsáŐěQ@@KČ3Oŕ|@Lq3f‡1§@@ĺqŸNăÓ@G‘?Z”†@@A ޞ1ę@Gwٕďć@@A<áĆ]ď@Fňţ6…Së@@A_÷’äô@Fä6=ŃÎ@@A˜lóE+G@FłhDü´E@@AŒÍ1ÇZ@Fɀ›ź7@@ApS+׼ć@FéĘî1Ť@@AM €Ą¤ƒ@G ĂžĄ+@@A@ĂčóŃ@G>đgôÚ@@@󐤴t}@GĽđ7ié@@@ĺqŸNăÓ@G‘?Z”†ŔNŠf 7zœ@%Ľ#tq‚e?đŔNŸątâS@%™?稑?đŔNĂ3{Lľľ@%bgzť/˜?đŔN˝Îôas@$Žm Zl?đŔNăj¤čO @$C!>žâ?đŔNŐ=ŹEU@$#VŢ@9ů?đŔNŻYčźľ4@$$XĎe9?đŔNˆőöŽ!˜@$CqrE'?đŔN?ŃE+@$ËGçÝÄŕ?đŔN~Ź-b´@%|T!uMD?đŔNŠf 7zœ@%Ľ#tq‚eŔ`ĺMő€š@LšXv=Ť=?đŔ`î‰ęX”^@L¸Žr?đŔ`í*‘e|@L™{H`őš?đŔ`čĘÄh–;@LuŚřŐ$ĺ?đŔ`á°yĹ@LUé=óĂź?đŔ`ŘţD}Á>@L&ş]wCÖ?đŔ`ÔBCţ`@L@xćvë?đŔ`ÔĽëäáÇ@LbkU˘?đŔ`Ř`!+;‹@L†ÁĚÓT?đŔ`Ţ­@:ĽżLWbd?đŔS_ƒ=ć),@:Ř—§$ś?đŔSrî|Ťâ@:ę/\'Pd?đŔSu ěZd@@:äż´´„ŔQLŠţôۜŔPĺÓƒ@B?đŔQ0ßlţűlŔPîʝM“?đŔQ s}ź_ŔPŕiö‹?đŔPútT0@ÜŔPĐiY(‰‹?đŔPöęyëŔPÁ !wT?đŔPîšŔđúŔPŽU(b?đŔPţ'ş!g“ŔPŞínŢ‹?đŔQĹßB9TŔPšźx\Â?đŔQ,ľœxířŔPĘą¨’?đŔQATŐJŔPÚüIhČu?đŔQLŠţôۜŔPĺÓƒ@B@aœ˙r|@Rp÷ë›ď?đ@a‹ź\ž“A@R`0ŕň1?đ@aƒó‰Čˆ@RZ/!?đ@aŞ}o3–n@RW&ƒD?đ@aȇE-ŽŐ@RQŻQ:f?đ@aéüuŸ˝+@RQž°ĚÓ?đ@aéȆˇő@Rd!U/Ŕľ?đ@aÓě$ţ<˙@RrŽMŃŤ?đ@aľ—Đ3\@Ry3 W÷ ?đ@aœ˙r|@Rp÷ë›ďŔ`}p“s˘á@J›úžúF?đŔ`Šö, ţk@J’$tÓ?đŔ`‰eZŐ@J~ZXŽˇl?đŔ`żÎšÚr@JbxçBf?đŔ`yœcÎ@JEéđĘ!K?đŔ`hüyź-a@Ją—`˝Ÿ?đŔ`kŠŹ#@J1\Ľ¸.?đŔ`u%Wi’`@JLžWÁ+?đŔ`y%„wp@Jm4§‰˜Á?đŔ`xŇ#ň?ć@Jˆ@ÓÉ?đŔ`}p“s˘á@J›úžúFŔTœe˙úzÖ@OyÎĆ^më?đŔTÜĐČáE@OqQë-Ź?đŔTŕŘŹ/Ćú@Od„A6Y?đŔTóś/[K@OB÷ć¸Úě?đŔTëMő§śQ@OˇĽťAq?đŔTÄfR˜mË@O ]l?đŔT¤Â&cM†@O3ĐC>ř§?đŔTŠ”ŕĘ ˘@ONĂÄR ?đŔT}ŤAŞ×ň@OppIĎÔk?đŔTœe˙úzÖ@OyÎĆ^mëŔZý„ĺÚ)x@GżňŠBĄ@ŔZčMj §@GÍgsŻ+ő@ŔZĚŁ\Ł‘ @GԛD,œ=@ŔZ´/v$q@GŘ7Ůk´[@ŔZ—‚äŞ<Ó@GŰi`Aäˆ@ŔZ˜ďł~ö@GólYv™ŕ@ŔZłďŠ}Ľ @Gä\Œ5@ŔZĘů/ÉÜu@Gف(XŔ@ŔZä˝J42R@GՊ9w­ě@ŔZúGeŸg@GÇ}íĐ €@ŔZý„ĺÚ)x@GżňŠBĄŔXuł”ű}@S­ÝZE6d?đŔXŒ"&A ‡@SZZ J€?đŔX]5ƒÝż@SŠR\ëó?đŔXJR~ Ą@Syˆf.G?đŔX×|TŽŻ@SwüŁjŃń?đŔWÇB- Ôú@S„n˙a?đŔWÇ 7ö—Q@S—g đD?đŔXŽœĹňj@S¤E`i• ?đŔXQBńZ‚#@S°š,b,?đŔXuł”ű}@S­ÝZE6dŔ%ů gą@ &RŻă3 @ŔťÁА@wE¤ö0@Ŕě>˘@ˆq ŃJ!@Ŕ‰Ź. č@PŮĹ=r@ŔďF(l@JĄj.Đ@Ŕ™őYň›@Šą]N—@Ŕ&Eĺ)Ů;@rd€?îĄ@Ŕ†gÖ|ĺ@˝kŞŠ@ŔRĺ× Ô@ď<Nx@Ŕ.Fąh™›@ŇF8Ba@Ŕ%ů gą@ &RŻă3 @a0{kü-^ŔB¤EÇčĆ?đ@a<›pĺcŔAíľúŕ^Ě?đ@a5Jœ–đaŔAÚhš¨x?đ@a-ŸťăLRŔAĚŢ}{:{?đ@a"3ŚŒ%ŔAÔ­eŒÔ?đ@aýyZôŔAŢ_› OÝ?đ@aĄSüŔAů6pň(?đ@a ßmŔBŒ^” ö?đ@a(”Řf•xŔB^Ç؊ź?đ@a0{kü-^ŔB¤EÇčĆ@7´e%‚Ë@SŠ{uĘň?đ@5[ţj{8@S‰ˆ$/@C>‹{ůś@@ECŽŤ(iŚ@C=Âa¤BÖ@@EqomZ:|@C6/´}ś@@E˜¤Đ1…?@C0łÚ“@@EšP §Ś@CP´${/@@Ež‹mr |@CqĘöĺw&@@EÁv—žI@CwAĽĎAÚ@@E… Żł@Cf˙P抙@@ET•Öڒĺ@Ccx{Jň@@E4ź#+“ą@CMôú9Ş@@E)—XŸ>/@C>‹{ůśŔ[—ŘAŘí@BóAŒÝ=Ů@Ŕ[‚ćöƒ@Bㆥ׭8@Ŕ[Ź“aD+!@BĂvߍ@Ŕ[śđ6ŮŻ@BĽ÷LG“˝@Ŕ[Ó¸ oÉI@B‰ VÇâ’@Ŕ[ČJ>Ľó9@B‡„ďÁč‰@Ŕ[ąH%Ţc@B›K(} @Ŕ[¨évL@Bžňŕă*I@Ŕ[›Nx*˜›@Bߒ•Ý%Ű@Ŕ[—ŘAŘí@BóAŒÝ=Ů@cŽ†.D‰eŔHÂEˆ?đ@c‘ŔŘúaqŔ@ˇ’•Öˇ?đ@c˜††ÝjŔ ¨mëG?đ@cžúę&zŔęk“NO?đ@cŤE΅ϏŔnea?đ@c¨Ny2Œ>Ŕŕkhřá“?đ@cŁî‘dlŔňůĽŠś?đ@c›§X‹`ŔDŔ’†Ă?đ@c“ź3 |ÉŔĽ;™Œšf?đ@cŽ†.D‰eŔHÂEˆ@XxIŠ„vÓ?đŸĐLůí?đ@Xjý›Žíp?óž?vÚ?đ@X\ń|>?÷pǭΡ0?đ@XL5zü÷?öÔ1´ŘôY?đ@XK‘íœż¨?őYŠ]h?đ@XVŸŔ•ŚÜ?ń5,Łzy?đ@XaĐ6§?ě<„Ś?đ@XoyDĐ?ăÍ<ÝTPAÖ Ŕ$ÂE cńV?đ@d.iݧA&Ŕ$yŞÍυŇ?đ@d)S“ľ¤ĚŔ$ƒ Y™“°Ŕds;Z'@K„ń™—?e?đŔd€  Ďn @K~RŸś{?đŔdŽ|őz”ý@Koƒ8Wţ˙?đŔd™ńRť{ƒ@KPĽŠ×Žč?đŔd—<ňö>@K6)ÂŘzŒ?đŔdˆő…)@KD~iĄ6?đŔdzô˜VU@KPB­krä?đŔdhŞ™uˆĺ@KXŽ-˘ŘM?đŔdkšP˝@KkÍÖUA?đŔds;Z'@K„ń™—?e@^Đ÷^/u@(ňËŇ9şA?đ@^Îu#“3@(2Ť–#?đ@^ÜIɊ@(O­ ‰4?đ@^ëíŞőSB@(˜*G?đ@^ý-`{XŞ@'Ľź˝cţ?đ@_Ë@Gć(@'礗ť?đ@^ö^ŔX@(_“.ÍĎí?đ@^čZ|$9Ž@(šŸâ(?Ş?đ@^×Űgƒľ@)ä߇’?đ@^Đ÷^/u@(ňËŇ9şAŔ[‚Ÿ”‘ĺk@S†ż"Ž”C?đŔ[ŔhÚ}8ô@S…1´ežž?đŔ\(;4"@S—aßý?đŔ\Lń’SÝ @SrĚî6•Ť?đŔ\:BÎ{qT@S_–ë…‰ę?đŔ[óśĚr+@SWK4BÄ?đŔ[ [č/ŒŐ@S^ÇLĽô?đŔ[šônüÎ@Sp´ŰňĄÚ?đŔ[|ŕ‘t<@S}Đŕ ôż?đŔ[‚Ÿ”‘ĺk@S†ż"Ž”C@Yěú5ű-@*uׅĂÍG@@YđGĐ̀ @*ŸCظ˛@@Yü›é_g@)ŽQV,@@Z äBéď@)^ČĐcí@@Z bTA,?@(ňÍŤťß›@@ZdÚä€@)4ÝÚŰđ@@Zů–˙!@)•9—Đ!Z@@ZË[‡g6@*—˜5ß@@Y÷đáÂüY@*qŘöf ;@@Yěú5ű-@*uׅĂÍG@d×}XFďůŔ-ˇ˜ýäW?đ@dŇ!B \ŻŔ-Œ9đ§R?đ@dÓĘivĽŔ.Hl_€ž?đ@dŐ$ećœ=Ŕ.ßH€”áö?đ@dۯ܆ŃIŔ/8‹°mŁŞ?đ@dĺl¸Š gŔ.üʊB9?đ@däoU$cIŔ.jĘ3ąîĚ?đ@dŢCă  ňŔ.ŠłŠvŒ?đ@dŘ nü`žŔ.YGŠ?đ@d×}XFďůŔ-ˇ˜ýäW@JŹMßí§`@)Ć>xŽ?đ@JŔ3jW@(Ď°(?ů?đ@Jă"č’Q@(Ą°ĽŽ?đ@K ;ŕ`fQ@(°´ú—0?đ@K4n˛G @(üßC)Őu?đ@K#Ž(Ţ~Á@)D˙ëŒŔ×?đ@KB‹čřĚ@)QúŰĚ^ą?đ@JÜ,—aˆ*@)Mę s?đ@J¸ţŒ%'Ü@)C’ą 7?đ@JŹMßí§`@)Ć>xŽŔc<ˆČnöw@MĺśĚ°6@ŔcEŕ„‰çÂ@Mäń%Ł@c@ŔcXJ=Úy<@Mß:żšNb@Ŕchádż[y@MŇQ…çÜA@ŔcyÂÍ´ŕî@MĹĎ ůÝ@ŔcuciâB@MŤ–šťźë@ŔcbŘi=÷ˆ@Mľ…#,Ľ?@ŔcSRaß7@MÂÍĚšjq@ŔcDuˆCŸT@MŮŁń<Ä@Ŕc<ˆČnöw@MĺśĚ°6Ŕ`ůÍ8¨?ł@Q?„Ů15?đŔ`柁O9 @Q;Âĺî„?đŔ`ĐX{ŽP@Q3}ń‡kV?đŔ`Ч5˛i@Q88ĺfÝÚ?đŔ`ÍíÉ6^@QHb´GŤ?đŔ`˝Šazě@Q\†ß 1¸?đŔ`ĚPMqŃ@QdŇ#]N?đŔ`ĺ†ř™“z@QXł,ŽŢ"?đŔ`ö‰ jěŹ@QMĺ6÷aä?đŔ`ůÍ8¨?ł@Q?„Ů15Ŕ\0ô]ŸK@DÖAĽô„˜@Ŕ\:zŘőßë@DÉ`‰ßĽý@Ŕ\7w;8Â@DĽ-pŃ&@Ŕ\*4$–Đ@D…Fěü܍@Ŕ\X=Wí@Deëy[@Ŕ\ !jŔt@DwsŐšl@Ŕ\ –ć@$@DŒ DţńŢ@Ŕ\n8śÇŘ@DŁĹ(ҜO@Ŕ\-—‡ONx@DÂk”&é@Ŕ\0ô]ŸK@DÖAĽô„˜@1 qëŞ4đ@LŹˇŰRů?đ@0ëQŠ#@L–ŰĹ?‘ ?đ@0´ ٗI@Ltçná`‡?đ@0x1_Ľ˝@LTL‚ Úe?đ@0iżôrp @L+č7WP?đ@0’FAwŸÓ@L1"%üŕů?đ@0´ĚĽžŕH@LT:NË)¤?đ@0ŕŮ=Mű@Lwáź(ąć?đ@1 \Ď@LšŁ>÷_?đ@1 qëŞ4đ@LŹˇŰRů@H 'ëúş”@Q=1Ł7• ?đ@HVŔvQ@Q0‚)‚’?đ@Hš!üńK@Q4éˇkş?đ@I 8¨ŸŠ @QCQpüŁ?đ@I–›OÜÓ@QOí‘"Ą?đ@HŔz’4N@Q\ ŮN”?đ@Ha1–$Š@Q]n]’ů°?đ@H&E/št@QN[Ý~ą!?đ@H 'ëúş”@Q=1Ł7• ŔZ$=Rr@Re\(•Ş?đŔZJúÀŠ@Rn—˘0ź?đŔZĂ]ş„@Rn@š0ߊ?đŔZłĺ+bޚ@R`üt”÷Ú?đŔZŠĚľéV@RQ0Äëł^?đŔZ]čœ&@R=˛;纘?đŔZ8Óĺ*Â@RG9I ŞŁ?đŔZ$Ágǝ4@RXě¤*E?đŔZ$=Rr@Re\(•Ş@]‰>‡Ŕ †55ëď??đ@]KôS¨Ŕ ă NÔśř?đ@\ţ:PНLŔ!‚F„Ĺůe?đ@]˝B‚*ÂŔ!Ŋö´?đ@]k8_ÜŔ!ƖRA€2?đ@]&S‚3ۇŔ!_ŻąLčt?đ@],‘”ôČ]Ŕ ÎWšŽC÷?đ@]Ď×?0ÁŔ y]Ťďˇ‡Ŕ †55ëď?ŔV†‘%…Ź@INóZšŠ@ŔV-ŻŔěV`@ILĚQSą@ŔV=5ŠďE˝@Hň޸B@ŔV?8ÝĘj:@HŐˇ_‚ř|@ŔV-ŕĘŘĄ3@HÄżGg>Č@ŔV䲥đ@Hšt=:ËŇ@ŔVüJw†@H̀Ű9=$@ŔV›ëčľě@Hör‘y•u@ŔVx154@IPg)_ę@ŔV†‘%…Ź@INóZšŠŔ\—‚őł @B?ČĎÄŕć@Ŕ\¨ęjä˝@Bş+uÓâ@Ŕ\˜GY>@B ŠŰź{@Ŕ\™oúą@B €FÎ$Ş@Ŕ\nŚ+ćk@A÷¸Z’x@Ŕ\n:YaV@Aúů]^Z@Ŕ\^˙ë~t@B>F "}@Ŕ\” FcĞ@Bˑé}Ě@Ŕ\•ŽZ7ţü@B5úˇw@Ŕ\—‚őł @B?ČĎÄŕćŔS [gçŞwŔQ˸]şÇą?đŔRÔ}'ŚÚŔQƲ„˘ań?đŔRž-ëOîçŔQŔâ!PŚ¨?đŔRoôÎ/ŔQľ“Ń/?đŔRŠWŚ?ŔQŞVŒć‰?đŔRˇĆů8YŔQ°Ľ°N­?đŔRđžőM™ŔQ¸EV,•J?đŔS´ěa BŔQÂ#\ë?đŔS [gçŞwŔQ˸]şÇąŔI֟bËǘżń F`ÄÍ?đŔIëú Ĺő>żő\ˇ+Í`Ë?đŔIĚ÷|śŻżő`Ű[—w?đŔI°‘I8űżń˘;Â?đŔIž9\šżě{.A¤˘~?đŔI¤™čŞĹ:żă!) ŞUŐ?đŔIÁŮ'zÍ=żä:çrçyV?đŔIÔŹj°ľĎżě@ümÓ˛?đŔI֟bËǘżń F`ÄÍ@XĐÉ!eöżúĺ + Ÿ"?đ@XÉů›vŔňż÷AŐŕ?đ@XÂD-ƒżó8ÎJÜX?đ@XˇŒhLnfżîüşô˘ŞË?đ@X¨śäš ÉżńyǸŔ 5 wîĐÝ?đ@[ž‰ŰwUŔý;6>?đ@[ü”aFkŔ'9S­$?đ@ZöOĚ{¸aŔzđíœ>Ë?đ@Zę‹ę“e`ŔąăĆżˆrŔY‡)a˙Ę+@OƒŽ9Ťth@ŔYyľSވˆ@Oq- ×R4@ŔYYľ­.w@ObY-żU@ŔY?ěŰ%‚0@OnřŻZ@ŔY@ĹnM~@O–bŒGŽá@ŔY,ÜŔŕŢL@Oł‚Zp?‚@ŔY@L›Ýđ@O˝gęâY@ŔYapÉ+ŽŤ@Oł{żďŐÜ@ŔY‚7÷,Ţ@O’ߙ"Ĺ@ŔY‡)a˙Ę+@OƒŽ9ŤthŔdË „P ‡@JüW†ů+?đŔdÓŢ${˙%@J÷\§ďáÇ?đŔdÝ°qDĆ@JáĎWÇ?đŔdă;/ů@JǓĎÓK?đŔdň’.ţâ@JŽäöÁž?đŔdíž8HIę@J¨ź´ÔŐ?đŔdŢ-]†>N@J¸§LčQ¸?đŔdŃ0őwĄa@JĐp(OĺĚ?đŔdˈëa1Â@Jퟃt€?đŔdË „P ‡@JüW†ů+@]‡OPmŚ§@@w‡˙4Č@@]” ×@@xŮËřŚ@@]¨ŽŢw}Ö@@ŽĆ+{Łľ@@]¨ŕaĎR@@şlč;č$@@]•†0ĂIV@@Ź$ö @@]˜şžîCn@@ŒŽpsh+@@]Ž€#RżX@@ŽÖn¤ßÍ@@]č)ôÂŃ@@´äánč@@]yî´&tö@@Ž‡N7ŻŮ@@]‰ŰœŤ’-@@Ś~1ä@@]‡OPmŚ§@@w‡˙4Č@Y_ŕ˘đŮ@IšGńŰ(@@YZłćÁv@I˘\bcť†@@Y€ŻÝó@IzŘZ”JP@@Y ŽgńąÎ@IL‚ž‹$F@@Y>uŮ@IPœ˜7~@@Y&ËNż~Ć@IsŘť;Ků@@Y/‚s295@I—˜2U'ß@@Y( âf¨Ď@IŔʇ„٤@@Y_ŕ˘đŮ@IšGńŰ(ŔQœŻÜ1Ú@P'ÝĺN,ô@ŔQŸĐ3s4@P2üâ@ŔQľ|ô\Ś*@PDŸ,n@ŔQŕü¸<ĺ@PSÔx˜ţ@ŔQçM§Á@PIłÔŹÓA@ŔQňźˆ`jđ@P8p”N­y@ŔQéPďqš@P)wŁŮ+Î@ŔQĹ}ߞÝ÷@P-“;¨›@ŔQŠw ł4@P* .œ~@ŔQœŻÜ1Ú@P'ÝĺN,ô@`Z ؐńżƒŽœ—¤ę\?đ@`UsĐż\Dż§wň´˛R?đ@`KOdčŐ0żĂŽ‘żr˝4?đ@`Om9]zżÔˆî_‰pt?đ@`W´Ě6öżŃz p"R?đ@`]5X^űŠżÓP¨î?đ@`fޏlWżŐÁß<×™?đ@`gnDĎmżĂPä |Ů?đ@`_4ĚliżĽƒ6kśjž?đ@`Z ؐńżƒŽœ—¤ę\ŔX֝!†Ě@EüE;vÄ­@ŔXٜţXŘJ@Eĺ~_ä^@ŔXŐ˙9Żˆ@EƘeF•@ŔXŇć&%ö@EŞŢŇfşż@ŔXŻó`/@EĂ\ݝ@ŔXą`˛[~@E”śňúJ@ŔXĀnăÚž@EŹólššĄ@ŔXÔx!AYŸ@EČđŽeą@ŔX׍5~@Eç”#áĺ @ŔX֝!†Ě@EüE;vÄ­@`ĎĺŁ×ŒřŔéŠ6ŽW?đ@`ĘĺtYFćŔżóîŠQűő?đŔdŢ[1ž@Mű‘şŔkĐ?đŔdÉHŚGV˜@M錫?đŔdş—‚f@MńďLۉř?đŔd´ÎyjžX@N$ƒ?đŔdťĘlŒ@N(Á˙Ë+k?đŔdĹ SÉFÜ@N2ăs­dŔRŤ°cčŔJcZTl+u?đŔRŸĐăHĹŔJ|ş‡ËŻŃ?đŔR†<ŘďÇŔJŠč`?đŔRj vX‹űŔJšo_ •?đŔRTĂ3O|ŔJŤWˇŞú‰?đŔR%KńleŔKLpnşO?đŔRQüšźhŔJó>K˝?đŔR úúAßOŔJă "ů*BŔS‹ň½Ęß@9_S‡Kĺ?đŔSƒ˝ý‡Ť@8ă'”ƒA??đŔS“ ;§P@8 ěK YŰ?đŔS‡ëÄ'@8dŽ[H÷c?đŔSv˙ o L@8eWć„D!?đŔSoĽ§–ÜM@8 TËU÷A?đŔSy#Ě`ŻŸ@8⼣Œ˝?đŔS‚ţ†k@9"՝•?đŔS‹ň½Ęß@9_S‡Kĺ@`™V3 ć@F˜őůD@@`’Ôx7á4@F¤ýјϓ@@`†š3şË@F¨e€Ž@@`÷m‹<@FŒţ?ąß¸@@`‚Ą@/ö@Fh™ľ'U@@`‰öqD\¤@FMXü‘›É@@`”AŞb…č@Fbѕ˜Ěr@@`™Ć9GŔ@F…mÓű,@@`™V3 ć@F˜őůD@_Ę%çQ-ň@RÁqť?đ@_ýŻĎŚ†v@Rm^ó?đ@`tB9@Rľ[‚\?đ@`,šŽ1@R đђbÍ?đ@`"Ńůăuć@R‹p֏?đ@`Žůłˇ@R$:“éße?đ@_ԇš>§@R%úěCÓF?đ@_ŽˇuZđ@RçHë?đ@_Ę%çQ-ň@RÁqť@GýX)‰…@T/-BHô?đ@Hcx‘6yü@T Ŕě|7?đ@HĐ„EâQ@TMliaˆ?đ@I™…^}^@T'o)‡W??đ@IéÂBŢ\@T3hśÎˇ?đ@H†­ˆv˘2@T$źéńčm?đ@GÝwM–Ŕ@TŁ]4ň?đ@Gą&ç„W@T ™(b†•?đ@GýX)‰…@T/-BHô@M†ZnĆë‹@QyhϜŹ?đ@MÄa{á•@Qr˙yÎxé?đ@N]V ž¸@QmźĽU‚?đ@N.Î[L7X@Q|/-qn?đ@Mă{üS@Q‰Ĺ§áÚ%?đ@M–Ăĺ1@Q™2Qß­?đ@MN=šş™Ÿ@Q‘ˆ˜Ź\˛?đ@MY3Ő(~Ť@Q…CŞbŻ?đ@M†ZnĆë‹@QyhϜŹ@`í덁ÇâżçIߍl?đ@`őę˘ŢyRżë€ľŤří?đ@`ú㳜ÿńkGO°@Ţ?đ@a .eUżňm‚Ě÷˜?đ@a$ůíňŞáűŒ?đ@`űÖnĹŔ~żçő:*̝?đ@`óR•Ýą!żćŐ.Şô?đ@`í덁ÇâżçIߍl@-ۍZŠô@Mk‹Ű`@@-SŃÂ\h™@MWŃ Ę”@@,ÔčÓÚ &@M7Pğj@@,qÜt`@LţŽ–1—#@@-:ހq@MŔœä›)@@-”)Á˘@M7:šŻÁŁ@@-×°FY@MV díI@@-ۍZŠô@Mk‹Ű`ŔS,W“É@9sqg˙?đŔS:óF}@9NúgBm?đŔS ۇsŤ@9Đ´MsE?đŔSĺÇáč@8Ěű@}N?đŔS ďîé@@8Ęq"Q?đŔS 4ÓˇÉp@9ĂňvG?đŔS´­Ňä|@9O…Qř?đŔS(ŠFž$C@9yîÁKˇç?đŔS,W“É@9sqg˙@2Ő%Ý%ŽĹ@Lńˆ Q„]?đ@2|'s@L姍ÂX?đ@2+óA9@LÄ qu?đ@2?‹4E…@L‹‰×J?đ@2ĄT2KV@L÷Б ?đ@2ŇÖ!O/™@LźYö‘1œ?đ@2ď|ńöŁw@Lâu"ĺŃś?đ@2Ő%Ý%ŽĹ@Lńˆ Q„]@_wcŽms9ŔŁFüß?đ@_‰rˆýŔœçiżGO?đ@_œU`ĺ 8Ŕ¨ ýůe?đ@_Ž†í9gÂŔĎZŰ?đ@_ŞĄ˙ *­Ŕ|Đ\ödH?đ@_™PçüôWŔšfˇ{R ?đ@_†čÔo\lŔÉĽx.%e?đ@_wcŽms9ŔŁFüß@c#(;Š1QŔ9Ť¸9ZŻ–?đ@c&T0ąäYŔ9c,‰b?đ@c*\N-ÍŚŔ9]Đ÷2‰?đ@c)_őŽm@Ŕ8Ö#n „ű?đ@c&sůą[&Ŕ8×].÷Ń6?đ@c#ˇÓ”łšŔ9"Âkl ?đ@c! #„7|Ŕ9_öœýŹ?đ@c}i­ŔŔ9§Ěl†?đ@c#(;Š1QŔ9Ť¸9ZŻ–@ 0 ‡đ_D@CúĄšĽ›?đ@i—ň蝂@Có˘’|h ?đ@-áă"‡@CĎtś“uä?đ@\¤ŕ@CˇRq7ľ?đ@ 5ř$1Ů@C­Ł_‹Ş?đ@ F2VL˙@CĐÁ1Te?đ@ Š¨žžŠi@Cëtě›(?đ@ 0 ‡đ_D@CúĄšĽ›@__$ž@$FŔËś?đ@_ťŮq@$Xrx Y?đ@^÷ŠîWqł@#şE?đ@^ű)ůÄ(@#KĽ Ńu?đ@_Gsžľ‡@#5ýŽď¤?đ@_ ŐOtâ@#yˆœ/úp?đ@_#ˇsí/@#ö˜<Ďš'?đ@__$ž@$FŔËśŔ7IxNŘ%@R5ƒNÝą•?đŔ8>í˅@R6ŕČ'îî?đŔ8U•œ1ě@R)ŕţ ?đŔ7ÔÓ}Ç Đ@Rî–Ú?đŔ6ˆ„S0t@RORœ­ë?đŔ6R=J Ą[@RąmŽĐK?đŔ6Ϛ5dşC@R, ŰqR?đŔ7IxNŘ%@R5ƒNÝą•@EiŤybm@LŻg{pČ@@EÚ5,č@L;AB@@E”>zx#4@LjĐ(k@@EŁĄ&tX˜@L_Mąěú@@Eš ťrđa@LŠŒůeŚi@@EŚ/Ճ}Ŕ@Lą¸L­ţÚ@@EŹők|m@LĆoč0"f@@ElQśârZ@L¸ęőd›~@@EiŤybm@LŻg{pČŔRšye¤2ÎŔR:ĄÍŚzx?đŔRՎľň0IŔR9™Ś85r?đŔRö†ć.ŔRI[pť?đŔRęŠJ<ŔRZ2 P‚?đŔR­łî î­ŔReđ“{™€?đŔR›L莤-ŔRY]T?đŔR‘ŠŢęVŠŔRGČo7Ô?đŔRšye¤2ÎŔR:ĄÍŚzxŔSąsĚ[NnŔRGžV=°?đŔSyĂä¨&ŔR;܍ â?đŔSaj~;$ŔR-%ŮŃo?đŔSy çQŔR!Ď^ZM ?đŔSÁvŕ\ŔRƓTí¤?đŔSżťž GŔR+aࡋO?đŔSÎGI'ŔR=VÓđ°ą?đŔSąsĚ[NnŔRGžV=°ŔSň¸šŞŸ]@O1ťČLl?đŔT C@OźĎî‰Ű?đŔTc]>çľ@Nô^ž;ú˝?đŔSüÇRáwű@NÔĺ}„?đŔSĺ['ă[‹@Nŕ€:I°@;1›ƒ‚h?đŔXYY~mچ@;Pög}¨?đŔXVĺ ĹwU@:˝Z(ó@K?đŔXN6~Q5@:M;ъ f?đŔXPÚ 2@:y‹¨ő˘?đŔXUľI°@;1›ƒ‚h@^Š’_@ŨŔ‰ÉѨš ?đ@^˙*-§Ŕő°[ľŐ“?đ@^—Ť‚8¸ŸŔá?ÜőFť?đ@^“”ŘiÔ:Ŕ¸6! Ă?đ@^ë gmŤŔsŃZgĎ?đ@^¨¨I<‹ŔcżU?đ@^­5í˜ńöŔ mâĽŃ?đ@^ŻŚ’Ťv Ŕc%‡dž?đ@^Š’_@ŨŔ‰ÉѨš Ŕ8Đ_wĘâ@RZĂâVŰŹ?đŔ9}fŠ)á@RO[ŸMß?đŔ8Ü%-ÂŘc@RDý¸_?đŔ7wýŽ$œL@RFÂúu‰>?đŔ8m¸ôR^Œ@RQTÔŠ?đŔ7šj9E†@RP1|QăÝ?đŔ7óGڛ{“@RWz̞6â?đŔ8Đ_wĘâ@RZĂâVŰŹ@W7YyŽ°@IU+É ě@@W'lÎgE@IF§bĹç@@WlsĽ[ @I/ˇŃ&ÉŹ@@W1Š=@ˆ@I -sńm@@W63{}yŔ@IĆĹăB@@WN[źn_Ż@I%Q?TŤš@@W?ś ?—×@IG ‚Ż†*@@W7YyŽ°@IU+É ě@@Z ëhĽR?őŮÝz”ö@@@q”‡ůů?öÂ%O'Ă@@@šž˙'‹?ô°‰!,ôS@@@eŁ˙r?öŰ÷×zę%@@@ŽŒťŹeP?úg˛—ąY@@@™ÜHĹ?úX+łÓŕ‰@@@tÔ*7Ío?ř÷ëboř@@@QIˆ+?řľĂT\@@@Z ëhĽR?őŮÝz”ö@bBšÎc€@F:á„lŠ?đ@b=–˙ ět@F"ń˘É?đ@b2?ö˙/@E팠zRű?đ@b9ÔůŤ•c@EýÎ żf8?đ@bBfö´Űű@F‘z€ęŹ?đ@bMŐJ¨:B@F-!gj^?đ@bKFpF˜˝@F9ă`?đ@bBšÎc€@F:á„lŠŔSŮĹH͖I@L1ď$ %ľ?đŔSĺ–ű@L!™ű ˝Ť?đŔSď˅>ň¨@Kű*“Ąšˇ?đŔSҡöKČa@L]Ŕ˙9š?đŔSÄ;ŽC’9@Lm—DX?đŔSȏŽŢU @Lu\ßD?đŔSï눡ž@L´aŠQ’?đŔSžł9”@L1 OH‚?đŔSŮĹH͖I@L1ď$ %ľ@A)­ýΓ\@Oë$Ć'˛Ž@@A+‘´ďę@OŇ}îgý@@ATžž @Oľ›)Ń@@ApP^üg@O…ĚĺűoJ@@Ay !jmM@O‘xă6ž@@AŒ"° đ@O´§.ëH@@A‡žEp@OĂů×Á,6@@ATŔ&Q×ý@O◻0ť‰@@A)­ýΓ\@Oë$Ć'˛Ž@drŞ€Wő&@MI@ěŽ?đ@dƒgg Aˆ@Md2@×)?đ@d“_”.Ý;@MxHóĚ)?đ@d’éŞŇ@M”(‡×?đ@dz=yą÷@M~2ľ\a?đ@dt5­ĆcG@MYÓIÄ9q?đ@dm¨­ń"Ý@MI8ŢŐY?đ@drŞ€Wő&@MI@ěŽŔdüžÖĚîj@JĂdŐxšd?đŔejD .I@JŔŰŘ˝N7?đŔeśR-ń@JŁ˝Đűźi?đŔe+]_Ď@Jz;řL1T?đŔeTěŠ@J} )‹Ţ.?đŔe ěŇfA@J˜^-qÎ,?đŔdý~Ÿő]¨@J°Yf?đŔdüžÖĚîj@JĂdŐxšd@ĄĐýŠy@JgŔТŝ@@n„“ş•@JJEęźű@@¤TÖ}Jč@J*\Ĺ íë@@ŽľQ^Ż@J, €™Ű#@@!ńŢŘÚ@JIږÍĆ@@0Ɍf|@Jjüx,ú@@˜űJgB3@J‚ŰŤý­ž@@ĄĐýŠy@JgŔТŝ@]iČŤ¨z@HŠoĚ4¸@@]ZT°é0"@H“Ž¨MŮ@@]Fó)šň€@HwWśţ˜@@]EssYcý@HVö”ÎO@@]Q€ß”Óó@HQݔÝÔ?@@]bĐ<ăűÁ@HmRôÝ@@]vş0C™y@H„úŔţg@@]s~żŠÄ´@H“÷=ô2Q@@]iČŤ¨z@HŠoĚ4¸@6؄@MMAłc?đ@6ci\?D@MHwă u?đ@5ő]aôŸ{@M3FňâqO?đ@6„,¨FÁ@MŇĚš2ŕ?đ@6@ö#ź@M Ł—ĽŘL?đ@6Ś1Ÿ[Ë@MXóŽŚô?đ@7#bRV@Ű@M9̲pŞ+?đ@6؄@MMAłc@BŹĚˇ˜@'=ůaSŠ7@@Bš)Űk 9@'‚Ĺ'ˆíŤ@@BÇî2â&ž@(Á2u ă@@BśĚčÂ%@(†¨DPk @@B]Đǡ˙@(m–w˝h™@@BƒýľMĄ@'ךš‹ťS@@BĄJ“Ó"5@'Đhčiü@@BŹĚˇ˜@'=ůaSŠ7@döˆÔ6ŔSk (‚ß?đ@e˛qÚňĺŔSg=ýĘÁ?đ@edq KžŔSZ}o$Ύ?đ@dňCnň„}ŔSWÂŚ}R?đ@dӅ‘řmPŔSRMŚ*›5?đ@dŃŃ]Ć3ÖŔShî7¸ Š?đ@dÚľëSš•ŔSs¸îŹŢ}?đ@döˆÔ6ŔSk (‚ßŔR< ćĹý ŔIQ v:áŽ@ŔR9˙íH}ŔI6ůwö–?@ŔRlq˝ŔI=Ă&@ŔR&΢şŔIä™7żß@ŔRIO:-ŔI öjŰݏ@ŔRHńÉ5Ľ°ŔIáéű|m@ŔR?őEłő'ŔIAŒžíĄ@ŔR< ćĹý ŔIQ v:áŽŔ[ąŚôͅ@SŽőąŽA?đŔ[ě¤&,Ď@SĽĎ œť?đŔ\Arë&`@S™{Dˇ?đŔ\´‘›3@S”˜r'ŃÁ?đŔ[ż¸ :'@S”ě^¤C?đŔ[aŹÝm@S˜>;O^–?đŔ[xŽ˜ ľ@SŠ›Ż€ł„?đŔ[ąŚôͅ@SŽőąŽAŔS˝¨žSď†@:Ź@ՈÎ?đŔSą°0=`Ő@:‰`:€™}?đŔSčĽçW@:”:z Ł?đŔS‚Qţ*ö@:Ź]Bł?đŔS‹‘Î0@:ś:ß˝P?đŔS˘Ô6íş}@:¸íÜ$Ť¸?đŔSłřŸÍp@:Ÿ R—?đŔS˝¨žSď†@:Ź@ՈÎ@L$T@;¨@:öáܖ§j?đ@L ťýoš­@:úFmkĆ?đ@Kĺd˛„9d@:ŕŘœ/u?đ@Kľď+˙@:ĽĚN#b?đ@KĘÔÔö’@:Ł¸ĄĂ?đ@Kň‹|„M+@:ś´Č„Ď?đ@LrŚ"’@:Ýś.$D?đ@L$T@;¨@:öáܖ§jŔ`§P”_N‚@N8Ł<.˙ź@Ŕ`˘"yIŇo@N'}ÉÝH˛@Ŕ`•?ŞDˆe@N )ME@Ŕ`‡Ęc‰"Ő@Mßɂ†W#@Ŕ`ˆű›†@Mń œI¸@Ŕ`“$ÓJ@N“0lü @Ŕ` Ąš§š@N(Ńgç›Ů@Ŕ`§P”_N‚@N8Ł<.˙ź@X#ŢhřH@26˘˝?đ@XŒ0ËÇŰ@Đ?đ@XĐGj}@zśó?đ@X#ŢhřH@26˘˝ŔTQB6ţ-t@JšńdňI?đŔTm”ƒs­ť@J˜cŁfŃq?đŔTz”?üF@J€W™F({?đŔT[U&Cd@Jn6żďż_?đŔT5ę§ŮĄ@Jcę@Hú??đŔT<ÚQJA@Jˆü‹IíO?đŔTQB6ţ-t@JšńdňIŔVGą‰ľL@B~WŃ;@ŔV zn9M@BgkK™Â@ŔVĆn3ŒŠ@BC5R*Ą^@ŔVŚvRš@B%.V‚ĺ@ŔUüŃ3ŒZš@B$!ő‚@ŔVůá"+I@BHçQ*E@ŔVf@áN@Bk`ˆ2ý@ŔVGą‰ľL@B~WŃ;Ŕ( ˆŠĺÔ@/ĐX˙@Ŕ@M˝Ź@/Î(#8ƒU@ŔŹ]` @/z¤Ŕ˝Qb@ŔŸ¨Cp§@.üÜŕLn@ŔŹVďDn@.ŞŠĽdB>@Ŕ‚9А@/ŮÉSu—@Ŕ'IŽƒ„Ř@/Çđ†ť^˜@Ŕ( ˆŠĺÔ@/ĐX˙@_XŸƒ2vŃżý…“Ě?đ@_d›Š‚r§żţŢn¸ÖŹŰ?đ@_wqýÚ`üżţŻŒ ŢaÇ?đ@_p@áiEżýÔ_‚ž€¨?đ@_ˆ`Mň ˙żüáĐIˇŸ?đ@_uŁ|ÉEżüĘ]Q›š?đ@_bÍOúŐ żüáǝ˘?đ@_XŸƒ2vŃżý…“Ě@.!ĚŁé!@QM4öŕť?đ@/)˘óˇv3@QKŠ=Ž?đ@0'ă,ľA@Qš™F?đ@0guëoŕ@Q1´ľăß?đ@/ýă顲Â@Q*q…ŁZA?đ@/™Xżg‘@Q3 řŔ%Y?đ@.řďůžO@Q*4-:^?đ@.`Ć7ż@Q:Ëbsj?đ@.!ĚŁé!@QM4öŕť@`Ă.ü^!°ŔžđčPX§?đ@`ÄnxîŘdŔŠ6<¨R?đ@`8“Ŕ›<Ó ›?đ@bĘçołß@Gö”Ť}Ö?đ@bźžżœ{×@Fú­ĘĽĘ?đ@bł=4ęÁ@FáÓMĚ?đ@bŻ}Učś@FÎëg%T'?đ@błőݎئ@FĐń†wŢ@blű=EŔ ż? Ł?đ@bgŹ ľjŔ­ľß?đ@b^Ń5Z‹8ż˙c‚žBOč?đ@bSσV|•Ŕ š@UŠ“?đ@bX<řÇáŔLˇěk5‘?đ@bbGôá—Ŕ{źP?đ@bk €S2ĺŔˆý_­Ó?đ@blű=EŔ ż? Ł@díý~Ĺ)öŔ0„ăa0AÂ?đ@dóÜ÷PńŔ0‰đ´r1ň?đ@dřœ›BRžŔ0fOţÝ6?đ@dđťw,c†Ŕ0,¸ÝVvó?đ@dęQSŻŔ/ęŻÚЋW?đ@dćýa’ŇŔ0V:'*Ł?đ@děXű|čŽŔ0OÇ:c= ?đ@díý~Ĺ)öŔ0„ăa0AÂ@`ŚˆóÄ@:Ôę ó?đ@`O坪‰@:Ż6´f?đ@_÷ĺäŁÇR@:‰jü˘LŸ?đ@_í+iě@:5?ifŢ?đ@_ő‡Ěwéd@:LŢ}ű~Ň?đ@`÷ů(8-@:‚JĐEá‘?đ@`śN^:Ň@:ś!]b?đ@`ŚˆóÄ@:Ôę óŔR;ŕ"#żÎŔHqDS†ĺń@ŔRAł~ŸĺŔH…•*şŮZ@ŔR%T$ŔHsDĺo Ň@ŔR%ˆĄZcŞŔHHŻî¨@ŔR(ž„ĎnŔHZ{8eÉ@ŔR6Ě'ÉGŔHAť:a‹×@ŔR;UóČŘŔHT~4ÇF–@ŔRBźu‹€ĘŔHhą’ł@ŔR;ŕ"#żÎŔHqDS†ĺń@Gân–ö‚@JFy,š@@H C(hw@Jý[łpÚ@@H]ď˝Ďw@J7Ä@dÇ#@@H9<†ŹŽI@J\žNŞ˝#@@H+ö—P‹Š@J['n@@HţبŔ@J: `w@@Gö#˘•Ŕ´@Jt™ęCR@@Gân–ö‚@JFy,š@cmť"pĚ\@I Ż˘´áĘ?đ@cz˝ft@I-yÜČ?đ@c‚Üó“6]@I@/ZP;?đ@c~QOý1@ITüăˆő?đ@crp˛.4É@I1źb‚‚@?đ@cg业Z @IŹëúÎt?đ@cmť"pĚ\@I Ż˘´áĘ@$ôW5Í>œ@KÄĐłn?đ@#ŞžaMLJ@Kź•Ő R?đ@$~Ą  :@K˜ňȟă?đ@$§ą^Mô‹@K‡ýDS?đ@%ƒóĺí˘@K–,ó"?đ@%pk‚B@K¸ĺ{["ď?đ@$ôW5Í>œ@KÄĐłnŔ`iŐ 2Ö@KůŞlYâ?đŔ`rNůqä?@Kć"ŸŕëZ?đŔ`vŔČ'œ5@KĆA6vŞî?đŔ`njÜ@K¸œąbűZ?đŔ`k<\ôđž@K°ŔٲâŸ?đŔ`erˇÉF@K§%ő§s?đŔ`^žŞ˝@KČ8[ĚLÚ?đŔ`cÖqd@Kꑞ;;|?đŔ`iŐ 2Ö@KůŞlYâŔ`Ć ćÔís@Lr‰Bł?đŔ`Éú…â@L\ˇ7€H?đŔ`Ä´´8şé@L:Űfžl?đŔ`Ä\ÇĹΓ@L×o)é?đŔ`˝\vOM@L#ŢŰ\?đŔ`şœ@ÔÚ@LE%ČNO?đŔ`źÄË(Âć@L`.—řÇ?đŔ`Ć ćÔís@Lr‰Bł@^Ţ^ź*9Œżô+pTsŇ7?đ@^Ϟy­ęŻżôJË*a9ƒ?đ@^ž(˘^ĺżó ďeĺ%?đ@^ˇoŞŠĹAż÷ˆ1Őg#?đ@^Ęłčűż÷žůEĹÚă?đ@^Ü2ßăĚZż÷*@Çes?đ@^Ţ^ź*9Œżô+pTsŇ7ŔPɋ#•“ŔK€öÂťľ~?đŔPä%hXi˝ŔKv‰bh"U?đŔQ ["$CŔKvŠđáqˇ?đŔQԅ×ěĎŔKÄX:˜|?đŔPěÇű[ŔKœ˝Âžď?đŔPĚuŠąŐŔKžyKpß?đŔPɋ#•“ŔK€öÂťľ~ŔX,ćv• @Kxrœtq @ŔX>‰ďEWŐ@Kt?=ŒÓ@ŔX\iN˛ @Kdů/vĂ@ŔXz\@šŰ@KUdĘ5˝@ŔXsŰ(ú5@KNΐf@ŔXX(~ľÁ@K\ʐęŽ@ŔX>Ú4áß@KnNý—] @ŔX,ćv• @Kxrœtq @cŽ-'Ŕů´`Ă{_?đ@c¨ő%ŒÜÜŔ mzź|J'?đ@c°“ć7 YŔ Śź=&úź?đ@cšCçÂóŔ!Š6ŰÔ?đ@c¸u‚Ů"jŔ ‘žr†?đ@cłě5fŮŔ +GŽ$Č?đ@cŽ-'Ŕů´`Ă{_Ŕ0b7ţąß´@<ŕ9÷2?đŔ0­ mۏy@óQD‰ƒ9@@^/C6‚˝@?K ,Ă@@^đÓGל@?!:7Ž4@@^ář ˝Ÿ@?nBC\p@@]˙ł)U@?eýŢ Z@@]ű™Éîä_@?%'UTNŔ,Rq'ŃüR@<^śtŁČ"?đŔ,°pŃőya@<#öԓls?đŔ,˛=k‘˙÷@<–gbă?đŔ, i?ZŠ|@<9ʁ\?đŔ+łÖB)@Ź&‰Ô~?đŔ7ʆgłŐK@R9$Z…O?đŔ6ՔĽ˝˜k@R2d˙Ţ?đŔ6˙ŒHc@R0s86?đŔ6&[9]ťË@R<ô$şJ@` Ł'¸Ą@ŸWŰmW?đ@`) lU@°4%ź?đ@`ąš7Ă@ŠăŒ=#?đ@`†aŠ@ŠˇM`‚Č?đ@` ľď§@MŸB¨MŮ?đ@`ž¸Uľk@Hč5áœj?đ@` Ł'¸Ą@ŸWŰmWŔW^‡…RŔú@SpOľ@ą?đŔWœžZ”cY@Spę™$+H?đŔWň…,9÷°@SnŰs\ď?đŔWőéS{(˝@S_ń[ĂF“?đŔW™C\'@S]ŁĽM§’?đŔWZŽ‹$ßž@Scś7r?đŔW^‡…RŔú@SpOľ@ą@KĚŠ{ęrÂŔ4çX\…=ę?đ@K§˝dyŔ4ńب+‚š?đ@K§Á‡9SłŔ526) +y?đ@KÇş‘ŢűąŔ5Y•DťYí?đ@Kčšl;\Ŕ5ĘT@Q?ÚĆg&Q@@;rd˙Ľ9@Q9qçăŔPH'P~­ŔP-}[`†?đŔOëÄă´îzŔP2 l a?đŔOž9WŔP'Ä?§8?đŔO—P—ˇŕŔPsÔ_R?đŔOĐńyëŐĐŔPé‚*ą?đŔP Ú~NĽŔP$]>šôH?đŔPH'P~­ŔP-}[`†@`Jšëúœżúĺ&žĂ ?đ@`Eš^ďŸgżű ŮAŽ?đ@`:ôÇ}>Ţżýľ)vó[Ľ?đ@`@–íšŔ/î‰?đ@`JYƒ<Ŕ•(ü­ä?đ@`L\M؝nżý_éä–@?đ@`Jšëúœżúĺ&žĂ ŔTĹTXé6<@5є31äŔ?đŔTĂşl#j[@5›ßmvf~?đŔTž€Đś@5uŕ}ú?đŔTŠ/ôŹťę@5Šńżßʝ?đŔTŞsLeFJ@5ÍV…)§b?đŔTźŠ3™<´@5ęcú/œ?đŔTĹTXé6<@5є31äŔ@!š¤ ‘{@ ˙ťqwGp?đ@!\Bâfâ@ †”(Vď?đ@!°ö–y @ €Ńˆ”‰&?đ@! ƒďuÜ@ ĺz L¸?đ@!ůÎĺb\@ Äư?đ@!ÖŻ˘˘[˙@ émˇˇi?đ@!š¤ ‘{@ ˙ťqwGpŔeǃ×I@J2„Źgú?đŔeĚ{ŹŒwŇ@J>ÂK_ç?đŔeߔść@J&ac#L?đŔe×çKÁ˛€@J¤XBˆÚ?đŔeËHăĎÂ@J TAM?đŔeÂⅢ)O@J#^⎐?đŔeǃ×I@J2„ŹgúŔRŇ6ř•_@7‘JC°Ľ?đŔRČvü@7GUTłŰř?đŔRĹ7† i@7~9m;?đŔRš™Pv‰M@6˙„Oăm ?đŔRĆf)–Wű@7GČń(Œ ?đŔR΀”˝ße@7‹ˆą]+?đŔRŇ6ř•_@7‘JC°Ľ@_áLfáƒżÔ ŃhÇv?đ@_׎ĄÜܘżÚÄîhƒ?đ@_ÝmŸ‘ŘŞżç mî q=?đ@_đg|ç żęGçhŔ/E?đ@_ěîDĘJżĺÂn?đ@_č)jQżŰŸňKp×;?đ@_áLfáƒżÔ ŃhÇvŔOT,{’řëŔ>ĺ.\=i1@ŔO2˝ Ą˛Ŕ>×c{céĄ@ŔO#yz`&Ŕ>Ź)WÚĚJ@ŔO?-âĐCŔ>‹Ęp‚v@ŔOm™zN¤Ŕ>ŁŽž"t@ŔOkIăáÄĽŔ>ÔĂ(­@ŔOT,{’řëŔ>ĺ.\=i1@a/°éD=@Kd°Ę#Ôá?đ@a;x¨ť@K\)Fn9Ý?đ@a@ĺmtî˛@K˜ j1Ÿ?đ@a5gxÝď|@K’|. ‹9?đ@a*ŁSh—@KwB‚‡Îř?đ@a'6o@P@Kd+d fO?đ@a/°éD=@Kd°Ę#ÔáŔL,`•f2~ŔOˇŹ Nż?đŔKúG(;•ŔOŹ˛ePC??đŔKŠy(÷Ô`ŔOŹ5rěŒu?đŔKuBÁ“tŔO™÷ô€{o?đŔKęvH-4ĆŔO‘.¨n^p?đŔL4 RŹź­ŔOĽu ÷Âw?đŔL,`•f2~ŔOˇŹ NżŔ`é~GN'@JĽ†Z->§?đŔ` ľp)ŽB@J†ƒ˝‚|ź?đŔ`!r#:ŹĄ@Jm)ŚĆ&?đŔ`¸r*R@J`{€Ë?đŔ`dŢ/@Ju°„–{?đŔ`•ýĺ@J–b2‹h?đŔ`é~GN'@JĽ†Z->§@YÁÇsl@?ę†^ý$“?đ@Yˇƒíö—?î@ÓhŰçƒ?đ@YŚ@eÇT:?đýŽĺ°Đ5?đ@Yy7oG(?î1^)9gŞ?đ@Y§SCßÝÜ?é=ŮWó—?đ@Yź;˙4¸ ?č3¸9ę˛2?đ@YÁÇsl@?ę†^ý$“ŔBŇ+Z!¤ŔSŠ'ĺ u0?đŔCHć]ŔSĽ˛{ŐŮő?đŔDv‰ óŔSŁĽU fů?đŔCůӜ§Î#ŔS§T ?Ăš?đŔCD'ŰbŔSŠŁĺh"?đŔBŇ+Z!¤ŔSŠ'ĺ u0@VŞąą@6Č<ŠÍs?đ@VĽŕ Ź&Ż@6\ Ś|z?đ@VŹŸđ: ÷@60}‘*?đ@VˇŠl@6\ő¤>ž,?đ@V˛Ü†Ľ†@6˘—<Ż^?đ@VŞąą@6Č<ŠÍsŔ430!ěARŔRˇ;ś7L?đŔ4+d¸{ŔRŹęU[–?đŔ4zUOŔR“˘rā?đŔ5:żN˘Ć•ŔR”‰^?đŔ4‹Né@éóŔRŻU^˙?đŔ430!ěARŔRˇ;ś7LŔ]ƲP7íń@J],cŻń=@Ŕ]˝főémf@JMěFËş@Ŕ]iŐč¸ @Jp˛ó@Ŕ]Šş—<ĐÎ@J1}~`7@Ŕ]ťŢá‡l@JO 'ů(đ@Ŕ]ƲP7íń@J],cŻń=ŔH˙â(V?оܖs?đŔI$ąXť”ż?Ęgĺůą?đŔI# ŻGĺ?Şg›}ö?đŔHú'ŃNMżJ„‹ć?đŔHâŽ.řň%?É靈çv?đŔH˙â(V?оܖsŔcđ|ŃP1@M0Ń½Š?đŔcpţŚ@M4wˇƒĆ?đŔcę‘ @M"|€ KC?đŔc"d_Ÿž@M aQ”‘Ú?đŔcGűI$@M `Đżą}?đŔcŮC%ł@Mf ßB?đŔcđ|ŃP1@M0Ń½Š@e&ľ#łš›@QxUx_D?đ@e č›@Q0ăiĐ?đ@dţďĺDŐ@Qs źö›D?đ@e⣨3@QfĘ,ĺK?đ@e(oôÜąá@QjŽmpŠ?đ@e&ľ#łš›@QxUx_DŔ3œˆp@S0)âőšÝ?đŔ3÷˙ýW@S%Čdě0?đŔ2źŻ6ę@‘@S—şŕ?đŔ2Ş×[Ńo@Sssz‰?đŔ2¸%\\Y@S'JI^0c?đŔ3œˆp@S0)âőšÝŔK‰ĹŁŇÖÁ@ęůL&֋@ŔKœuŮNˆx@(ŔŃíŽ@ŔKĄŹÜCăo@9jöąĐ)@ŔK{M#ÎŢ8@^˝„¸Ä@ŔKp$ţ<´Ű@[šJ@ŔK‰ĹŁŇÖÁ@ęůL&֋ŔROé]ŠGÖŔFwŤ\ĹľĹ?đŔRAšl|ĘÂŔFjđĘ ÜÔ?đŔR5ˇä^”ŔFMŒýűeB?đŔRAelŁ ŔF7ýjęÉ|?đŔRQu”ŃCŔFH~CíşŹ?đŔRV=…ŒTŔFe“2jô?đŔROé]ŠGÖŔFwŤ\ĹľĹ@ey$B„]¤@4ôKŒƒ?đ@ee-m˛íÚ@fnď,â‘?đ@eoZ iM3@Fŕ/E}ú?đ@euď˙8p@÷ń5ŕrĎ?đ@ey$B„]¤@4ôKŒƒ@MĘÇtfň‰@Tţ-7Îe?đ@N|šHDßž@ToÇVw?đ@OŠ/N”Ú@T0%U†BĆ?đ@N4—Ă24@T4ß\őeţ?đ@MŻĺŠŻ\)@T+ĹN/wŽ?đ@MĘÇtfň‰@Tţ-7ÎeŔRkŹĺ)—â@4ö‰ƒäpň?đŔR\JUń5é@4đGîlźŸ?đŔRFeűĘĽA@5$Źžľ˝^?đŔRSşťŰ-Ó@5,ö¤Š-„?đŔRf—žŔ ‡@5Zaą ?đŔRkŹĺ)—â@4ö‰ƒäpňŔ`GÚfđq–@JđÄĄ9â?đŔ`A̡Xˇ0@JÖCü”?đŔ`4í@J˛đŁŔą?đŔ`5Yémľ@JĚŁ˛ä [?đŔ`?É7V}Ĺ@Jč‚Am’ą?đŔ`GÚfđq–@JđÄĄ9â@]ĘxĚś@@Z|j¨Ňô@@]ŐÍFŃĎĆ@@cÇ[r> @@]Ô1\˘Żß@@ŠÄŕ? ¤@@]Ŕźč:ĺ@@‹TCKËZ@@]Ë}ő%żC@@Š:ýLď@@]ËcĎRŢ@@qauÖÄ@@]ĘxĚś@@Z|j¨Ňô@`DQ†Ö(†Ŕ'˘Ľ  Ą*?đ@`Ow{ŠĎ´Ŕ'„žˇ–˝?đ@`L{.rrŔ&ěő*ŁŚ?đ@`GŹ^˛Ŕ&Ý ‹ ?đ@`Cˇƒ"9Ŕ'eĂ.u?đ@`DQ†Ö(†Ŕ'˘Ľ  Ą*@_ľ>ď­}@@œÔNNÖ?đ@_ŠGň§¸V@@ĂĐúÂ?đ@_‘ŤCpß@@Ť{IUO˛?đ@_Ł?íř C@@ž—ć‰Ĺ¸?đ@_¸ži1w@@´Ô÷¸§?đ@_ľ>ď­}@@œÔNNÖ@QˆŇ.Äp @RCŤ/T’?đ@QŃq߼’4@RLÄËgPœ?đ@QĹŕÔ̖Í@RXňA­Ź?đ@Q‘Hg=o@R\`>Cnj?đ@Q~ë…Ë,œ@RKSž‚Ůâ?đ@QˆŇ.Äp @RCŤ/T’Ŕ]tŚ ><@S„Cşť?đŔ]›xß (@RüZZŒúŚ?đŔ]ž×˙Ę@RçK}–Š°?đŔ]„Q™tY@RěĂň%i?đŔ]gáC̊/@RţîČý&š?đŔ]tŚ ><@S„Cşť@LĚyŘgŔ4żü…š?đ@L°bXsFŔ4K0Iäo?đ@Lš݃_GŔ4}éľú&€?đ@LŢű˙R/Ŕ4`—‡×?đ@Lâ"Ü˝¨ŰŔ4-řőt )?đ@LĚyŘgŔ4żü…š@C™M–¨VŽŔVŰăŤ×?đ@CŤPd$Ŕ<éé™"L?đ@CŔ ¨ÝŃŔwř-Ąŕ?đ@Cą4ĐÔ: ŔčşüǞţ?đ@CŁÉCG2vŔKqšĚ?đ@C™M–¨VŽŔVŰăŤ×ŔFw(žçx@TˆŢ஘Ő?đŔF^˛ęň@T™ľ$Č$‹?đŔGO|~ڕß@T¨)Q5Äg?đŔG~UœÓ@Tšű˜ń?đŔFŇżdœx6@TŒ€Ÿ`Ác?đŔFw(žçx@TˆŢ஘Ő@dż…Ź€$@KŞVŇćÄ?đ@dž•Á**É@K™uɝ˜Ç?đ@dĆŘ^7ˇĘ@Ky}CJť?đ@dĐ˝aőÍ@Kmý‹Ťč?đ@dÇđóĺ@KœKŸo?đ@dż…Ź€$@KŞVŇćÄŔQ0xŒxs­@IĎĎKţč?đŔQC&KŤńÓ@IˇőwĂm˙?đŔQ7řŮ:’Í@Iš›8ž%?đŔQľ7ťv@I¨âDXť?đŔQrÓ(‰ @IÁŮ9-Eŕ?đŔQ0xŒxs­@IĎĎKţč@^ˇ˛Öę‹ËŔ%˝úĄ˙]e?đ@^ȍŚNhŔ%Ľ%_L¨¤?đ@^הŤÔ˜XŔ%/ÍŞđ|g?đ@^ÎĘĐĂŔŔ%ÇAż(č?đ@^żŽż‹ÓšŔ%ogzˇď?đ@^ˇ˛Öę‹ËŔ%˝úĄ˙]eŔZ|1úú†@SnBqłŘ#?đŔZoT?ҋ@S_ł:Q ?đŔZAÄOţ@SLőţ@•ű?đŔZ-uu•*@SX%ßI0?đŔZQ;üŰvI@ShŤTEl?đŔZ|1úú†@SnBqłŘ#ŔR `Űń´ŔHŢ1eV9P@ŔR(ôGÖ ŔHË2Ę<7@ŔR5œŻßJĄŔHźď1Őţž@ŔR9ąb]@†ŔHĐćC<ˆÝ@ŔR‰]ď˛BŔHŰg…˛ @ŔR `Űń´ŔHŢ1eV9P@\EŔťßň@Rę0ě ?đ@\FŘ8%Ý@RˆďƒRĹ?đ@\l’'ž@RœüÂ}˜\?đ@[ď󽜂ŕ@RĚÇ} ?đ@\éăXąy@R‡bOŘ)P?đ@\EŔťßň@Rę0ě ŔRËpáđč=ŔHW$—2?đŔRÇžBQ†ŔH> Cűâ?đŔRŘH–Ż­˝ŔH˙¨CŚ?đŔR܃Šf?ĺŔH)GŽŸkŃ?đŔRŇ"ůikŔHHô„ `?đŔRËpáđč=ŔHW$—2Ŕc‘fĘ°ĘČ@4윻EŞ?đŔcŒž2"ââ@4ĽwˆđZđ?đŔc‚şĺ6pH@4­Ć(J˛ž?đŔc„z†v.Ń@4Ţř´đ“?đŔc‘fĘ°ĘČ@4윻EŞŔMurA…fŔOwd6N?đŔM<ö‰Ş%ŔOPAş0‚?đŔLě(∊ČŔOć3âky?đŔM!řn˝•ńŔNř˘’4Ž?đŔMcš˛šŔO „\ů( ?đŔMurA…fŔOwd6N@@Ĺ0’lH@C> ş^@@@ÓLS˛n@CQןcç@@@š w[+@Cx%{őm×@@@™*q+ß@CgžN’ś@@@˛¤bh@CIH Ć*<@@@Ĺ0’lH@C> ş^ŔRcŒR@P˙űNCmă?đŔR…áŸZŒ@Q|‡),?đŔR§šŃ°@Q+jąß?đŔRšcë(çĄ@PóŽ$ć[Ú?đŔRc¨# ő@Pôfő3Ľ?đŔRcŒR@P˙űNCmă@3V˝ {@K"ůžVť?đ@3”Q@K*ŠFaý?đ@4Öć _ë@KN4Ä=•?đ@3Ógfô í@KH‡‡T¤ť?đ@3hŐ +5Č@K/C+ë„?đ@3V˝ {@K"ůžVť@:HŇí4@CŽôvĚú?đ@9óď#†ąş@C áumB?đ@:".Ş#Î@CŽ˙It ý?đ@:y”_!%P@Cƒ?¨3¤Y?đ@:z^/k@C™đÓ⠒?đ@:HŇí4@CŽôvĚúŔeiÁ^8Ŕ+›ĄĐ–%?đŔeˆj23ŠŔ+„oPĂŠÍ?đŔe‰~ĚŠ$Ŕ+ą lëô?đŔe”ść5€”Ŕ+ Ž–đ?đŔe“ĹČ#çuŔ+g0Â@ÝD?đŔeiÁ^8Ŕ+›ĄĐ–%ŔT3ýœŠZ@;/RVŚ^@ŔT?V{á@; iĽ\ł@ŔT>Qż2O@:ÔĂÁ˘4}@ŔT-źu˜ľö@:ĂÓÇĄoĺ@ŔT*VBD¤@;ffá@ŔT3ýœŠZ@;/RVŚ^@dúş×$´DŔG_E9kg??đ@dő`đŹúnŔG’n"¤Ÿ?đ@eŹ~Ę}<ŔG‹$â饕?đ@eq•žY ŔGqŃŔô?đ@dúş×$´DŔG_E9kg?@<#ŽÎú-w@B5Ί%Ł?đ@;čCEý¤+@B)L`qâ‹?đ@;Á&„h|Z@BˇŚKšö?đ@<ĚT rˇ@Bń,Ç{Ę?đ@<0p ţUÄ@B(dćłÜ?đ@<#ŽÎú-w@B5Ί%ŁŔ\ šTz+l4@JœfĽ+ź?đŔ`; ć™@JŤůÂýŰ?đŔ`F°€|@J؍ l?đŔ`OśčÉű”@JÍŁőÜú/@^źXßn[Ŕ=xÎ-ç?đ@^~1ëŔšôƒL?đ@^áçŘ{4Ŕ@ă~y_;?đ@^"0ŤT|—ŔÔȁtL‹?đ@^!ţšpgŔ­ŞFřĄ?đ@^źXßn[Ŕ=xÎ-ç@adŤh#đ Ŕ0ÁĐű?đ@ai MPŔ0˛ŢVMZ?đ@as>‘öWŔ0‚ÖŘ2´Ń?đ@amrSłfvŔ0qú¸1ś?đ@afŇŔ(aŔ0šLX˛ ?đ@adŤh#đ Ŕ0ÁĐűŔVʝOěŔR#b!˜ĹÉ?đŔVßđwšPhŔR.œŘ˃8?đŔVŘZFŐ`pŔRAšňN?đŔV“ăń+ĆŔRA ő&ő?đŔVľ˙ĘŮ5ŔR/ćXt@?đŔVʝOěŔR#b!˜ĹÉŔY3_kOQ@ŔR,)S~ŕú?đŔY¤Ä׈­ŔR1Kŕ¸ő?đŔXĎ­|&ŔR0…h #?đŔXÜý3 š3ŔR&ˇëV ?đŔY˛†IĐŔR%]=ę‘?đŔY3_kOQ@ŔR,)S~ŕú@@1SœN>?ůœ^~ôĄ@@@?˘ÚĎá”?ú8ě3(]@@@pŠr¸”×?üÂ|Ž‰@@@XR­÷ ?üt/v2ć@@@6hT›Ű’?úĹžťě^@@@1SœN>?ůœ^~ôĄŔT6Śň@;Ů°tŞ)?đŔTókCřň@;´ÝëÖH?đŔTu’U†7@;VjMŇú?đŔTcŽr ë@;paŠ!p?đŔTóŹF@;śX=9–7?đŔT6Śň@;Ů°tŞ)@^LŕŞ6Ş@?ČXĆÍ`í?đ@^Uż1‘n1@?§0˝đţ]?đ@^m´Š˛ß@?ƒA¨I?đ@^iĹýƒKE@?œOGţ1+?đ@^XdˇęŁ@?Ĺ} Ë:˙?đ@^LŕŞ6Ş@?ČXĆÍ`íŔS"^I>ž@G×ǤűyZ@ŔS/@Ç´›@GĂ~¸]%‘@ŔS$čĹu@@G™XK’Đo@ŔSĽĚŔý@G§ŘǢŻ=@ŔS$ş}řŁţ@GĹ´šÉĆM@ŔS"^I>ž@G×ǤűyZ@bžĽ3umŔڋÜ?đ@bÂżüŃoŐŔŠó?đ@bËnQA’/ŔJt)Z ?đ@bĚ énÍ Ŕť7Ŕ§ů?đ@bÂÉ×ŔPxŔa-ćÔ\ä?đ@bžĽ3umŔڋÜŔcż0fúŒ•@5´ěĘzK?đŔcÄgňHW$@5VvĽĆŸ?đŔcĹ_-ŃVR@5gâ° ¸—?đŔcşúqFĎŕ@5Yœt1žI?đŔcźŞÖ4@5’`ţ ľŁ?đŔcż0fúŒ•@5´ěĘzKŔSqGž [6@8H@LšşEÖŞo?đŔ‹ŃUWĂ@LľX@3đĽ?đŔ.ňS*@LÓ@c%/3ŔXCž“j4@;ŐŐży?đ?đŔXK§AęM'@;ąmĚŁAc?đŔXVC2u)5@;`püżŕ?đŔXRŇâE@;s5xgE?đŔXI0 @;´{*Î?đŔXCž“j4@;ŐŐży?đ@_ —-tq@,b…3%?đ@_>÷’ @+Kúe{ž?đ@_Ĺ Öޖ@+TcƒŒX?đ@_Ý7ŕMű@+Ý9u3š?đ@_ —-tq@,b…3%Ŕ/vgOˇg@;ĐŇ ‚Wö?đŔ.ă7lIv@;Ó5~Őť?đŔ.â<„‚Ĺ@<X2ÉŚ?đŔ/v™‰ĂX@<ş­A?đŔ/vgOˇg@;ĐŇ ‚WöŔUçb‡]MĹ@AfŠíúËS@ŔU×X—ç–'@AcA­sÄ­@ŔUĂF¨~!@ARőžÜ@ŔU‹ľÚË^@AWzź’ Č@ŔUÖ`äA—@AgľżŒŔ@ŔUçb‡]MĹ@AfŠíúËS@EĄh;"ŔiŔ&ÚÔәA?đ@EžĆßł0}Ŕ'BĚÜýż?đ@EŹ15RLŔ'šąqF~?đ@EšŮ&•¨Ŕ'”ž~ŐG0?đ@EŻ×¸K’WŔ&ôŢD65Ů?đ@EĄh;"ŔiŔ&ÚÔәAŔeÁÖ%75@JÇŔ@š]?đŔe¸?ĐÖ˝@JŚ9Éoo?đŔeŚç82Ç]@J¸ďčÁ…?đŔeŞŕ$ć@J Ěu+ť?đŔešdƒťü@JĺkG?đŔeÁÖ%75@JÇŔ@š]ŔRî“I ž@A˜Wáʜ:?đŔRâŽ,ú@A¤hŇ×ó?đŔRŢLj|Ř@Aȝ#aŔ?đŔRޛ’ëčŰ@AĐŕígź”?đŔR䲒§@A¤°N°—?đŔRî“I ž@A˜Wáʜ:Ŕ_Ńźz+Aň@J5ޓ—Ź?đŔ_á=ÖçŞ@J)oÖgÜK?đŔ_ö0ô?Ä@J żUr#á?đŔ_ęß.ży@J ˝7ŐŽ)?đŔ_ÔĺÖLđ@J%cA“Śĺ?đŔ_Ńźz+Aň@J5ޓ—ŹŔ`ĽD|†´@KVjmČ?đŔ`¤üłs@K‡ˇœ1$ž?đŔ`›Ź€‚sŞ@Kaů°)•Ę?đŔ`šŻ­g@KmßKL?đŔ` ˛F'Ą/@KŒŹČši?đŔ`ĽD|†´@KVjmČ@VӕE+ńä@Sů2ăÝ0?đ@W%3/őv@Sî`¨%ĺ#?đ@WS~łN@Sý=Z ô5?đ@VăĆqŻó@TLuŇZÝ?đ@VӕE+ńä@Sů2ăÝ0@c&^łł¸Ŕ&ˇv{–?đ@c*o [ăúŔ&˙ž••?đ@c3¤yš3&Ŕ'6Ú?żĹt?đ@c3€7ŞcŔ'î6ˆĆą?đ@c*ž€ěŁóŔ&Ĺńůk?đ@c&^łł¸Ŕ&ˇv{–ŔU÷lößęđ@G´Łi„0?đŔVî÷Žz@Gťś@p?đŔV8v @G•ôŐCl]?đŔV *iFE@Gžcí˛ů"?đŔU÷lößęđ@G´Łi„0@Cܝ˘ś[ŔČAÖۏ?đ@CçśöžĆüŔ\;íTŞź?đ@Cí>ŠqýŔ7 I@sÄ?đ@CÝůnҞvŔöŮëÍ ?đ@CŮŠő<}\Ŕh^ęąd?đ@Cܝ˘ś[ŔČAÖۏŔ4ćҏéřF@R›wV6sG?đŔ5ÇÉEť.Ŕ@R•W/ŽfŹ?đŔ5bďíšý”@Rˆ&ë¤îD?đŔ4kpá[™@R~Űđ’j?đŔ4ćҏéřF@R›wV6sG@aPBic @C'ƒŹž,?đ@aK˘3¤ŹÚ@CőC•?đ@aH—0ëA˝@Böry&š‘?đ@aN.6—˝ž@Bđôćói%?đ@aOçwÜAá@C§Ü‡›n?đ@aPBic @C'ƒŹž,ŔVSăĂy@.źě"žNr@ŔVIü*ř@.ŘqFoDM@ŔV;2d~ë×@/SŰ˜N@ŔV?¤66@/R3XŠ=@ŔVRů ďŮ`@/đĂ} Đ@ŔVSăĂy@.źě"žNr@>‚đˆvxë@I›zçę-@@>dÄE*A@IˆIţ@@>o2';:Š@I]ő‡çÎĽ@@>ŠÁ'@Ł@IeE°+@@>‘Œ#řČl@IŠŃër<=@@>‚đˆvxë@I›zçę-@YÉtžČĘ?ěčŠ\Ł= ?đ@YŔw¨ěď?đÎÓ^ێ?đ@YŻ-¨—J?ńŕ§vzʈ?đ@Y°Ç˛×ƒ?đ*„g{~?đ@Y čuQ?ě,Ţů/śo?đ@YÉtžČĘ?ěčŠ\Ł= ŔU˘¨×A4-@>eÍNŠŃŘ?đŔUŽŰôŤ˘@>fçŰ; l?đŔUÇĘĎx8@>Yln!›6?đŔUĂf[Qż @>YGřľRŘ?đŔUŽO8ŐŰŇ@>d?# •?đŔU˘¨×A4-@>eÍNŠŃŘŔVڗÄŔ @Huťúh?đŔV,ł[ő”@HFÎuç5?đŔVG¨żŽö@Gř–ÄĎă?đŔV>ŒL@Ż@Gón‡lLb?đŔV'ŘߘŃ<@H•ť‚vĐ?đŔVڗÄŔ @HuťúhŔŰŕŕ+‚?đ@4‚ŻĽ÷šü@S™vCޏ?đ@5-ťšá@SŽ7ŽĐÚp?đ@64ź|îý@S—“f֏ŔcîMˇĐĄq@68ăup Q?đŔcö÷ŮŤ@6™Ćľ?đŔcńOh?đÔ@5纪wŚ5?đŔcę}ËO…‚@6 Ҋ8?đŔcîMˇĐĄq@68ăup Q@Ym”2Ľł.@m•i  ?đ@Y]öž”’ @> ˛Ľb?đ@Y^şśq‰´?ülHÇŚŮ?đ@YmzÇď´?ýŮě ŠE?đ@Ym”2Ľł.@m•i  Ŕewž+ƒ|éŔ,ĄĎhœ4?đŔeqŚ2ď(˝Ŕ,rşÂˆĎ?đŔer%őŮŽŔ+Ň ~U?đŔe}ĽüÚÝzŔ+ŽČÚJ4f?đŔe|"¤v9ÁŔ+ţmkۛŁ?đŔewž+ƒ|éŔ,ĄĎhœ4@`˘ÔČn˙Ŕ‘Gš66Ę?đ@`’~BIŔ9ˇ˙N ?đ@` ŤÇŚ@ŔÁؑN™›?đ@`¤˙eP˝şŔž‰ŠýŁ?đ@`˘ÔČn˙Ŕ‘Gš66ĘŔVÉ úş@Sb!\e2/@čŹ?đŔR­IľŮoŒŔQƒ jś?đŔRÍŤŕGggŔQv%íkfp?đŔRďĎ9˝ÍÁŔQ€žy •ů?đŔRÖĐG|ŔQŠ>/@čŹ@déŻiwG†Ŕ4Ո Úż?đ@dä6ž3+Ŕ4Ĺňƒ/P¨?đ@dä ż°uöŔ5Íú“V?đ@d얽V}ŃŔ5ŤäĘŢ?đ@déŻiwG†Ŕ4Ո Úż@Mt>0erl@4ą†á?đ@Mi™kt@4‘4œˇU?đ@MTüVËř@4T†ľÁŐĎ?đ@Ma'-ę9@4L>Č:ł?đ@MsÄJśĆÓ@4ŠUL }?đ@Mt>0erl@4ą†áŔSŹpO„@QRuw ËE?đŔSÍ`ţÄ;ś@Q>†a8 ?đŔS°Ľ$nť°@Q>dçtœ?đŔS—şâ2F@QPWŒq'r?đŔSŹpO„@QRuw ËEŔc—žŚ@LýjČě@Ŕc†WëďΊ@LߜڈŠ@Ŕc€VƏD@LčZˇa7@Ŕc‰ĺL[[ś@M44Ĺđ@Ŕc—žŚ@LýjČě@&žqWď“@KnBV™B?đ@&‚~‹Q‡v@KWRĚ9€i?đ@'s{7֐ @K[_€;?đ@&űVN×ţ@KopôË'?đ@&žqWď“@KnBV™BŔN´ŇEyď[@GŇtWđË?đŔNΖp$U@GĘ)Í3?đŔN÷„xE÷@GŤšnÎb?đŔNć‘1eJ…@G°ŹtP+đ?đŔNĹ\4¸Š @GÉŹ" ˜?đŔN´ŇEyď[@GŇtWđËŔ\ Ä-Ý(@=&çîÖޙ?đŔ\ €Bź:c@<î*K?đŔ\j75ŢĂ@<ŐčÓ(¸ö?đŔ\:}:ů§@=*UÄŚ÷e?đŔ\ Ä-Ý(@=&çîÖޙ@0aM N@E˜ş]+ţP?đ@0”eĽ@E’q ?äÂ?đ@0ţřž}uN@EF' 5?đ@0÷^ĂŢČÂ@E“ ę{g´?đ@0“‡ü?Űš@E™Ć%óđ?đ@0aM N@E˜ş]+ţP@^„ †[M@íďţ¨G?đ@^xąÍtĹF@¸-6Á?đ@^‚eîŽŕ&@ľÝą¸?đ@^ŽihMĹL@uâŞ$?đ@^„ †[M@íďţ¨G@^žSšÚ2@*?ĹÎLNĎ?đ@^Â6in;ź@)ůoŘąPx?đ@^ŃLWŐ!Đ@)–,8Y}?đ@^Ň2č(üą@)Ś8ŃŸŤ?đ@^Ć"ďN3 @*uĘŃ?đ@^žSšÚ2@*?ĹÎLNĎ@SPWͅá@RşT•ć×?đ@S‡ úEŚ´@R/.şgF?đ@Sw˙Çńń@R&'⡹?đ@SHů‰"(É@Rsf„8}?đ@SPWͅá@RşT•ć×ŔR˘C(ĽE!ŔHP˘ČÄo?đŔRŤŠ´ť3ŔH'Ç˘:&?đŔRśű(%GçŔH8żdÔ!;?đŔR´‚ĹĂľBŔHQ´t˝}Š?đŔR˘C(ĽE!ŔHP˘ČÄoŔRépŕ0@8’ůÄzÜŠ?đŔRÜŠ Ÿ@85ď]˝×?đŔR×ĚʒČ@8CŠą˜—3?đŔRä ćŃ 5@8ƒŃ_"ęŔ?đŔRépŕ0@8’ůÄzÜŠŔYÂ^SŽśČ@SĎdĽš?đŔZ‹˜Ôđ@S Ŕ´ ˇ?đŔYútw1 Ĺ@S4ĹÁb?đŔY°!x&,I@S !l?đŔYÂ^SŽśČ@SĎdĽšŔZ÷ď…ě`@RŮȸ=R2?đŔZ1ÜŮĹ@RĚ Ľœ2„?đŔZ9ÝcC@RÄ{ß?đŔYőW„6ţ@RÔb83)ó?đŔZ÷ď…ě`@RŮȸ=R2@K“ÝuE'@T<ž/%ÝÂ?đ@LvNPŐ!1@T1Pőůˇţ?đ@Lt„(IM1@T:^3;ď?đ@K™€wě˘!@TCJÇD?đ@K“ÝuE'@T<ž/%ÝÂŔGKź×#ýüŔ4ŽăT@ŔGX&4h†Ŕ4€ü_šf@ŔGvľŰ6ˆŔ4Vsßwa@ŔGxy‡CŻXŔ4fŔ>`ű\@ŔGcqÄľ|Ŕ4†Ľ­q"@ŔGKź×#ýüŔ4ŽăTŔNmVÜëJĆŔORqđ@¤â?đŔNVźL"ŔOVT?Áž?đŔNBň~mŕŔOCţ2cJ ?đŔNqŒßV\?ŔOE…őXýą?đŔNmVÜëJĆŔORqđ@¤âŔX„[Ęę@R…đ=ŮDl?đŔXÂćQvB@R}”łńrś?đŔXś &2îŮ@Ru‹ƒžŸ8?đŔXwţIW*@@R~ű;ž??đŔX„[Ęę@R…đ=ŮDlŔR|bôF2Ç@6 |7"cĘ?đŔRˆŢÉjř@6M~lŢŽ?đŔR€ŽÎŢ/R@6Y•|‹ň?đŔRw!‘âŁ@6›ŐŐÝâÝ?đŔR|bôF2Ç@6 |7"cĘŔN–ĺhŇ­:@-vÉEńl4?đŔN|6qœ÷@,ţ{™ÓP5?đŔNq˙l˙ě.@-S1âúG?đŔN†zQ/˘@-¤\„KŤü?đŔN–ĺhŇ­:@-vÉEńl4żö^šÖč—@N9ŚßBńą?đżöŃyŮŔ$ť@NHĹÔY'?đżónÓ\˛:S@N ŠŇĽ›?đżňŽáBĐ@N4ź¨d,?đżö^šÖč—@N9ŚßBńąŔ9žb ’Z@BäśĆŢŻ?đŔ9_.Đ°gs@BÜhăŒřÖ?đŔ9HKt@BęšHz|ň?đŔ9ŻÂ˛ 4@Bě…ü?đŔ9žb ’Z@BäśĆŢŻŔZ6•…K7@S(ćĺęě?đŔZĽůIő@S‰ĆÄf?đŔYÝ˙źzh@SîNŤô,?đŔZ6•…K7@S(ćĺęěŔbą*HjŞŔ1ż}Đ7ٗ?đŔb¨ć˙^ĂśŔ1ËR”ą5|?đŔbŠÉvş–ŸŔ1ŚUüŠÖ?đŔb˛Ć}byŔ1‘Öť3 „?đŔbą*HjŞŔ1ż}Đ7ٗŔUy9Ŕ=@PƒNˆÂ9?đŔTěąžœŇ#@Pn'î?đŔTďYő{Ň'@Pxc{őa?đŔUy9Ŕ=@PƒNˆÂ9@Y Žd6h—ŔPkUl¨gN?đ@Y9ĹCŚŔPj\ÂËÄ?đ@YEZíȁŔP\Ř˜t‹?đ@Y{“FŻŔPb‚ ˆżÔ?đ@Y Žd6h—ŔPkUl¨gN@O†Ĺ> e@T/DěŐ­O?đ@P3ŇEX@T>ŹîtŞ“?đ@OžŻ‰X?Ö@T e@T/DěŐ­OŔ`ŒěeŤ1ń@L,a;Ę\1?đŔ`“íŁ,ěx@L“űe%ö?đŔ`‰ŽąxÎ@LeĺmŃz?đŔ`Š‡ÝďŃ@Lƒž* ?đŔ`ŒěeŤ1ń@L,a;Ę\1@*]Q˜U1@K%lŹ›ŠĎ?đ@+‘°*@K&ÜdWb?đ@*⪁č„&@KGśGňYA?đ@*rI¸ @K< )üźÍ?đ@*]Q˜U1@K%lŹ›ŠĎ@Lňȸpß,@TšĆ8OŰ?đ@MEÍˆ@T>ĎŰq?đ@LéCš0¸h@TŁ].&?đ@L§œ˙Ĺäy@TœÇ˜?đ@Lňȸpß,@TšĆ8OŰŔRĎÖűľ9ĂŔI7œ$Šźů?đŔRź <ŔIüä0 y?đŔRËźűú97ŔI˘Ě”CŰ?đŔRŐý5hÇ4ŔI(rcdJ?đŔRĎÖűľ9ĂŔI7œ$Šźů@¤´(@G&ż<4Z@@ćîű“Đ@G4őFPžç@@^ádÇ<^@G?˘nú¨@@űöŤfÓ@G.ŁhŽ‹Ľ@@¤´(@G&ż<4Z@`2‹íşĽĐ@ŕoŒ?đ@`) ómč×@§?đ@`3ŕ8\nB@ŕoŒŔQó–é‚5^ŔJőwĽ]?đŔRĆՅŞŔJú­ęK&™?đŔQţgăOUŒŔKĹ< pk?đŔQňŰŘç¸'ŔK ÎŃ)…??đŔQó–é‚5^ŔJőwĽ]Ŕő?ŔÂі@L<âÝ76?đŔ„G_ťö@LJĆҐYô?đŔÂŤ×/ü@L0ˉúúű?đŔE8çî@L,ĹĂľ´|?đŔő?ŔÂі@L<âÝ76ŔfÄ`ŻšŔFÄŽ'…H?đŔf {řÂ?ŮŔEčfÚG’#?đŔf ŠP,!ŔEÝÓ’eD?đŔfmpęĎŰŔEě—đˆ?đŔfÄ`ŻšŔFÄŽ'…HŔPâËŕ@&šZ§Í?đŔOţżŰd@%ůǍŮ…?đŔP =¸ňŘ°@&ŻŽťL#?đŔPâËŕ@&šZ§ÍŔUŽ#¨ĘŹ€@Q iĐopŃ?đŔUŻŹ’ŚĚç@P÷D †?đŔU™œœˆkĂ@QXßő…B?đŔUŽ#¨ĘŹ€@Q iĐopŃ@0#ŽiRŔQ‰ĺF˙?đ@0BşóđgNŔQ€+Bk‘?đ@/>öË락ŔQzĚ…¨ň?đ@/^‡h ŔQ‰śď?đ@0#ŽiRŔQ‰ĺF˙@_˛ đĺ‰@.V×.?đ@_°ÄĄćs|@ąf}ŕě?đ@_¸ÎÜxů&@QŢĹ&‚H?đ@_˛ đĺ‰@.V×.@Y“IÜ^xF?őv\ňŠ0?đ@Y’ÚĽ‘ ?đi™Œy6?đ@Y‰â†Ż?đőäˆŘ€q?đ@Y“IÜ^xF?őv\ňŠ0ŔOz[?ŔQl}„F?đŔO$ßľwŔQTđ<ł?đŔOŰńö[ŔQa‰Î¨ź?đŔOz[?ŔQl}„FŔT$Ć9Č@Qmç–íV?đŔT‰š?Řň@QeO]`\Ö?đŔSęӂí7=@QkŽZCíŕ¸?đ@`üżp!ŮŰ@Rîjďž)ý?đ@`óIŽŹx]@Rî¤ü1•G?đ@`đ5 };¸@RŢČš$q0?đ@`übzZ!@RÜŞ>íŕ¸ŔR¸'b"4ÎŔI‡ÜŹĽ#˘?đŔRŠ°ÝíYˆŔI†2ąĽTđ?đŔR +ĎÄYŔImޏhN?đŔR˛ÁCÉQfŔIvŚ[(cÇ?đŔR¸'b"4ÎŔI‡ÜŹĽ#˘@e x&˙LŔ1‘竝?đ@eaě Ŕ1źţekˆ&?đ@eŮßP‹Ŕ1Â0˝M’?đ@e x&˙LŔ1‘竝ŔOE­——ŔP-űHŤ?đŔOPB‡Ć0ŔP 3•c?đŔOAűEĚ"ŔPIzs’?đŔOE­——ŔP-űHŤŔP.P1t§w@NĎźçćfÁ?đŔPMĂ˙SK @NŃ5Ő IÉ?đŔP9!Ś!Ü4@Nˇ}[äAË?đŔP.P1t§w@NĎźçćfÁ@e=‹46Ŕ/äX$ WŇ?đ@e+FJŰgŔ/;Ë †zl?đ@e]ŽŐ0ĐŔ/Ç)—H?đ@e=‹46Ŕ/äX$ WŇ@4‹Ľř7%@C:.¸“źË?đ@4p(ק›|@C'Đęč‹?đ@4”œ0c,Z@CN5sʊ?đ@4˘ëÍ.˙s@C)#$-~ö?đ@4‹Ľř7%@C:.¸“źË@,¤x&Ѐ@F•bŕ!?đ@,Ë׎Ş)@FjáŮţ¸˛?đ@,ŃЖŤżĺ@F‚ŔőčË?đ@,¤x&Ѐ@F•bŕ!ŔQ›ä˝8…•ŔKsŽćŃKP?đŔQ´ž3XŔK|ĺÖďF?đŔQ¨ž”đęŔKĘĚN?đŔQœýhÂßŔK…|}‹VS?đŔQ›ä˝8…•ŔKsŽćŃKP@CŒA:a@Měëę|8Í@@CÇ°ťĹ˛@M͆÷-{U@@C°Fß>Vă@MŢYšˇĄB@@CŒA:a@Měëę|8ÍŔUEŸÚ2ž@PĘ˙ÄÄŔ?đŔU7Á>ŤĆ@Pl@-۸˝?đŔU1Ô°X|@PwÚőXhž?đŔUEŸÚ2ž@PĘ˙ÄÄŔ@-yPGšÄ@FYŸdľ?đ@.y„UŁŮ@F8˝Ň´ƒ?đ@-Čć\Ś?Ş@FL’čĄď ?đ@-yPGšÄ@FYŸdľ@#B§89F@GĂôšu”@@".čO„@GÜ-‰ňJu@@"Ÿw´nwh@GĚôÜšś@@#B§89F@GĂôšu”ŔV™Ě çôżŕĚs#O?đŔV!f2ěżćۋ‡Ř{?đŔVđ¨˜:ůżä+#ě>9?đŔV™Ě çôżŕĚs#OŔ)ÓŘ1ű@I}ŞÁŰ?đŔ)6ú™Vć@YÍšÉ?đŔ){ywŔc#@‚y?1C×?đŔ)ÓŘ1ű@I}ŞÁŰ@aćsţËM%Ŕ Ű%W8Ŕ?đ@aďt5ŢçŔ!8Ň(›?đ@aëOyĂŰ Ŕ űČeżă?đ@aćsţËM%Ŕ Ű%W8Ŕ@by łtîŔ2\}•}´?đ@b~ܐRsčŔfźÍ}!?đ@bLHü$ŔF Qţ?đ@by łtîŔ2\}•}´@9ű ĺ)C5@CH;?îv$?đ@9÷*â’}†@C$x´đ(Ţ?đ@:$gŰF=@C3DJƒ¸8?đ@9ű ĺ)C5@CH;?îv$ŔRS=‹Ő @2ě=”g?đŔR?d‹=Ý@2ËÁ-bŤÔ?đŔRIĽś–Ş @2đl’XZ?đŔRS=‹Ő @2ě=”gŔXőĽx@TňRU˝!?đŔXŘꌝ8@SöĆHŮ?đŔXĂÚ'źf@T4H›§7?đŔXőĽx@TňRU˝!@e&mQ´—>Ŕ2˝ßuÖî ?đ@e 9Ă]‰Ŕ2Áh_Ǝ2?đ@e'eaú"Ŕ2đ~xéĂ?đ@e&mQ´—>Ŕ2˝ßuÖî @cčłŃÎď@G‡ŤxĄ?đ@býפŕW@Gr7Ďş´ŕ?đ@c;Ąb@G‘]•IQ?đ@cčłŃÎď@G‡ŤxĄ@3şŽ¨Ęx–@Cä­f* ?đ@3ç| ťt@CŔşŘ Ľ?đ@3岚ßS@CŘ`{×˙?đ@3şŽ¨Ęx–@Cä­f* ŔNŃn_çy[@0ü,8~Ž?đŔNϤŃó<@0G-ĆĄ?đŔN㏺ž´@01L”}Y’?đŔNŃn_çy[@0ü,8~ŽŔUÁ#Mƒ÷@FĽŠÎş‹?đŔUЛŸI/@F‚řiÁO?đŔUÄ óŕša@F“: W?đŔUÁ#Mƒ÷@FĽŠÎş‹@_zŘ żšMż˙Šöq:~?đ@_~"Zs>Ŕ^ÂC4ŸtČB@*Ž(Vš`Ý?đ@^g\#đĂ@*ý§dڊ˝?đ@^uRÎ^b@*鄿řdaŔIVŢ"oގż‡wî‡Ň2?đŔIuËD[—čżĹƒ>°NŤ?đŔIYřHÍ9żÂ™Ći?đŔIVŢ"oގż‡wî‡Ň2Ŕ2tŮŔ´h§@RÖC}Tß?đŔ20đ÷/[@RĂä ćü!?đŔ23t2É@RĐ+÷‘Ů&?đŔ2tŮŔ´h§@RÖC}TßŔD°ž‘zS@PűGz?đŔDHŽ›4U:@P/ÜšĎúś?đŔDEËýeuŤ@P&ýŁˇ†h?đŔD°ž‘zS@PűGz@^ ôľ@ý @\C*y-?đ@]ý&¤ŇĂ=@Ťl~Đo?đ@^ yëÔ@Ęë„ŇAf?đ@^ ôľ@ý @\C*y-ŔS#o÷Ś­m@Oşů ŚĚń?đŔSFMתň@OÍ,Ś?đŔS7vRŤr‹@Oľčžx˘?đŔS#o÷Ś­m@Oşů ŚĚń@`aáÚwńx@>՚űKúľ?đ@`^0Y%´@>Š Ç,Ŕů?đ@`aůł§÷§@>Ż" 5ń?đ@`aáÚwńx@>՚űKúľ@^y–<ĐďŔfŇWę?đ@^zđĺˆ}Ŕuš*yě?đ@^‚/€žîdŔÔ´ńEÉ?đ@^y–<ĐďŔfŇWęŔQJLlśz@(Âؖŕ(?đŔQ;üˇ|mB@(Mş Y Ž?đŔQB­l<ɞ@(ŽÝ?7?đŔQJLlśz@(Âؖŕ(ŔQâ0¤6vŔK ™8_ńŤ?đŔQĎŘťÜd5ŔK"…‹Ľ.L?đŔQČš“DŹŔK˙BŕKÚ?đŔQâ0¤6vŔK ™8_ńŤ@J‰(öD¤ż@QžSŰ1´?đ@-đźCÁó@Q%ˇ"ŇŔRŒL{HÄ}ŔIkF€žđ?đŔRšŽ@ęVëŔIJu…,ŕĘ?đŔR˜ŻěÎ îŔIc‡6Ăsć?đŔRŒL{HÄ}ŔIkF€žđ@QP )”¸@JHş-jÔ@?đ@Ť¤PA@J7 2 …?đ@ńӒ)˛~@J7Á.Ž?đ@QP )”¸@JHş-jÔ@@`ßŘ śl@AHë[€?đ@`Ů&Z&U@A)[~"ş4?đ@`ÝöŽRa@A3)œĆŔ?đ@`ßŘ śl@AHë[€ŔQ]"ő‚@NI΁¨!?đŔQ×Ňç‰K@N,üSG?đŔPůÁ<ţ@N4­F4Žˇ?đŔQ]"ő‚@NI΁¨!Ŕ^ŚŽ@ł‚r@H!Ző7o™?đŔ^˘‡ Ÿ é@H 7:†v ?đŔ^§ŚJJ@H2|Çtů}?đŔ^ŚŽ@ł‚r@H!Ző7o™ŔRž:¤Ž“QŔJ ă•×lƒŔ&ăéśZ`đ?đ@a=Ă5$‘Ŕ&bn(aÁ?đ@aé_”YkŔ&›Ger”%?đ@ať¨>ƒŔ&ăéśZ`đ@d+J€ű™Ŕ"˛4O}N?đ@d.ÔüÜ˝ęŔ#B1‰I‚?đ@d.{[řŔ"ěľÂľô?đ@d+J€ű™Ŕ"˛4O}N@c€đ‹XŔŽnŽVBţ?đ@c•iŁúGŔ_Ă^‹Ĺ×?đ@c•ů(äŢĚŔšju ˙z?đ@c€đ‹XŔŽnŽVBţ@DđŞöEă@0ÇŤgČh_?đ@EPMÚě@0łŔŠĽé?đ@DŕŘŐpš@0ŕ( Uî?đ@DđŞöEă@0ÇŤgČh_ŔNź-řź\@/>á€Ŕ!Ř?đŔNŻŠT“@.ťÝ:&°y?đŔNގ—žžÁ@/&‹Ă?đŔNź-řź\@/>á€Ŕ!ŘŔf"$RiXő@Iôťhů8?đŔf.9‡ą¤á@IᘅŠu?đŔf&o6­—@IßÜ˙li:?đŔf"$RiXő@Iôťhů8ŔRo"ÉŻ­ŁŔF•çCRDd?đŔR…T•ýŔF‡v›hŽ_?đŔR Č[ŔFšěRzr?đŔRo"ÉŻ­ŁŔF•çCRDdŔIŽî'@T<^¨îY?đŔJFşDčÚ@TTkK7^?đŔJJĄű:*ą@Tƒoëȋ˜?đŔIŽî'@T<^¨îY@WÜNX3@%Ż#›ç?đ@WCî ?@%=şů—ˇ?đ@W"|f// @%FŚcnfE?đ@WÜNX3@%Ż#›ç@eA”2öŔ0($Nű\?đ@eÎYľOBŔ0O]ńô‰œ?đ@eƒD•ĂBŔ0L@mýb{?đ@eA”2öŔ0($Nű\@S§5ňĺŠ{@R6#¤Űú?đ@SĆ1şŘŁ@R/Ňg{ă1?đ@SÎđëO“‘@R=œĘžŇq?đ@S§5ňĺŠ{@R6#¤Űú@YÚţGRĚŔP]ż˙Žô?đ@YĹÖuŔPM¤˛ą=?đ@YÄôý˜5ŔPW“Äő?đ@YÚţGRĚŔP]ż˙Žô@břýW!;@+Lo3ąD?đ@böąÖ7w@*ĎqGšÖp?đ@b)5ŻF@+­ď†(*?đ@břýW!;@+Lo3ąD@I<Ěo]Ş@:;\č`—?đ@IC ę Ů@9őąě˛×?đ@IKŽUÔ¸w@:%vQ1yŘ?đ@I<Ěo]Ş@:;\č`—ŔI/ţ/Ą˝N?ă~řŢeśŁ?đŔI50>Z#?ÔJh=# ę?đŔI,„łĺäí?ÝuQ}†Ą¤?đŔI/ţ/Ą˝N?ă~řŢeśŁ@WŠz0™ž5@0=Œ­#6k?đ@Wž0[†s@0üˇŕˇ?đ@W§—‚Ţ%@@0áč$C3?đ@WŠz0™ž5@0=Œ­#6kŔ]†üŔľŇ?@HϕN~@Ŕ]„ƒCŹł@H˝NłƒŞt@Ŕ]†ŒłTÚ@HăŃŹŘژ@Ŕ]†üŔľŇ?@HϕN~@_kúÍÔŔ ńďwÔLF?đ@_|ë3áŔ ĄÇN `?đ@_"‘5’0Ŕ ˘Ö¨k-ƒ?đ@_kúÍÔŔ ńďwÔLFŔ\˛0wĄĺ@SÎÍP?đŔ\”5ŸŃíV@SpîxN.­?đŔ\€G„EC@S|m@Ž?đŔ\˛0wĄĺ@SÎÍP@X“ÚgÖ@ XŔK›{?đ@X”!gĐ@@˜ń×†j?đ@X™l<Œ/Ň@ €ăIx?đ@X“ÚgÖ@ XŔK›{ŔXÉqHŸ6@:ŽŮ˙-Žń@ŔXц ‹JĆ@:ŐWŰ0É@ŔXĎgŞp°d@:ŞC _5@ŔXÉqHŸ6@:ŽŮ˙-ŽńŔ91š„j@0őČzŘm?đŔ9â$?@1#­pĺđ?đŔ9W֕+@1 É+˜ă“?đŔ91š„j@0őČzŘm@fCŸ?ĘŔ3ô˛Z°+?đ@fKO4áČ}Ŕ3:ŹÁY?đ@fJ+D^ŞŔ2ô—~ŞŠ?đ@fCŸ?ĘŔ3ô˛Z°+@eřp¤ Ŕ5nťD‰*?đ@dűőTŇ+™Ŕ5„7­?đ@eoÂ=Ŕ5ĄŠŚěó?đ@eřp¤ Ŕ5nťD‰*ŔQM˙űdŔKxz…}Ő`?đŔQm DČňňŔKwÝ,eŁ?đŔQYć ŤÓ ŔK~VŠ€×şÇ?đŔV^cE Îżéßݍ”ˆŔsk#˙Ž@K4üEŮâÂ?đŔ‚X -Ă@KÄY:v?đŔ*F߆$@K!žTD š?đŔsk#˙Ž@K4üEŮâÂ@Yűt Ô]P@$ČP.ÎC/?đ@Yţ—9“ZŞ@$M˜N:w?đ@ZHŁ˛; @$w‡ĆĹ?đ@Yűt Ô]P@$ČP.ÎC/@.ç•ĹČĝ@Q8×.Ó?đ@/˝8ߙ%@QHŘÍĂ?đ@/%+W{@QC:$ˇ ?đ@.ç•ĹČĝ@Q8×.ÓŔF•’fSĘŔN]„/z™m?đŔFÔĚĆWIĐŔNIuż*5ţ?đŔF˝ &—O‘ŔNUz2éA„?đŔF•’fSĘŔN]„/z™mŔSO$ěO@Q[fˇ´ŚŢ?đŔSKŔĂŘÇ@QLčt‹Ľ?đŔS4ßç÷k4@QUY#3Á‡?đŔSO$ěO@Q[fˇ´ŚŢ@,p椑'¤@Q ß)?đ@-“[Κ˙ƒ@Qfnš@?đ@,ÉcÉ{Čn@QY€Ęg?đ@,p椑'¤@Q ß)ŔbŁ˛îœ‘OŔSFb?Ńu?đŔbż0âçŔS;˜Ŕľ^ ?đŔbťzÎvů¤ŔSE§śK d?đŔbŁ˛îœ‘OŔSFb?ŃuŔT Şoľ@9W­XŮ2?đŔT3^>,f@9AîZ?đŔTJ+“E@93™÷ú¸{?đŔT Şoľ@9W­XŮ2Ŕů'¨áӌ@J´O…;?đŔçŻnk6–@J›ł4ł?ů?đŔĚ{bŐF@JŚJ[Ş.ž?đŔů'¨áӌ@J´O…;@e+Ź˜ňŔ.ľ˝Sóňa?đ@e¸Žo’ŚŔ."ÖÁŠŮJ?đ@eŘ<ÎdžŔ.R_Šœ[?đ@e+Ź˜ňŔ.ľ˝Sóňa@`[)!Źˆ*żčą AŇžú?đ@`Rľ<Ű×!żë"ÝřlH?đ@`Y¤~¨ĺ‰żë"ŕśŘw?đ@`[)!Źˆ*żčą AŇžúŔfCąą†@Ióƒ}wZŸ?đŔf@ŤÄ 3@IÚý)NmM?đŔf9XÔ׍b@IäȍڟÎ?đŔfCąą†@Ióƒ}wZŸŔB÷‘Ča@Ph.y‘2?đŔBŔˆĆ_ŐĄ@Pkˆ\‰{?đŔBÚ8;=ud@Pu:ÔŞ?đŔB÷‘Ča@Ph.y‘2@20’b!@Qa÷(gZć?đ@2˝ŰŘ#U˙@Qn,ŤŔě?đ@2Q– -E@QkŘÄß?đ@20’b!@Qa÷(gZćŔeŸçŮhą@NG2qŰZŞ?đŔe‘›Śtoç@N/Ą8?đŔe˜cŐCFv@N< h™É?đŔeŸçŮhą@NG2qŰZŞ@3.…ąŒ@Qrë}Pʤ?đ@3ttÚh—i@Q›=\É?đ@2ňą.^đá@Q}äů¤É\?đ@3.…ąŒ@Qrë}PʤŔRť줂&ŔH1˙ö_#[?đŔRŔO;őüŔHE[Ef?đŔRČÔçBVFŔH&ô÷‡?đŔRť줂&ŔH1˙ö_#[@@Ň0*źjŔßťŹ“?đ@@{.ćŞ7nż˙<ƒô°–?đ@@tdĺd°Ŕi´-˜Xý?đ@@Ň0*źjŔßťŹ“@aZ4…I‰ěŔ SɏÖ+D?đ@aT˘@xr%Ŕ †*š‚F—?đ@aYô’ĄChŔ ąŚ7ť Ľ?đ@aZ4…I‰ěŔ SɏÖ+DŔRÖ |äSx@Bňq$§?đŔRË6ťf‹@COá4Ý?đŔRĎ9c„}@CuO?đŔRÖ |äSx@Bňq$§Ŕ`‹ąÖ{â@L=@Kr“\!ĺ??đ@%śŚ0\ @K€!#f5D?đ@%ׯS Œ8@K“Q–ĹŔR•č–ƒœŔGýK1+?đŔR–ĚÔ÷ÔŔG÷đr&C7?đŔR‘ăމ=¨ŔGîŐ,ľë?đŔR•č–ƒœŔGýK1+@'‚ą°2`@KyŒ˘rí?đ@'ąIBŹčä@K\+śIo?đ@(­X< W@KkJ°l|?đ@'‚ą°2`@KyŒ˘ríŔV’ĂDl’@S4@ňýR?đŔVŠˆĐÇfý@S$Đjřfc?đŔVr¸ s‰@S,ţ{lĚŇ?đŔV’ĂDl’@S4@ňýRŔ_)V7);@HăĆÜ9?đŔ_ŔŒ2 ,@HĚUA@G?đŔ_uí:@HŰ@ŮÔ=?đŔ_)V7);@HăĆÜ9@VĹn8öyľ@6(˜ňΟf@JežÂ"y?đŔ` ݘYśi@JCAż™/€?đŔ` c(Ëó€@JSl4•p'?đŔ` k‰8>f@JežÂ"y@dĆC"…ŔIEwÁ厩?đ@dŔôKŐ*~ŔIc,MV?đ@dƑ8jÝŔIYqŘΟË?đ@dĆC"…ŔIEwÁ厩@e-PĺDŔ3x"×Œ?đ@e()ˆ˝„Ŕ3rőĘŻb??đ@e,űYŇóŔ3˘˘˜Î?đ@e-PĺDŔ3x"×ŒŔb‘Ó|Fm˘ŔSMN R”^?đŔbx)gFZuŔST!ł”Ó ?đŔb€ ö‹ĚŔSHLN ‰?đŔb‘Ó|Fm˘ŔSMN R”^@F€9Ź^;Ŕ(R˛šQŽß?đ@F6ňDŚ!&Ŕ(†“’ŽŐ˝?đ@F/çáĘĹ8Ŕ(GŹ1ţž–?đ@F€9Ź^;Ŕ(R˛šQŽßŔP†J~:ÄŔŔPxIĽe?đŔPqš‡=á¨ŔPjöľ[Ŕ%Š?XƒŁž?đ@d˝÷ť´ÝŔ%hXĂ.?đ@dšq2h‡ŽŔ% 42_œO@/" kÉłŔÔ=ĺČ|@@.ˇŰ7ĘŔ´ńŤô x@@.ăüb˘ŔBĆ4ď.@@/" kÉłŔÔ=ĺČ|ŔRlą^*RŔJ7˛Ý8?đŔR|oÖŽ,ŔJpVcóŔ?đŔRw1ŤľęSŔJŔý‰Ž?đŔRlą^*RŔJ7˛Ý8@HëĹP×Ŕ1üJíč?đ@Húq7e’WŔ0ÜśźKf?đ@Hđđ[ĹďŔ0ôŚŁd ?đ@HëĹP×Ŕ1üJíč@9pÔ|ž˛@Dó!ě?đ@9+YC$Dž@CöăCHi?đ@9L$†î+@CďGLJC?đ@9pÔ|ž˛@Dó!ě@`3\? 1Ŕ>=’ú b?đ@`5WłMŔçýn¸żS?đ@`9*f“u–ŔůđĎw?đ@`3\? 1Ŕ>=’ú bŔ`(‚ŚÚlj@JhZvUë?đŔ`#ˆm V@JKwֈ:;?đŔ`"Eŕ9*@J[0 5?đŔ`(‚ŚÚlj@JhZvUë@-@ŚP@KĄ–ƒüş“?đ@-Óߌđi(@K‡=d1j?đ@.ƒŕ“â@K˜ŕGԈ?đ@-@ŚP@KĄ–ƒüş“ŔRŔç‘ĺ'XŔIź {RLř?đŔRŹ }żqŔIŠáúçDř?đŔRšI°ÇäŔIŹOÜt"•?đŔRŔç‘ĺ'XŔIź {RLř@Wj[Ě^ť@3‚uţ›[Ň?đ@Wtć ÉC<@3X ´ţĹG?đ@Wtş"şm@3}SVlĹő?đ@Wj[Ě^ť@3‚uţ›[ŇŔR’tJLě“ŔFfăpK"?đŔR‚ Ó¤ó¨ŔF[ÎŹ„ţ?đŔR’@Ë 6XŔFU7rpy?đŔR’tJLě“ŔFfăpK"@7*(đ¸D@Q‘šjp.?đ@7{CYÇ<@QžpE¸›?đ@7RÍÖ}ú@QœTŚ,ř‡?đ@7*(đ¸D@Q‘šjp.ŔRÎş |ňŔHî´üND?đŔRŮ"UÉôŽŔHŐBĐąl?đŔRÝö9ęy;ŔHăy5đŠY?đŔRÎş |ňŔHî´üND?řłŒŕŐü@Cha™ř„?đ?őX]'ž@C|ôĹđ5%?đ?řąŽ!xÓă@C0$I?đ?řłŒŕŐü@Cha™ř„@H!mdÍß@=ű€üÍ?đ@H§[ňťe@=ĂÖVî??đ@H#Öť˙ë@=ݸz ›z?đ@H!mdÍß@=ű€üÍŔU¨LԓA@0H775E­?đŔU˜ž9׼@0aŽfő~Í?đŔU Háx/F@0_Ÿ 9ß?đŔU¨LԓA@0H775E­ŔDŸ„ě€Ŕ @O Ş wě?đŔDĆ)°¸ł@OľÜq/n‡?đŔDÖ䶗ah@OŽ`„”+‘?đŔDŸ„ě€Ŕ @O Ş wěŔ3đMôÂĽ@Kđ&Jˇ.t?đŔt'–k)@KŮ1t&Żš?đŔY¤ěęIę@Káv÷xęţ?đŔ3đMôÂĽ@Kđ&Jˇ.tŔEč 0ˇ&ś@MűQ `:;?đŔEš!c™)–@N=8]‚?đŔEč€o3ěŢ@N {ł!Mt?đŔEč 0ˇ&ś@MűQ `:;ŔÄçaéa@O&6“c,Đ?đŔĚÍř#@O ŹŹ^‹é?đŔՄG§<@O—%öĐö?đŔÄçaéa@O&6“c,ĐŔWł„ŃAnđ@L1čő741@ŔWĎ+Ź Y@L7m5ŞĹČ@ŔWÄł|tç@L-%żú@ŔWł„ŃAnđ@L1čő741ŔI0˘’ďdé@wĘfZ…?đŔI:Ďś×>Ą?˙řYās,?đŔI(=?cĽr@JvőMß?đŔI0˘’ďdé@wĘfZ…Ŕ_bvkE’@Płz1ŤTQ@Ŕ_F|Ţdič@P­Ř ŽĄ$@Ŕ_M۟>ÍI@P¸Çĺ)ś‡@Ŕ_bvkE’@Płz1ŤTQ@f}Łçđ2Ŕ1■ľeŔf}^}SWŔ0ÓiHAJ[@f~xÚD?5Ŕ0ßÇ|(I?đ@f}Łçđ2Ŕ1■ľeŔcü'2wŽX@K¤Œ;<•G?đŔdý9—o@K‰‘­ů0?đŔcýM^{`ł@K‘„9Ł9Ž?đŔcü'2wŽX@K¤Œ;<•GŔSşôůŽo@SĄOĎĈ?đŔSŰćZ˝o@Rű˜ˇH?đŔSÂo‘V|@RűęŚŇÁ?đŔSşôůŽo@SĄOĎĈ@RĄÁO6ĂŔQĽcËęď?đ@R}œb”ŽŔQ˜’äaҋ?đ@Qďw_O ÂŔQšhű:&ć?đ@RĄÁO6ĂŔQĽcËęďŔYG$Ž@QA%ÁpüĚ?đŔY#źAŠÖ@Q4Ë6?đŔY6žœž@Q6G‡Úî?đŔYG$Ž@QA%ÁpüĚŔI ţá~™?äˇý ň?đŔI+Dď?ߨeçśuS?đŔI uĺđVR?ŕ2.ŇW\Ö?đŔI ţá~™?äˇý ň@Xgbërű@A{łô>@@XnDc‡źx@AgŔ‰Ër@@Xs “—vQ@A|˙őňƒ@@Xgbërű@A{łô>ŔIŽj2Cg@Qzč™U˘…?đŔI˜c% a‡@Qmßřę–?đŔIk3?¤dŽ@Qs2#L:a?đŔIŽj2Cg@Qzč™U˘…ŔRJn$ű@6b ŠmŠź?đŔR9˜.††@6W˜‚¤Úú?đŔR@TŃřŮś@6j•ú˜:)?đŔRJn$ű@6b ŠmŠź@X–+fö"@(ŽĘIĹdm?đ@Xš‰ĄcqŘ@)Ô~–D\?đ@X”ZťŔ:@)ćžÓ´đ?đ@X–+fö"@(ŽĘIĹdmŔ8PCŹWłQ@0‘&֗ Z?đŔ8/藙Ăü@0žáäŐä3?đŔ8m<˙§@0¨ ĐŔq?đŔ8PCŹWłQ@0‘&֗ ZŔRĂö;}ŘÜŔG íU0‹?đŔR´5¸/‘ŔFú1˛”}_?đŔRžŕđSůŔFůtŚ,Żľ?đŔRĂö;}ŘÜŔG íU0‹@`ÔE¸d;3@ç,”ą?đ@`Ń´ŕ|j@s–ý -?đ@`Ô~—‚ Č@CŠ€n^?đ@`ÔE¸d;3@ç,”ą@-ąÄ/ˇ@F†ę¸ˆ0?đ@.*(;@EüS{ýŢa?đ@.RŒŕëü@F6,îœL?đ@-ąÄ/ˇ@F†ę¸ˆ0ŔVĺˇ:ësżŰ"ž ß)0?đŔVŢAuôĆużŐ  í?đŔVę{˙˘“OżŇU°ťŠt ?đŔVĺˇ:ësżŰ"ž ß)0@3ۡK•…@N2渞Y?đ@3Óhůˇ˜@NŹs~?đ@4ŃužU@N H~č?đ@3ۡK•…@N2渞Y@ăBx˘•@D”ňvzM?đ@˙ˆ.ĎőÝ@D„ě2%˜?đ@ĆŠ j @Cô:g Óg?đ@ăBx˘•@D”ňvzM@"CŠY#@OÉspÎP?đ@!?m74I@OǢĺôďb?đ@!ľ+™ŹRĄ@OžĆő˙ ?đ@"CŠY#@OÉspÎP@;v›­o1@Bă=΁Ý?đ@:Çk~)oi@BáQ˜ÂşÜ?đ@:ë‘R“ŻČ@BŘtűŇBŒ?đ@;v›­o1@Bă=΁ÝŔKŤ~x7(ŒŔNŸ¤ đ?đŔKy—ŢŽůŻŔN•ČąpCÔ?đŔKĄä1&„ŔNŽöżnŸx?đŔKŤ~x7(ŒŔNŸ¤ đŔRÔ9™ÝŔIe’kĆâj?đŔRŃ?§@zZŔIHë8ÝłŒ?đŔRÚž(¸gŔIUćŞl Č?đŔRÔ9™ÝŔIe’kĆâjŔ`ů7{aŮZ@LŠÎńK‚?đŔ`řęŢRM@LŽĐˇ:űĘ?đŔ`ňü:tÚ¤@L˜CË÷>?đŔ`ů7{aŮZ@LŠÎńK‚@0ŹŹčłLZ@Ez]ą_$x?đ@0˙żLtä]@Eu—ôńCŽ?đ@0ęNr<Ňl@E|Kść?đ@0ŹŹčłLZ@Ez]ą_$x@Y˙.fîŚ?ö(;N7¨?đ@Yń6ęŤĆ§?ö?dÄ@q?đ@Y÷ľ˘_Ô?ôß]ŘĹůT?đ@Y˙.fîŚ?ö(;N7¨ŔV˛]ŽĆŤ żŇ”>0'J*?đŔV¨W™Č,ˆżĎÇł‚Âí$?đŔV˛ťŒ9´ żĂnfŽ*–?đŔV˛]ŽĆŤ żŇ”>0'J*ŔUŻ¤ŚhŠx@4”M욙Š?đŔUź,á@4o4eńžž?đŔU´î„fy@4q5fČ\?đŔUŻ¤ŚhŠx@4”M욙Š@;YÖRO@BoˇI1lS?đ@;čš-‚D@Bf>pÓôq?đ@;0!ĹłŽß@BfműN'×?đ@;YÖRO@BoˇI1lS@_j-ěĚ]@ m/ÜďOé?đ@_b;Şĺ÷Ľ@ ů^˘5‡?đ@_bƒoŒŒ@ ęŠ8–‰?đ@_j-ěĚ]@ m/ÜďOé@&8X¸;Ü@@ć˝ÇcŹ?đ@%­(“›%@@ěؤ?đ@%ʖÜţÇ3@@ŰD;\7?đ@&8X¸;Ü@@ć˝ÇcŹ@`’ńâŕqŔ&Ś#9ǀŠ?đ@`’‰ÜGtŔ&2„‡ě˛1?đ@`šdsîŔ&XSc(BĘ?đ@`’ńâŕqŔ&Ś#9ǀŠŔRΤĆŠ0ŔH†^ĺtQí?đŔRÜG”§ąKŔHpďĘĆÁB?đŔRÝwK.ŔH UäT?đŔRΤĆŠ0ŔH†^ĺtQíŔUFaoĆťu@@“hä´$@ŔUG˘tŰU@?ĹřÂäČC@ŔUEqhĺźë@?Ň=ŒŒ@ŔUFaoĆťu@@“hä´$@`a%§-!Ŕ +Jcôqů?đ@`\1Pp=Ŕ x]ˇú;`?đ@`a`G=ŤŒŔ aŒ.rÜ?đ@`a%§-!Ŕ +JcôqůŔSŠp´vHâ@QoűçŘŽ?đŔS˘Že˜Ć­@Qeö/ňhţ?đŔS‰)(„÷@QfŮKž°?đŔSŠp´vHâ@QoűçŘŽŔ|ßć5ů)@MzU)Š}?đŔśaz€ű@MƒVźëB?đŔöWĄœÖĐ@Mw=tÖß?đŔ|ßć5ů)@MzU)Š}@]řÖl8…w@'čŚíŕ:?đ@]üœ5`ËE@'‰ČN)vŮ?đ@^íL˛¨f@'Ż´î§îB?đ@]řÖl8…w@'čŚíŕ:ŔRŇÍLŞ˘ŔIĐ9¤E?đŔRÇ÷a“íNŔIľ–*jÍý?đŔRĐ $ŔIźËaŘ?đŔRŇÍLŞ˘ŔIĐ9¤E@4ĽÄ˝äCO@Bđ;Äî˛Ţ?đ@4Ň~ŤŔáß@Bہ­ű>?đ@4ŐXć]GĘ@BébďL?đ@4ĽÄ˝äCO@Bđ;Äî˛ŢŔSŹŃĽšŢ@L7ľ7\?đŔSśzŢyŽ@LŢŠsq?đŔSŹLK5Kä@L >⁣§?đŔSŹŃĽšŢ@L7ľ7\ŔTt -QÚ@Kq\â…?đŔTn䏄@‚SŠO'?đŔTlFˆa~z@ô”#™AŽ?đŔTt -QÚ@Kq\â…@bâ˙TŽ|9Ŕ Ú Š™ ?đ@b₠őĚŔ!PŮć$a4?đ@băďŽßŽŔ!$^ fc?đ@bâ˙TŽ|9Ŕ Ú Š™ ŔR›á§€˘[ŔF⤯iޝ?đŔR’¤ßíEŔFĚÂô Ů ?đŔRí*Q×ŔFĎR$:œ?đŔR›á§€˘[ŔF⤯iޝ@RO$Ó͸ŔJ~żŠÖJ?đ@Rbď–Ć…ŠŔJóúť?đ@R\؝íˇgŔJÜ? ^ż?đ@RO$Ó͸ŔJ~żŠÖJ@0nŹWÝ?đ@_ţýýŤsŔ k~ áă?đ@_űÖŢ.Ŕ @đ? m/?đ@_ńĎÍt^ĚŔ >ŹWÝŔQĽ‡ŃN›@ObüLą‰Q?đŔQź0ę}lç@Ol9ŹŤ°?đŔQŹ|G}Ź'@OWĘT+ÔR?đŔQĽ‡ŃN›@ObüLą‰Q@c-•5ŮŽşŔ;şYž&h?đ@c/ŽHM̀Ŕ;ƒ 6NŠ?đ@c,ďbŤŢŔ;“,Éç?b?đ@c-•5ŮŽşŔ;şYž&h@8ş.ŮutŰ@Bűţ.Ţ*?đ@8ŘŠi@BĺËş~ă?đ@8ęy˘ÖŚ@BďUrŸ?đ@8ş.ŮutŰ@Bűţ.Ţ*Ŕ`ůÄӎ@Jü˙]ţ?đŔ`2(MÜä@Iď$°iNą?đŔ_˙R#mďr@Ió›z­‚n?đŔ`ůÄӎ@Jü˙]ţŔRYFŔJ,ůćo[?đŔR6óš=˝ŔJ‚ţáҚ?đŔRW˛ăŔJ7pov§?đŔRYFŔJ,ůćo[@^mŃ°‚¤żŔ%'ĘöƒńM?đ@^z?¸_i#Ŕ%Ü\qz?đ@^v…—đÉpŔ$ń 2úM?đ@^mŃ°‚¤żŔ%'ĘöƒńMŔPž6XJŔK\čî?đŔP"˝ŔtFęŔKcşi/˘?đŔP Źi2ËŔKd¤ԓw?đŔPž6XJŔK\čîŔ_šY&ć1Á@HëÔߙ–?đŔ_śe>@Óx@HŘnVŹ•?đŔ_ŞeŽ¤„Ó@Hᒟˇ:ń?đŔ_šY&ć1Á@HëÔߙ–Ŕ`ŠcĆüi@LY‰Ú‚ś?đŔ`ł•™UçŠ@L$ąCxX?đŔ`Ž×Ĺfx@L̓ŕW?đŔ`ŠcĆüi@LY‰Ú‚ś@-ć•ič>@FœŻ}¨uŇ?đ@-!ĹÆ8Y@F…§÷Ţĺ?đ@-h!Aüç@F‰çLż=?đ@-ć•ič>@FœŻ}¨uŇ@Z§¸ë\<@Jń•ŒŰ@@Z$)žŢAü@JÚu%÷Ś@@Z!ŤëŽ@Jśąń@@Z§¸ë\<@Jń•ŒŰ@Cܗˇ…Ý ŔççŁڑ?đ@CěîßrĘŔ8E/zŒl?đ@Cۍ‡•ŔuXÓÄŘ6?đ@Cܗˇ…Ý ŔççŁڑŔ`|ź~:>@JÚŃíšI?đŔ`#RF i@JÇ^椐Ô?đŔ`…ĎÎWk@Jʁ ´ ›?đŔ`|ź~:>@JÚŃíšI@X†0"[–@SG ˆňŞČ?đ@Wű‚ވšÄ@SAs•äĚm?đ@X!ćIŠČ@SL—–Ŕ“?đ@X†0"[–@SG ˆňŞČŔNC4źcu°@&°!ć$´-?đŔN\Ľ–šĂ@&|K/řM\?đŔNN+ .R@&ySĹmĽÍ?đŔNC4źcu°@&°!ć$´-ŔRĎĘč´ˇ ŔH­a˛č?đŔRťžíM÷#ŔGűŐrô\?đŔRĂ°@äßŔGúܢJŰk?đŔRĎĘč´ˇ ŔH­a˛čŔIjßNIJążâ&Âߓ.Č?đŔIÁx5ô6żĺџáŽî~?đŔIp˘­ő’żćnt__u?đŔIjßNIJążâ&Âߓ.ČŔ`L zr@K hż?đŔ`SŹZÜÍ@Jüę= y?đŔ`N?'r,í@JöKWĹ2b?đŔ`L zr@K hż@]Ü´nú_Ŕ ÜV|éŮ?đ@]Ú2oě¤Ŕ!=ű­¤ß?đ@]ŕPî:HDŔ!#Pćš.Ń?đ@]Ü´nú_Ŕ ÜV|éŮŔ\ţB„ŻË@8‡ ôA™?đŔ[ôk?ßł@8k)ně?đŔ[ö(ô†Ä@8<¤ŔŤ?đŔ\ţB„ŻË@8‡ ôA™ŔbDAöxNŢ@N4Ą×gkŽ?đŔbQLü=@N1ˇJB2?đŔbK0RXuá@N*6 x?đŔbDAöxNŢ@N4Ą×gkŽ@döۧ‘Ŕ.öÎIv•™?đ@düÉNąNgŔ.ÎŐĹŰč?đ@dřĂ-IÓMŔ.źëu˙ő?đ@döۧ‘Ŕ.öÎIv•™ŔU,ëY@=ŔĎö-Żé?đŔU;ˆFĄ t@=Ś`œäds?đŔU6?–}Ć3@=Şč[G?đŔU,ëY@=ŔĎö-ŻéŔY"Pˆc\@S.ęݒ[?đŔYI\•"Ľ@S*‡:‚ß„?đŔY2˙;Ë@S(Ík;Ů?đŔY"Pˆc\@S.ęݒ[Ŕ.ÎöľÂ@KÚÂŔŹvÉ?đŔ8¨ré¤Ő@KĂĘ$ą{?đŔˆŔb2h@KËTöRX?đŔ.ÎöľÂ@KÚÂŔŹvÉŔW$ޝ2Q˙@FMŐ¤¤@ŔWë?é-@F>ďócăž@ŔWN[°lŠ@FE^ɧżN@ŔW$ޝ2Q˙@FMŐ¤¤ŔdôßmŒă@KłŽ|+Ě?đŔdq‡MP@KĄý0â =?đŔdo€ Í@KŸäŞ#ţ?đŔdôßmŒă@KłŽ|+ĚŔSŞu=f@7ŤőnąŹq?đŔRöP Äjp@7†›ƒš'?đŔRůrA3§—@7›Şźb;?đŔSŞu=f@7ŤőnąŹqŔS|Łł­Čţ@6MŇę?đŔSpÜ­ŻĹŔ@5ü˝:ńLř?đŔSr˘U ™@6¨_U?đŔS|Łł­Čţ@6MŇęŔRiŇeߧ*ŔFŕˏd?đŔRh9ňó”fŔFɑŒW1n?đŔRp­ÔĹşzŔFĎ$1{=?đŔRiŇeߧ*ŔFŕˏd@c-ĽCnœŔ;ZJ,œ W?đ@c-­Bb؋Ŕ;$zÇK…A?đ@c, Fě‡UŔ;3ŔCmzP?đ@c-ĽCnœŔ;ZJ,œ WŔRĺžńU ŔHXďĹćPË?đŔRŘv^YŔHG|ôŽÎw?đŔRăAS´š~ŔHG÷Úń,?đŔRĺžńU ŔHXďĹćPËżńčŠn:¨@IX_Švř?đżő”Ă+Đ@I\‹É(Ž?đżô‘ÖäYß$@IOőTŚ›?đżńčŠn:¨@IX_Švř@:[âňŚ@Bזk¨Éř?đ@:˜Ľíz@BÍ=âtl?đ@:9w.Ӄ@BĘďěOŇo?đ@:[âňŚ@Bזk¨ÉřŔNť—Áe÷?@LvĂ˝ Œ×?đŔNČ|Ŕ]qŇ@L]†“üc?đŔN¸+úě¨}@LdPş}Ĺ?đŔNť—Áe÷?@LvĂ˝ Œ×ŔRˇâž–źžŔJ­ţ— ?đŔR­¤2kÎŞŔIůĹŢď|Ŕ?đŔR´řM˙œBŔJK=Ö?đŔRˇâž–źžŔJ­ţ— @b˛÷势őşŽ :˘Ü?đ@b´’}ţÚÄżřkGůrö ?đ@bś2=FRœżöű[‚#§?đ@b˛÷势őşŽ :˘ÜŔM˝3ŠějÔ@*'“8ažK?đŔMĂőRëjh@*y$Wń´?đŔMÎ|+˝]‰@*Kä’>…ă?đŔM˝3ŠějÔ@*'“8ažK@_ÎÎ|‡Á;żĐŸ‘źóU\?đ@_ÇüŠ㋿×ő*BU6§?đ@_ĎŠš}eżÚfýqCŤŽ?đ@_ÎÎ|‡Á;żĐŸ‘źóU\ŔL.@h–@GL[ĐŠ?đŔL.:0ů ]@GsěŠu?đŔL$˛ŘÉ @Gw“d{äô?đŔL.@h–@GL[ĐŠ@cŤBÉťŒ€Ŕ Ó0ŸXhä?đ@cŠi0ŞáÜŔ!5 QŘm?đ@cŤÁEAîŔ!lÂÖ@?đ@cŤBÉťŒ€Ŕ Ó0ŸXhäŔ`u\[aô@IŰŹť/ ?đŔ`ĺB¨ş@IĹ g°Cţ?đŔ_ű-űŘśĆ@IÉVZ@‡$?đŔ`u\[aô@IŰŹť/ @F‹,g?!°Ŕ)˘7ýp?đ@F•umС„Ŕ)ś0UweÄ?đ@FŒhRY˛™Ŕ)Z ŸßéÚ?đ@F‹,g?!°Ŕ)˘7ýpŔQ<'Ő^Ż@(šĄnŰGŢ?đŔQýÄž@(Kąü¨éŽ?đŔQ>Ciúč@(dŹUB‰ ?đŔQ<'Ő^Ż@(šĄnŰGŢ@4ąÄ ŽĽ)@Cl;’jDĹ?đ@4•çÉ c4@CZËóž€4?đ@4Ž)Ű}@CU|ń,$ö?đ@4ąÄ ŽĽ)@Cl;’jDĹ@aęX5˘ŽGŔ Ŕoaj˝?đ@aďYϐâSŔ ęúě˙î?đ@aďÇîlJŔ Ăk@ťń]?đ@aęX5˘ŽGŔ Ŕoaj˝@W˙át1Ăż@SW‰É}?đ@Wěúp(0@S Ýĺ?đ@XŮÇŁĘĆ@S Äiaeň?đ@W˙át1Ăż@SW‰É}@aŢľN7šŔ']ŕÄ ź?đ@a Œ)ó)Ŕ''ňcçb@KuyĚőz?đ@ Ŕ 3Ÿ @KrF8NÝ?đ@ ”‹‚œ@K^ř-E@`Ş::3•ÇŔp^`^ 2?đ@`ŻUg”7 ŔńÖqÎÂ?đ@`Ž5ŽPĂqŔşó~k›ű?đ@`Ş::3•ÇŔp^`^ 2ŔLź"?s!ŔP"ćEů‡?đŔL‡ËűOŔPëcg,5?đŔLĄHŰ Ć)ŔPś ţţ?đŔLź"?s!ŔP"ćEů‡ŔR–"Nሇ@6ÓćüőC?đŔR‹žRľÜ@6ľ.ÁƒŘ|?đŔRŒkó×@6ÇWe÷˝`?đŔR–"Nሇ@6ÓćüőCŔYLaaD˙@=xŕşpm$@ŔY@,´˜Í@=Ôwš@ŔYKáîß@=Ž$‹"§°@ŔYLaaD˙@=xŕşpm$Ŕ^ěSŠVë @HŒKsŒt?đŔ^ߓ٩Ĺ3@HxvŘDî?đŔ^â3§ţç@H}˘cđŇU?đŔ^ěSŠVë @HŒKsŒtŔ_Rx4znŇ@I7)Í•f?đŔ_OžH ŠR@I"őH¤?đŔ_HBKPbŰ@I&T„Řěf?đŔ_Rx4znŇ@I7)Í•f@*ţS+ Š@Qľ­0L?đ@+Ÿë^BĹp@Q߰ߐ?đ@+=í żä@Q  K-ů?đ@*ţS+ Š@Qľ­0L@@*+[š@>eÔŒ'â@@@:ŽŰíę@>@LĺxŘ@@@>ć f@>Lď“aÔC@@@*+[š@>eÔŒ'â@X‹Ňí~'K@&äůş Ď?đ@X‘”R$"|@'=áwŤç?đ@XwvJżp@'(ęxÉü-?đ@X‹Ňí~'K@&äůş ĎŔYÚj=áT@JŇ´×NXo@ŔYěΧXQŹ@JÉu5„@ŔY䯐Ô\˛@JĆU‡Ĺw @ŔYÚj=áT@JŇ´×NXo@Tr­”OgŃ@RŘi‚Z˙|?đ@T…á-÷U@RŐmˆhc?đ@T‰ąF={/@RßÁœ8Ž™?đ@Tr­”OgŃ@RŘi‚Z˙|ŔF7XĚ| PŔ5†`eޡ&@ŔF<œu‹á…Ŕ5dź"ľ˘.@ŔFFÔADűůŔ5`…w˝ÜR@ŔF7XĚ| PŔ5†`eޡ&ŔRá2€cuŔH˘–îÉ˙Ÿ?đŔR؉ Ř!ŔHQF˛ 2?đŔRáó˛ÇŔH‘ŘËA]?đŔRá2€cuŔH˘–îÉ˙Ÿ@c‡JqNćŔ%CŠ'ěŹĹ?đ@cd›)–DŔ%^^Şuaž?đ@cˆŸbhŔ%G–ĘGŮ?đ@c‡JqNćŔ%CŠ'ěŹĹŔ[ěId8“@GSÁę@Ŕ[ĺ0ŘšA@G=ĐC0R@Ŕ[âqNAT@GB;‰źj@Ŕ[ěId8“@GSÁęŔS,Xˆ† @AY˝YÔĚV?đŔS;Ÿě*ë<@AWŽŸoƒw?đŔS7ň§,ľt@AWđ…Äév?đŔS,Xˆ† @AY˝YÔĚVŔW´˝U/@=Yę쿀?đŔWž:‰†@=7šfL­?đŔWˇöś(’@=@á#ź^Ľ?đŔW´˝U/@=Yę쿀ŔP8x÷Ľâ„@1¸g5`é?đŔP,î.čÄ˙@1śĘaŐ­\?đŔP-üËx“§@1Ä# 㖠?đŔP8x÷Ľâ„@1¸g5`éŔ\˜mô7*ö@AAg‹–ů@Ŕ\ČúŸ˙@A/úŠyb@Ŕ\rQŕÜm@A4Ą;ťÚ@Ŕ\˜mô7*ö@AAg‹–ů@@hăjfżßiç>Ůśň?đ@@źCވżÓÍ/+TF%?đ@@”.sSŸżŮťŻdŠ?đ@@hăjfżßiç>ŮśňŔb8–15”˘@NMŔŔ?đŔbC0Ď@NEşRâx?đŔbAgxm@N@J<†!ç?đŔb8–15”˘@NMŔŔŔR“ă­ƒ‚ÉŔFƒ<‰Łí?đŔR…ńŚÖpŮŔF~ä$ůŤ?đŔR‹>+›zŔFv ˛ąFđ?đŔR“ă­ƒ‚ÉŔFƒ<‰ŁíŔ_RĄQľřr@I$.ďH5;?đŔ_PďŢÁđ@IzăKü?đŔ_LCŁ×PŽ@Ižqˇ ÷?đŔ_RĄQľřr@I$.ďH5;ŔVâ‡gœÍI@2ÉÂŘږ?đŔVíŘŐ8żŕ@2śŞźÍÝŮ?đŔVéŽ^Ě@2śq… Ď?đŔVâ‡gœÍI@2ÉÂŘږ@J .n„9ë@(s“7˛S‚?đ@J!ŃcN>B@(VŽxŒ]w?đ@J /OąŚ@(mŚMĆźU?đ@J .n„9ë@(s“7˛S‚ŔTú°¸G‘;@A3‹Î`Č @ŔUŞgd‰@A"^ž°2Ľ@ŔTřĆs>‘Ÿ@A&Ęâu!˙@ŔTú°¸G‘;@A3‹Î`Č @8şLŒ—;|Ŕ=úúĹŰt@@8Ůűţ×41Ŕ>Ɏ×ŘR@@8Úö‚ń5Ŕ>źNŇ"ž@@8şLŒ—;|Ŕ=úúĹŰtŔSčyHťĹ!@6ĚŠőňĹ­?đŔSÝçĎ#l@6łşâö:1?đŔSßބvmó@6ž:ČiŽÇ?đŔSčyHťĹ!@6ĚŠőňĹ­ŔX6şÖűC@<î‘㊉?đŔX><ŢB˜Ą@;űu.ďŇo?đŔX;2żRý‹@;ý"ɗ—[?đŔX6şÖűC@<î‘㊉@*2­VÇb@QČ<ßţ?đ@)ŃVĚ@@Pü=˘˙Ç ?đ@*÷s ‡Ô@Pü˝ÄZs?đ@*2­VÇb@QČ<ßţŔS“ěžĐŽĆ@6g|źXÍ?đŔSŠźľŃň‰@6Tř:ĽÁú?đŔS‰ĂӅۚ@6cŸˇN+?đŔS“ěžĐŽĆ@6g|źXÍ@X’S3ľ`Ŕ@%tW¸šë?đ@X-ĎŰzž@%źf’:ß?đ@X‹ůš?ĺÚ@%ŞÎj-?đ@X’S3ľ`Ŕ@%tW¸šë@XUúy|*I@q‰ŘR?đ@XP:ĹŰ@{Ă …?đ@XO:\‰‡@s+š–?đ@XUúy|*I@q‰ŘRŔ]H„o˘@LąwO~Ň@ŔŽnŤ­é@L Çëo@Ŕř‚¤–ş@LĄ(üAÓ@Ŕ]H„o˘@LąwO~Ň˙ř˙ř˙ř˙ř˙ř˙ř PDL-2.018/Lib/Transform/Cartography/earth_day.jpg0000644060175006010010000027234012562522365020022 0ustar chmNone˙Ř˙ŕJFIFGG˙ţCreated with The GIMP˙ŰC$<'$!!$J58,{ł9:ŒxŁsm/Ł 9C:›ůa6źÖÁćšuüžFŻ”ăţŕu•ćęľżü3ÓĆÍ?îŃdú™V‰hß}XÔż´€ôƒ’ţaIŰĹ(öŮĹ˙Šć„zěr”˛¨gÔř„ô(Że˙P=Ŕĺ‰;ů°(?6™ŻƒŠďáBß}( 9(ţŚ—Ő™yąŽrGň!‡6Ü1Â-˙–)ŸÇÇĺý˘ÇóüË˙ľ˙ąĐ6’śéÇůž4žXĹżómýÍ||5˙r2úΙ:}F$ükE]NŽ3Ő˙Ľ7ý€ąępMľŘĺ\ԓŁjIđÓ9Ţ)*ĐŇ~qľţ†?•Á'Š¤×Ń$ xôý.9)Ćă.Ňďů.L]6HišŒŁĎ w“ŠčăžP”3ćĹ(đńËýĆÜ3ĹEG.ImVăËŕ@<ŘeÔcsţfxçů~9_ߓkŤÂňü-idŤP–ÍŻŁ°3ŻčžŽ…Î×ËďóĐ ĎÖfɃĽÉ– Á_Ď*Oîyý;ŻËŐôńÍ,5:tšŻĎ%ĐúđĺęşĚ2—ţ9cý/ţ(ÜzŻ‹u—ď‡ßúX<Ž=UüDß׏ţżčrqő Kââé3W[‡íOű Ú\™y!nI}Yň:žŽpžŒ˝7UšxôÎ?ş:ôš?œoŕÍźqć2Ç,r˙Eű Ľń Ő§kŰsŒúޞŞmô?ö$p7ľ5żyKČ]QŇňe{ěŢWkŘ‹ŠĂ*ŠŚšťÍaki§ěb=$wŒäňCMT’żĘ5’Ź’pŞĐŇODźšÁ˙GËÉęޕ“4Ł.‘ĺȝ7đ”÷úî4>Ö,¸óăY1dŽH>%hŮă‡MÓä‚R顸ߏÁäőU‹¤ÂóË.\p{JXÜÝ7ôš\ôďYčc:}g[*ç⫏úżÉú$ŁŠ´•]ąf… ]WÄÍ,oXWi8É{4ßîu„Ôďj§ĺnA -É%nţÉ°(9KŞÁsËëzš¸d†Epœdżĺv€$¤˘›“I.ě $˝WĄŒ´˙5ŽMsĽęŻÁ—ęţŸÜşźKŮşŽKŞ= ů‰˝3ŠdžOxÁ˙ŠĘĹ~Ÿ/ŐĐúŸńŁîâKřŸĽŮçęgëRŠŻîzqzďE•4˛(ÉLš_żƏ¤“Ôzä1)hXe%ç:˙K<ý7ń.)śłŹqküł˙z4Űďć?]čdžN§e˙7ąeë]6…đóôů$ű|M?écT} yş~­g‹–”’ń-GHu§7É6šVM Äň¨+u÷tyçę]&;חMr鴟‹°yżâ=ťęqŞVÖ­˙ĄŇOŽŁÝ×÷.¨ôƒÎúî—jĎn–—vülUÖtňŠ’ÉińQ{“C¸3 ČžW˝]5Ođh9žŁ m<Řírľ-cɏ,ucœg1v€ĐRM´šmrŹ t›ŤöG/.unßýę4şČÁ[‹kţ]Í>ˇ§Šˇ•~ÁËâ`ÍľÂIt¸ÔăŽ1’áĹ$Ŕěyłő¸ń7‰—üÝŻŻƒˇĹĆ˙ů‘üœ3zO–AFuV¸Tgë3E,˜^8˙š.ˇü×Hç9çę—t˛Uýhĺ/O“’iĆ*;'˝}ÓŁ“뼂U)7+ů˘Ó{yácś~“ŞŒÖN›¨SIo‹fL__,ŰMŇkżĐ\´>ĚúĚŤ$á“. <ęœ[k;G¨Ĺ'˙5Ľ˙֏“ń2苖5 W*ӗŐÝłX楆MőâŽőˇoú“Ëň}'×/šZŁđâéËâA}ůŕď îQ‹Qr‹ďÎßd~]Iḑ/ń%ĺŚ˙sŮ ďĽßx´÷k…ř_âéú‰â2űŞ\™:ÉÍü(菇 ~űßú~š}vh),ÓŮóţ§ˇ^HG‰7íYQœpÎŁť”Ÿœ“˙DvÇǕ歞<žŁ(ÍăLJ$§áoţ‡ę\RrÁĽpő*˙P>°>_óydŁ5/–_O˙ŘőGyĹKůšîŞ?őÔÚ]ÎyłăÁË5üœçŃbÉ-Y¤ýäUŇôřä§(ŚăÛ˝?K˛ĆQ‹„ňdSÝ8ÇoÍRű’pÏžEA~ŠNUEË×t¸aŞyá^Îßá%ęý—ţ#—ś‡żä Ác×ţ)8óňÁ$ţs`žf˘°áĐ˙SÉťü/÷8âő.‘ÇN,9+Äqąčiő8éăxă/.ĽűšGHbĐŁÍF1TŁ¤—Řĺđ3Ź‰žł.›ý:#ţĆńô˜1Ď\qENŤSV˙'`&ړw}‡Ë5[Jžĺ R¤A4E;JŸ°Ňť*(WȤůÜ˝€Rśé[î(rb†USŠ’÷4㓧‹¸ŕğ•tÓ­Ý.ݑ Ÿ&N˘SŃÓăQJď&KŻ˛ďű<žúė_ÔĺÎŽô'˘?…ţŹúŒăe,šT_ŕů‹tOJé#/xćľ˙ô–ciˇéAůé˙ôĘpÁ‘Éż™:U÷=Xż‰=?.\xă,‰ÍĽźi/Š|jmőÁÍő8mćƒçćFWYÓJ:—Q‹OhĘť—ó8?ý|ýčóćőOÁ‘ăÉŐAIvÝ˙bęh>wüwÓ.ż›‡á˙ąĎ/ŻôPÁ9Ç>)N)ľŰżn6ú ü?˙zžŚţ4iž4-Ž Ö}EÉ7ÖäUîoăŹů?Oęžż‹ Î°c‡Ĺȡ–ôŁíő>zţ+Í5>—^cüţ‰IĆrn:Ţړműńšíč?‰'šɅ´G‡ßĺ5á$M×ׇńd]ę隮*W؋řś=ú7öÉ˙C׃E8Ç1Ę ms‚wő:Ăr`ů°J .J?żƒ;Çń{|é˙˝ŃÓ-}ľKeţçüYÔŽz|Oîϧ4ąĽ/…Ójżš.§řG.‹I&ᗣ‹rmŚŁú}‰ĺáŞńŻâ^ˇ2—ÁÁ•[Ő%ˇö4ýgÖqb†Iaé§ńNßí#ěĎÓqJ2Œ0bŒeiíšz^“ůXÎńÚM8üąŽô]ĎÁň°úżŞćĘńźqäŻÓ7Łń|ŒoŽÂR”ż”„§sŽßšô˛őYąĹ9Ź–Ÿ˙§ţ´x3úˇGŠbËŇĘr›Iɤ­ţ/’{úW“7ŠúŢlňéĄ,x§ŐIEţíţĹţc×˙Cę1Çłšăżąő0zďŚ95OšuĎë=<1ęĹuŚŢŽÔ˝ţĘçë}WŚË(>Ż3iďSŐżÚĎ.nżŽÍ%,^fükjžÇÜőYębÇĐâŠuΙÚ>[ę\ŠÍAZů`Ł]ü*KęÍOřŽ ­ëœ™Ď(­šřŻîyÖlą&IÇĹIŁÓŐâQqřiˇŢmÓťŁËĽĆ;¤ďŢčŇ;ÇÔzě{CŹÎżţă9dęs咖LӜŽîR˛K,ä÷“ĽÂˇą–ŰďeѲM˝Űśf˝ĘŃc)FWâ×tŔÍ4üŽü{.Ü4ˇş[[Ş°]|3J1–M1’Iđ屟b{1tPÉ(_U)>-ˇřŁÚ˝*NX˛Ă5ržÚký~ÇÇmˇmŰ5 Ů`š†YĹ>jMY,ŁęGŇňĎ$ÜĽ wşŠi_ŃlzŸ§tŞJR뤝۷§ďî|?ćsęRřŮ5.§hŻŤÎŇO,š]›˛jŤéfé–i¨`ęÖDăŰ%Űç†ŃÍt]SÄňC,œRÝÍR÷ŁÄúŢĄĹĽšI>RÚÎQÉ8´Ôäšâ™uG×Çé‘n˛k“žęMl×ÚݝăŃtћn8ĺşI¤ëńçđ|EŐgé͑/ LëQę!ɤˇŮľż‰Ş?Eü˛nřkLž•âoW?÷FńĆX績ňÉ(ľk˙ĽŸÁęÝF+řă\”żÄ”ŻotϤżŠU§>ƒiňĽ_čfăWošŠYňb†H,‚uŁ6­U˙Ó˙SÓ/ŽÜ\dĽ˙Ëq{ýëcóQţ'K-ăčáŠ-ŰięoűčúÖ>ŞQPëçŠJ›K ýŒÜiˇŘĆó¸Ă_M­ÔeŤKýĽšRů˛8ŞŞQK=Ď?QÇ- rŠÔę2q”Sđ÷G|şĽŽ $!âZöŻ&tŽÝ<3Áäřů–Dĺň|´Ň÷ňv?7Őő]GO(<~ŤŽM:jm%ýˇ>gUë~§ŇëĄ%ă_ěkĆÔŰöŕţy/Yő)=úĚżiQË'¨ő™+_Uľ˙ň2ütŰú>¸ęÓŠ_‹<’ő^‚Ó.Ť]évę™üőĺË))K$Ľ%Ýť3{—ă6ţšłczjIęáŽÜŮüŰU–0řZ?Ęäé}żéšz/PŒąËhI•źëäfáŁoŐíYň2t‘ÇbÇ×ĺéâ˙D~dë¡ţ‡ˇĽéóâǧ'S9× Óoö3Ľv­ž8żŁěn7ĽjižôŠ“Ž¸J6ăj­r.‹6MżWÉ9(ż–tďn)˛Éąö'&˘Ú­źłŒg“"œu$×őc§ýĎČáőLÎçÔšĺƒ˙.§.9ůŻÓz÷ŚNN“ĂĽRřŤjöJÍ\,Mž–L˛KCϕ=:›Œ#kňYő‚Yf—TßáQáÉęţ—´cž\iľąĺ~ĽĐ)CxĘ˝Ü×îŤbjţ}ü2É8\ô§áo_šŠcrç$×ґůŒžł$ŸŔŒcWĎ Ň^ëĘě}ƒ?OŸ§ů'-Ó˙eűËďšĎÓĹÎ=BÉŤqÉfżŮ›éz‰őŒţV9+RŒďíT&OüŐ!ąôČçéÉ/Ť?=ŸŻő,š“ĂQ[čUű:l]tçY$ńA=ç$—ţäÚéöŢ\j.O$tŽöEŸ)ŤńÁńeŃő]GQQ’’[jÚŤěuÛA&Ţg™żčÇ Ż¸”}i<‰üąOîc#•&ԯ•d|ézˇÄ’PY1ŤŚô§GŤ[‚ Ać–IyP‘wK­N6â“đîLBo#PXŐ6ů†ČőC$'ú%ôf3ĺ–(Üq9ýTHGLh§Č~Š›ăSQI?š+z_śçÓśhŠBIűZ´6.\‹58ÉŻcžŁxOgMYđˇK,˙R9eÁŠ?â,Pľ˝éßö>‘Kôäœo–šg‹'DÖM°çž˙ŠÎ.˙'ŻVŻK…%ËŐÇٛ}T\SÇó&ŽĹƒçOŇfިmý2¤˙mĄŇĂ>8¨dÓĽ-Ť›9ĎŞÉ Ţšě´;ţçXäÎ×ߖŽżZzŽämâË(_+”Ďň]ODľÇ,üTűUdœŰÇ(h•\Z“ßö#ő'y5ŤÚۍFŢŸ­ÉIfříŢÍcş=‘ˇŤjÁ6šůáÁRŒĂRž&î˝ţ…˙ÄG'Ęő¡×KńE˙á¸ÖE8dËťj´y2ő/ǖ,žĄ%ĽÔĄ˘ŠýkcčüYĘ/CÇ­MŮây0Jn9°áS|ˇoěƇ_ä°ő8!Yœń§q’§ˇÔăŐĎCĆ82§7k$bŠ?mÎÚz™ăӉü8×ËŚ’ţĚňΤá‹Fmm|ęYžëŰzbéćőd˖.R˝RIŻďgnŞ],%Aăj<8ťLú8ş8E¤úK_óIlg?G:ÇŃĆwĎÍTfAđóu/2q„1E>ę'^Ÿ ‡ÂĎ9- ­UĘün‘ô˙ÎŠŹ<]ď\×ÖżĐGŇ窼ĄÇ›Ş&—oĽŽxçKÔ˘ÖÍ;+Žv<řXdX2Ă %[oMŻÂ,˛trƒ–Řă§ú˘âŠ#/S“řšT9ďýɓIËiŇ˙Ô˙џ'Šţ#čúiT%<ӎҌxvżąńşâ~ż$ĽđĽP|*MŻšŠ§OÖźx°ÁϨÉďŞ_*üžlޡéřSŒ:œN^ëö?Ôu™úŠ)gÉ,.íœ L?SoŇC×痨”łĂ¨”Wt—Űţ§˘o¤ő8ĺ–xóę†úd÷?(qvzý?­]&xĘxąäÇ2–4Ý{6.Űőxş~ƒ*OGP•_Íľ›Ĺ?Cvă<+§Ş_î|źÄ+œ”đ†řRŒZúRGŇčzŽ4nş,kÄrSülsń×Ó[z1zŻŚBK,ĐMöŒ]cßĆjă$ţ‡ËÉJŐ)ć–4ăťJëězpuޟđÔąfƢřˇWůG´>^ˇéфŚú˜|ŽŤťűÇüAé“I˙3ĽžÎ,jŽßL\~§ŃeuŤSÓ Âi8J2OşvM ™IŽ"ŘmE[tŒÓm7_cÎŢW=ín]Ł%(ĘŁOfîŮSoŞuRÄĽ‹őWĚŰßŘóŕőĽŽOX㤾R^whçÖ<óęž8Šžt=[|]Da—#†ięßéTţ›ÇŐénóeęăqÔĄ*zŤşěLŢš‹GNŐĆŽŸíýŹđu™cÓO.7_üĚj§ôušđă.ŁŞÎĽđçKvŠ´˝×ŕԛö?gŃzšëVŹ]6e ­Rq_ľŮŽżÖz~‰N.Kă%jÚĎÍÇŽ‡CŠ&9duňž˙J´|žŁŠËÔJňÉIůĽ“SoˇŸř‹6Lš°ĺŽ„Ô”2cŢüZ=Ëřˇ§ŮK§Éu˝4՟)Ż›~ˇ'ńnKűˇŘ˝7ńGMŁüydžŐšůŽ?YőeS]^F×i;Oěz%üEęoŒń_LkýŽ™­Dń‰m}'ëţŠ˙îŸ˙dŘÇüwÔ­7ŐMűRGĎ`xĂot˝kÔ&˙üVHý$Ě˙Ĺ}A˙ůÜ˙ýěńPƒÖýOŻţw¨˙üŒóäÉ<łsÉ9No™IŰfS*ľÁt-ɤĽmpŹš_)Z ÜßĆČ­)´ź-G\ŸŸ¨Çń ń(Ý|ůcřlű7đŽi8K'QšNJ+‹đę™đŕóeANMďŚ*˙c×úž6§/ćTRŰVރ7­Gčń t˜ćŢ\ů˛Aťp”Š7ö=ý7ŚtÝ#OÉ íń$×áş?+üçZáeÄŠ^Š[q}šjŸÜú=XÔtÉÎ1M5yg&żö9]ţ´ý*TP†9O,ň^ŃĽuűžŽ—ÔĄ–2žL”ŻeĽ+ú+lΕíʲ|),.*}œ•ŁËƒŁË Ň͓;œäŠ§ź~ÜúXĹÓäÓ,YeĔўlŢ˝ŠXĺpÉ >$ëc6Č>¤żĂË:‚÷Igę=ˇĽÇ-3ę1ŠxԎќfŽR^S°(1<Řąţź‘mÝM5iÚö%ŞžF“ňՁ@éZšo˝ ´š]ßą@2ÉVŠ$ß ËŽ-ŇiżPKňP=‘ń=nX.?âIeŻÓý×`>ŰIŞjŃÎo “Ç7Ÿôś~5š>˙‘Kú’ű#k§í>.ôFüŃćĎé7Q“^U9;áÍŃů˜uYń­8łd‚ö›= Ô:)K¨Ę÷ěë÷PÓîő=IâXzyĂ$żJM~ç̗ŚőQš‡ÂRů˘×ţ瞼ÔĆ´ĺŸ˙Sżî}ŸŐ˛Ş]N _ć_/÷,˛ŒGHá_đŕN›’š3Ŕú˜Á´Śš{ˇľ_š>úő’MGăFßăňnpéTž¸áRĺÚVo‡nŽâďý $‘Ŕ§ńá OĘG,*Pk5'ĘŐ>˙†zĚÎzbڋ“_ÓJ$ş\󕼺bů„}ÍĂ”’•­—řsşպˆeŇşu‰7łË|Ëęš%-5 äśoű“pÓß Y#Ęy#ö†űý‘“HORÉ5ť–ÎĎ&Qɖw9ÖŰăľş3ZřŮ㏠u6ݧ’KžŽ NýĄ#MÎI˙U1ĘZÜ[Ő´Ď<3e’ÔĺŚ2ăD“ŻŘÎLꯏ6߲´fÝ{ňF_Éś“\§TrÇŐ`“œa8\_Íż2eՉĆyuĆ[SŠýÎXý?Ľ•aÇúţÍöĄ5Fç— /ńe'I-ŽűĄ?‰SĘ×5˙SŽn—Ó放\ׂŢţǗŚč×OÔ<łË—4ť,™)'ô_ę[×Řú7:QŽvŻmęјioçę%+á)5ýęQ]F%.Ł¨Xaő|?•5áďšůŹÝ>:čóeĚÓćJ’EĆLžËÓö“ęú, |WđŰurťgŚ1Á‘|ą„—}‘ř|>‘Öezn nd˙Ôú]?§céääńdÉ4÷ůŢ˙m%şŸgoŃf†b”’n“za-ţ˃ăuŘ}7ůLËŠ‹éĺŚâž˜Éż˘çđrë%üćŒ_Íd颣oâä¤ßŠ_ÜňËřg<ęxsâË˃,×ę>ÔTڄ›ěÚŁ4}œżĂ]|-Ć”WüĘ˙ÎÍŇĺÁňCNőMďřűe•—žˇkKŤ­ˆhÚ@&Ůl Š¸)´(XA ěé.Lm8NQŻ ć^Ŕ~‡ŇývXeŐO,âöŐŤWěĎĐôţŤŃuӏ/ŁzÄ3F6iEM$ĄIî}Łšl39éVř@h<˝~Q(Šˇ6¨Ĺř3šLmtŃ`œĺĽ&ţˆďŇtąÍ“NOˆź(Ǔíô˝&.ŽQœąü7I9r“űŻěs˒ODŽ=đăępëĎÔ|)>"–ëę}Ž›Ň=;˘ŠJç5ýRßűđ|ţłÖaÓFxá•NćÇJ˙ďč|.ŤŻĎŐĘňOeĹžY/QűžŠéý<.3ÂŇWQ’żąňó˙VÝ?M÷›ŻŘüĹsŽ}Śß_'ń/ŠN4˛Bń‡űžYúż¨äťë2Ťń*ţLjń‰śňf͗˙7,ç˙ŞMœű”… ˘äŇ[ś%e‡$cn;É,ž”ÓKrÇ%@X°MŽŘş|“Ž¤–ŸŠ-“ŮŚ-$´ŚŸ{wf{ězĄŇJęN4ţě铣RqŃQ˙6üűűů1ý_ňGĽTšuŕč°6ë‡SŞčćżů‘ŻĄŮb’ţ´ßţ“9rĎŞłöt˜zlJĚcy›Uztż;rHâĹ[‚o߃ŹTŤqGžňĺ~ۘưMtŮ>&¨NŤRäîúěŮYrÎPî›nţǝ%ŢΑœ í#>Uue“§šIF[qÂ9(7+ĆĽ–ků…{B?tbYť×ЛU–,‘=Ĺż; ČĄ§â=/úlĹśíśFŰ{Ř5şŇäÝpG—m-öŮ Ö:ĺśYGâۓŐ[*@K_ÔÓ_úJxTvJ/ëg5Ž)l–Žď‹ű 7˘Iľó/¤MŽŻ,i­öý(áUĂ_‚O*NĽ-ßk/üGçú™ůŒ”śĽ6ŒK>ˇsŐ'ćRłœęSž˜§ˇ6×ۓ„ňdů^8ŞoĂăö5ăSon<ńŽ7ÉövXFy˛|7˙ář‹ü)čóÜô/\č^VŻĚY7ŃĎ~šéĘUüĹű¨şţÇŻUƒŠ_ŕć„˙ô˛Ž 9O—S ßiEV„öSÉęÝ'SŐâŒ0N*?ŐÚłŰ(IÉJ9|޴́řܝW‰Ë_M“nZŁŮéţ›ÖšăËóâÄÝʤâÚ?LqęSž7äɎO‰B6gÄOƒň8Ľ$žďćśĎ‰?Hë~4ĺÓfœbßé“Ńř­™ę}o[ҧt™˛¤öɓv˙¸ýnI˙â:<°^bŻűÁÇŚz¤KŞP‹ćŚÝ}ˇŽ.Qs”Úď*żŘą’”T— Z)dĐđKţ)Ž Gů|­ťMڥ⎠Żő,Sk7C­W˙->~ťŸX ›Ôzš˝ý7*^uş>†9JpR”ţ–÷F@e’u)Ĺ?vi4řv~cĽBZĽł§U̔ř1Ôe—Ľaź|ňë´Ł\S^öëěY-şgÔ˝_ŚčŁ(K2Y\^”˘ŢçĺłzÇ_—$Ľ‹ŞĘ žŰĽű§<şœŇ˓yžNMóÚű#ś8HĹŻŻQő$Żţ'/v~ÇżůŘ䆞ŻŐ&ŕŁrxäŁríTŻ÷?0eň[Œ6ýd}gÓącjz‹Şůĺ)_Ůş>7]ęxłżđąJřŐ>kzŕů…ű Œ†ÝĄÖußɖqßo™›—¨ő˛MKŹÎÓĺ|Fy’˛ŃtmőzS–,‘}FOˆ›Ť“{*öÜúĎřŁ§†(Ü%9×é„j7őě~OKK„Śßľč?ˆ0çKă'śÚoŠúszvż ĺ”üĘ´Â´Z˝–ěĎÇÉúŢŻřŤpá`ç•ńŠRÔřů˙ˆýG4#’0IŰxăMŸ68fűpU‚OŔţíô­ftă—66šK+qkčřg^Ÿř‡ŹÄŞYľGł”SkŰąóŁÓE/šŰ'ňÉži~LůຯŘt>żŇfÄż˜ĎEĎ)?Éë~­é랷˙z?ü´Żf‰>šQ[SöDÖŚë÷řýO˘ĘÚÇÔă›I˝™ŰUÓ玬YĄ5˙,“?ôÎXňږ\{4Ü#{~KešÁdËRĺn“ű"řOÓočż—-kJďŘ,¸ä­N<_'óź}WW¸CŞËľÂ›GjęĺJ9ňKűš:CŔŰ÷Ť>'Qšš˙“ćţNJ>ľÓO?„2ÉůQŰý˙cńWŐv”ä˘î÷tgWŸHd†Y)CôťŕżmýQ/éožÎ-QÔü˝Ô7‰íňŰ_“É/Q뤚—Y§Ęy>:ťEřśľĆ×;•N“Š”[\¤Ďćqœ•ÓhFSŒľFMKłOrüęy?ŚƒůÜ}KŽĆÓ]f}×Ät}.Ÿř§­ĹÍy˝Ú§űńÓÉű ~BĹÝSOOO‰;Úíž<ţżŐĺËńqck'…]żvçÓőŸQ/ćňĹ.d×ďÉŤúƒž§Öfž6“Kđ_Ž›B<§ękÓÔWÂy'?ŃůgäzZëqĎLúŒÓ„žéKćű6~–>˝éĎŚO&YęKxdĚ˙ЗS{|Š˙ú’Ď%“<4¸qt˝ýĎ3ĘňüňĘňIó&ěáę=n<˝SŸI‘Ľ/ůR^6äÎLsĘĺ5Ôt•ŢŇQ§á'żŕšqů„şz¨i<1ërB*-EËüÖYuš ő,¸ç}´đrřrkĘ>Â„0ülŮŁéš[ßěYćéÖÔóämT´űEi_ą…Ďo­ž\y°íyŚ—ŇŽŤ/M{ćoëg+…]˝pmÉ,Vë–Ůźůţ.]Ye9ä}ßom'ó=_ůĎč“7§Ł|eWîš3ă”ú]ǧ_Ôâœ~Y¸ŽÎMţÇn§ŹÍÔäÔĽéN˙'Š9bŐĹăkţWfľ^Ëö'•†ŁßƒÔşŒÄœĽ ů“včé×Jă—˘ńĺZ–çʛ˝íŒjs“XţjVčosTuĘ㲒Lű^‰Őa—L°Ş†Hˇłć^ţççĺ,‘n3TÓîaĎ$LŞ]šEĆę•űwş>WUéůâÔşI=KžŞ“Áéţ§ŁáG.|‘iüîQrŐ÷Őţ‡ßĹÔbÍOls_ňĘÎśF_žę—¨4Ÿ[é}Š?ąĘ)Oe&•^ýĎÓOź:ógqÍĽ%ĄÜeőť8ĺő(㒔›Í‘ľwqP_Uő1$ŕ”]´źł2„^źqŞůšFfS{ątÖOâ jź8a¸ť’:zv|ţŠŐ¨uy˛| ÔţôˇłăhÉÓÍI­;ÚiY÷ż†z‡—.My1ŠĽňęŤűoÇŃő$ÜcíőúL8z|7ĹŻúU4ż‘8Íđő/ůO'Y’]#KŚëąĆ)|ŘۋŇý$zîŽţl¸§ý;žlĺűtŽÄ8äăŽnYNœĽ{ž|YŔ‡ţ+jŐ lĎ\úź™ŠœwöłÄđEeRNˇˇąf_ÇU5ŢßCŚÇ“"׉(Gť‘é–9,[ÁIű:_ÜůË.DůOět‡Y–ó}LvÓ=bÖáŕş÷ăý8×W…ˇ‹<ń:´ŁwÉÖĺ’ýŻedǛ¨ž§ v’ÝéároŻŚlwé2őˉ×ä6đ–W˙4ŤŐz|zŹ*2ęsBűZžţW/đψş™´“pi}ÎĐůÖ­){şEóŚœ:żáůÁ7Ň7•Gő<•ž÷GÄˎxŚá5ştéÚüŁôtňľ 9ä˙*[ßľ3ăĹ$—[ÁŚšnűpžÎ¸ňłq~Y1gëąbčs% 1dÇr–X¤×ƒŠôEšY'ÓţĽMBi%ĺßö^Ććrł§Á!ő2z]6á’ÚŸ?cçdÇ,rÓ5Oś–_HŔŠ[0F•ˇ°[nDiT]ľŠx*;bœ­iMKjjö>÷Aęf,)šG&8ěă“i/ő?; ’Šj2iˇŘ铨I7]ľ(ł†xÝíÓýÇIę?Uč—ĚűĹ%.gá1cęĄ,Xă'{ľ-Ršô=?Ő§ĐĺŽ<زh“ÝIU} řţ~°2SŠ”]Ś­Ë@iryóu8 Ür:÷Ť= ×'ÎęňŕQ“sǑ§úetžűĐG,“čňęœŚ˙OËwô8u'+ł>§ŤC§ţ_ĽÉÓ䋤Ł*•Ę.ťî|Šť“zœ›ÝˇäôcÜamٲ†âŠ‚e ,6%€Ťť"€˛ŇßȚUÝŮ()-’Ŕ X°@-‚)€“`!@˘đDÚ4œ›ěVVíö5ĽwcáÍî—z6şyinRQŻ&|ńŸfŤ—lŤťquŽŮŹx ĺ&ăö&)âçˇr6ŽßĘNPrƒM]$Ý7ö9ϧ͏őAýˇxßľńŹëÎv,ÖÓĹŃ´Ů‹ Žš ÷5rĄ*LZ~ÁˇF527`Ón~ ŹŔĄ)36j‰Dj, ćér{ş.™ęšĆ+ŞÜ]ĹÓ:G¨ÉŐťóg<ćW¨Ôąú,}_ŔŽ™Ď#ĽKLö>_Şuše‘F3n/}ÎxúČ4ž+ßŮ.^Ÿ"Ňäp’ËÜk§+[Š:8Áo Śź>L]ězĺ–9]Ľ{†\4FĐť°SJÖÖJŘ6uéÖ*ʤŰŮ$čÍş›YńÁ䚌{ŸEtřăQ[w,#ъGE/cɟ%Ęôé&œ~7Ěž~§,p¸¤¤űYîlńu8˘Žiťžxňţ]Ó/O>8äm8)_”Žš1¨âšŞČŢŢçnŸ5Ľ’ńHŢ\qĘŞN’đt˒̵c2nîŒô˛IJ.őňÝňK&ˇWŠ=č=šhĂl–a­´ä5x1ŤnF´ˆŢü’‰Šű‘šxeqšxdšxÝő˘j9[ďbßt şëöގ[žĆ´MđľyîÉń/ą~\íő4ŁrŹ°œŰ˙ckŽÔwî΋2J’¤G&ű…E w+Ää¸2Űú“S Ž:6żÜ‰ŚeťäZ‹ľČFÚ_R\|#?™ťÜŚÝ>ŒšňcS˜6é´îëčn˛c“–,“ƒ}ă&Ž ľÁ\ŰUţ„6ő>łŠ—=Fg~fĚËŞĘŕŕódŃ.cŠ×ŕó&—6ΰȍ…ř.čÍA“ŕďÎÇG’?ĺOěeeŠ6œ2äMpԙëĹ륉Çüg8ŽÓŠw÷äÔÉŻĆÇüGÓ8/‰‹,eÝE&żš'üI~Œ_ţŞFˇÚÁÄmţž•}ç˙C?üG’˙ü<ű‰ĺOĐáGř–6ľôÍé˙Ąďé=[¤ęćąÂn9šŚËšQîˇOoˇ’”>n\Šž[çŊÄ.ëđăŰsÁ7&Wžlm]qťf1fŒ0O°ĹšU´Ń횄ťZ÷<ů:XżÓ&żąšÍŰ7ôňü/đÔÓUtfżc݂Ĺ Ă,Ą>e Ôż(ńĺĂČâ›ipÚŁŽ9Ëé›+4fŠĺ|ě MšQ|Ž ÉšZVĐǓDÔŞčSÚv5 ržŃ‹g­uX›Ýiű#8ÉZÝ{2ĺĘ}51ŸŽ0é㺡ĺV4ť/ÁĽ$řLż2ޏ=Ęßn‘7ŘRđŠĽ&[ˇÁ‘+Â2Ň:×z'Řt4šľ}ż#Tn†ÄJďFŽ×°Őěj`Łâ´Ł*OôGđ’ĺ jŹĄđąäkäWǂ˙/ÇSJUˇÍ+f5űŇ#šň_+ú,°âБÎ].6Z÷gO‰í¸×.Čł<§ŞšŽÉžÓżąĘx2AńkŘőüY*¸Ş4˛EňnseĆ>}yٚ†9Kt—Ü÷|Ż“žXĹF×&Ż=פńyžťŮŠßĚ÷:ÁÉ+\w*Ói×ŕĎˑŚ¨§Mż ŇğdžĆő_îgĎ&´ĚpF2ž~§iB3†™Ľ]ŤąĚŃ.VÝěÓ ĽŚ˙ŠviŐˁJ1Œ"“\ż%Nťł¤r­­ů2ŢÍG<}ҜŰrđ¸;ĂŁ† $Łn÷Śme‹[lj9"ť’ňeú˛G‹'§äŒžWŻ­eŇĺ0mϧ–iĆ ô˜s¸ĽűšœŮ%Ć>~ü —U…ŠjKŸąÓXýTÝ}%žÜ\Ö6×ygţ ń­+ş[Ż÷2’ŠÓsúňrę>&ǗŹ“ĹÔdÇđcĽ˛’śžýÎţŸëÎ8%ŰäŠţ—ţdžőMĘI[ݡä™{"޴֘E×*˙Üĺ8JĽňʟTžśmMŽ~ĄĺO^=߃3{Z燮}6VÜ#™5MNëögŞ2}^Ša†>ž lŽďív|ÜqŽL­ćžžüsěwĂÖGŚu…v4˘œŻˇĐďpŸŒmßCž95Ëgľ7ŢŢČš3¨:Ns\ţžsꢰFM)ĺ’w7Ě~ü›ÁÓIÂYg=1šü/<™ÎI7’Íý7‡<Ą%’jK{⏭řƒ.9a&Ţ*ĎĎdÇQ¸É;|ľşÁˇŽ3ŘÄÇ}âťý}ŹÝoKž.Ré~JŮă•/ĹéúŠbwŽn-óîýŰ>v<Šqԟբ⒜Œ]Ĺ}ĚŠéĺ<I?.ßćIŻÁňzĚQé˘Ô„&÷ř˜ßű0dĽNZŁT˘ŐĽö=0čşNŚ*3PŒŰ}ßcS)ꥏÍeŠR´âÓ˙)š>ďWü9(Iž›&¤źíżd|ŮúoWĹKś­$ŻcŃ3šbĘňQR5’0ÉĆpq’ĺ4f3ÜŢŮíî>Ćí24›*mŤ‘[l ­ÇOüˡ“ÝÓőx˘â˛bN+´Ÿű#Ŕ•mđšfrĆeífVz{úŽ§Ł’ŒşxdǑŻŸC¨ż3ÍŻ¨›iĺ•űmýŽp‚JĺGL_]OšđĽGăę7Űöƒĺčg‘NptůtŚx=#ŹÁÔôą†|7$áăî{Ół óuS„`őuĂ´żšńń,pJXŚž.›Jke*,–ŚßŁm=š8ĺčđe–ŠFŸ˜˝?Řüëţ)ZăŠM'ť\ł‡UüSšVş|QQkw5lׅ6ý"ôţ’ Zröœœ—îoŕáé˘Ţ,XĄ{młóţ%šŒc 1žJŢz/Ąă~šÖÇ"”rԒŚŞÓ÷,ŒߣĎÖâËôřsIZŇâ}š?1×őOăĘézlZ]|¸—úŁË“ŠĎ•˝y$ďšŘç&äîOss&×â;˝1żý+űä´+cb‰¸ÔnČHĄ˘Đ#`P@ERP(´PP@@(QJŤ˝ý‚%ÁŽMÁöŠüłŃSÉú”T{ż<łńŁ„pę[4ý‘Ú˘•5÷=8ącMŰoě‘r5Ғc†\–ľ§/ĺatÝ&ˇoť˙cK1ŞˇĆë”Ě|GĂ܎VbçiÓZb§Ş*™dÔĄĽĹ=ůŁšdÖÚ&ęťG4”\vKŮĽ•w3ť&Íţ›ZÓâÉ(ëýS—äRěŽ 2łŇ0şx^íżcÁ_§űU%Ďä×őiNٹɖÍ<ßËθ#Ñsző5&śŘą–ßîkćËđÓŔŐ gžQRć)œŸLť6Îlo´ÓÍeł¤°MxC:iîv™Ké›Ň%cIÚľł:ŹqKćJý†YLfë2îę<šF“Ő,PŻ'čc”ËŃnŒ};š´Ň3“ ąňÓú3j3ěÚúř ť”Œ\ľ{˝,íćzţ?v#é_úźřý5ŞňiďE¤űŃęx”Óo’Ç4ˇWőcćĆCUäŃá٨9BWšëřp\EŁ\"^|uč˜×•ĺלHEűŐ!Ňă”UI›XcvÝýMĽ\ňäŸůjO×'Ń.Óf%Ҹ­Ś›÷G§SžKvfrç>ÍGáČżĽšÄÖ97(ś×Őä­ň'ľó+ú›ůˇ5bxšăˉöögMkÎç† ÚăÁŃ$Žyx˙ĺfţÚs—ŸŘóőĹyłť~‡UşżaÖR—Ó—O(Â2R¤üłRύ=ćŸĐóš'+Żąë†*Zoľyq’ůTÂý$rFJÓŰčmS1-ř"râŽZ–n.őtčšA´ĚWĐ+ł-4á-ŃQîÚQśk.LŠVY$Îi­@uŇŢőhŽim;9,ň”´Ámćiœšh+zÚĺQ¤í{œ´ľË_‚ŻmÂíŃÚĺ‘&ű“wÜjkꌎ™ľîbĐwڀëŠ%ą¨ćJíľô8)÷؉ˇYOUť9śűłœŸť-YMś¤–íŰ5­3 Ś´]Hć“ňUîŔŽF^ýË°úš÷–™(á AŞî,%‹_4€9žŰ{•-˙܊¸4Ť˛zŠlU”ĺ_/s‘Ú2qĂĄĹšnű…D¨Iˇ°˝ˇł:Ť‚iIąń6¤‘9ĺ˛UiJťšRƒ~N{Vć•'ł ÚŃtiě¸,`˛AŚ–ĽĂHʞ•ó-×`ŠqçIŘš“~ć%vśüoË3Š÷bűÔéĽĹ#ăđ]/ŔHŽy2ň§Âg=/؍>Fş<ÂÓŘÂNˆÓ)ˇOˆ’ŘjošĆŸmAŐň ´Ý+gn“ŹţSŤ$ÓWIř9nz°ň×ňrË_C’şg6ď„u†˜Îĺ%âčö`ˎmĆT{ţŻú<î3z1‘ŕŽ“[-źš˙§|­űB~šű˘:ţŞüšßqÓOę§U˛ˇŕďłi|˛C¤”RˇTý‚œ[j-Y›”ž ÍĘ팯ąiůŻšŤtßcŒ¤ěŔëşáîG–|nŽN ˇvEĺ.!ˇ\•Ę 4ĽfTŐěśúRmrW(ÇkśG;UJŒR(ӕ÷#~Yw\šÖŽœB2ˇîWąĽOÉTôŃkŘ&ťŰ+‹đfŠîÔoľłGxľŮ>(8+[WÜ4âšłŹíĹ5Ŕp”žábohťöç]…>ő$öđj8ćŃG{#gg])oô]ĐWVÎżmü´ţ†eC˜´% şçąŠAĂőGMďŕŽŇ ˇťvÍoőY"n߄„ş;(żšeiěŽn.[;HéŽ8Ůş–ßBęfĺý^çeš:wšCĎđuKŠ^ćž8BŞ/žĂ/ ˝É+IýÍk8§ąŽNU]5Öľ%{ł=ů żk]J’9]FˇüÚ(ëIœô¸Îű2ŠîTěoIĄîČšśîi5F[ŽÖ.×Ejý™¤×7ů9Ő×-Ą¤­÷ľő1/›Ă0Ý=ŮuQb6Ş1ŮWĐ'śäRľÁ[H*‡É.‚Śť”G'ຝQÎXçwŽm{Kt_›MÉGnö_řB+RŠŇŻťi/ť:ĎxGTS”*őE6O’yş¨ĂUG{Ň}ŢÜnbŻ˙†Ë‰eqoćRkw\#ççëóőž$żW5°Ćd]1™BZĹ78ůjˆšîr-žˆĹ›u炵G$Í9'ÁYŃtn*KND­^řłŃ,—¸ąőđtÝgSđđŠŻůR&^‹ŠÂë6)Gěqč=W'I4œuĤŮí˙Šő;Ź}DŁžÉ*HňeŽ˝şĘ÷˙ĺ–.Ąáx?Rýj;Ľďě~Š÷Łĺz?¨ŽŚ/JřŤ{¤ľ~űŸT@œ“Xŕç$ésJϏę>ż‹§œ!†W+ůӅWÝ˙bÉhű3šÇ9]%n•ž\~Ą‡2 äű*{Ÿ’ë?ˆşÎ˘3ÄĽ„í'U&źžçóÔT%đÔU-QŻ ›~÷7_ƒŚÓüĚžŽ¸>_¨˙třqĘ=$ă—-l÷¤~?&\™+âNRŇŠjwF,ÜÂ}ŚŢΧԺžŠIe’”ežžÉůGˆcJN7NŹ‰Ňý šWj̕młPĹ<’Q‚śţč)nŻŘőG,Ô\(Óí-čÎVĎCϗL3Ӗ„ź5FOŁ9O6ŽOdŞ+”‰‡¤“mc„§kt•œţiŽýŻ‹ç¤ůěU{­ĎłŇôů%ÓĎF,+őJśF^šRxÔç(Żč|˙áŕů 辎r‹\Ş>Ź°eÇ卤ř¸™x!–)dŠżÖű/bNnű‡‹ĺyăĺ’Äۏk2Žňí@”P!@…!*@@]€EŘ´=7O˛˙jîű˜ĹÉ­rPş˝*ž§NMuE}>ŞÇ‘ľ[şksrœaB˘ăĘůnžç)ÉóŞ˙ćgN]™ćÝŞô>˛J-(÷´yܛńőF^ü€-”œ÷2ň(5ܸărş‰n›!Ďă˙ʍEäŸ %îtź6vžMýŠď¸94j܎t˜ŮjŞ96–ÉŘšGľŠN’¸—I­Č'Ĺ]ÓF–E\™ČžšHć˘Î¸ńăœŰ6éčR‹ášR÷<ŐśÉ2$ü†_Tňzœ‘ÉÔĽi츢“sŠőěţÂ^çY4˘ˇvsîZےeËĺ5a0ŐÜ->w/Čż¤„ľćĚÎLľ­Ż†.ŠtMF,śsV›Řj¤ˇf-žŕmH9ťź™ű…ůeRC^ĺŽ=ŽRŇ]0.ýŹ(žnŚŁŐ-ü$câ5úRHĂýŔěňĹ-—Üćó_ c’ŤmݚÚĘm­MËd—ܡ4÷ŽŢIˇ‚§ä ܒŕóĆ92Éš?Ąč´fŠÚŘŢ9řú‰ŻÓ(Ăv÷:lťŁ ěK§š›nWudÓŁŚŹÄmJź’R}‰mŰŞýČŽ.ŰvżŤňےJI-ŃU?<’űٕwtk°ßfeűpRili9?ęf&âž^w ­–ŐY(:î–Ĺž §Bě^ţQŤł.ԏ耥T‹ČrŃÜśŠ‘›-ƒjĐH–´Adl ˛X˛§°E\™ŘťW7ěUDö˘Ż&x}čŐŰŘ ëÎćă´|˜Śř5Ó §Ý™|MZ2ŐđA‘M˝‹[—KěEŤî>dř*‹ű”n ŽVÇwđçÚ’—fŐţç›uÜÔfÓtęü‰CşýŒŐm>]ýLś¸Ţž ggáÁŐíö*ŒZłŚ,Pœ’sПw؃ĎBÚ:´ÓŠ+^I(ŤŘ#•p9đV¨Ęäs\•~BÝ Ś˘KÜ7~/ęnĂ؉ďî)ű…]Ůhˇ˙/ŕÚMŽ@ćľw-S:o{–ź­ŔĎŘi.ŢîˇÚ­>Mjlç{[{‘äKÝřÝ\’ńf-śDŰĺI'żänšŽŚé9_.Ţç9JŐ^Ć^HÇg%~썡u&öMYR–ë\}Ó8ÂJJÓą9Ć Ü’~ăąó4ąś#*[ŚËń_GŃyîŮv›]ˆYJů%vÇÔeƒ†GKą‹sšN›{_4ФOî&ÚXŚä⒵îŒďR‹_aKą^IRůŢŢäţGKČÝwŚsÔŹÜ[“4šÓiÍŞR—ä̔˘ţiKsź#ĽVÍłJ1n4p˗n´Ö3+ۆ™M-܎˜Ą(ŢŐőGU4šŒRFr9jĺ}ŽYsnkMLuŢÖRkfŽnźnT†ČâÚ;k˛3¤ÔžÖf›ŇH |=tŤÉčŏŚÇyudi~Ž>€y\ŽŸËäқ‹KÍF>ˇ8ăŸ¤ĹŽ]Yä—S>Ť#žGŞ~őEGaRţŞgĽzVlü)ăČŇşŽEƒSé˛Ć Y‹jÔvăčxç)ÁՅuAÔĘ3”qI¨~ŞěrŠĹˆçËp›‹~Ü}/]Ôŕř‘źŞ.;k¸?Uî^{ž™z~wŽSřSŠ]ŁĚńĘ1ś•}@—F–Gތ_ąRO؂üAń%˙ą*—’.*Ę7ń%v˜YĽ6^ ĽáśÄ•r˙(ƒŃ ÚšŤňűřĹxç~ĺú3Q“âÁˇŚÚý-} /š;Ű~čSrQîřhÜĺš,×fUy¤š˘%ąéj)'hóMiuýŔž62Öꅕ4ů ´Ý1zw“_sKq^6űb÷¸đʓąJ7˛5ŠţPDދżƒ›É7Oč]kn Łm9:Ů ďG76ÝE[ â7ú’.ş;ěëÜŠ´ŇؑľËłkOü‘K6¨ÂŽţčľśÄU˘6˘ˇf~31Ź•iżĄdý5)[MleŻdţ\b—v÷ňTžÉŐŰÚĚ$őršfšĽł *ÔżŤö4îűQ„öŞŕ˛’ŠśŔÖ§ż;Yc[OĂGő ?Ä˛K#NOƒž\IdË$ÜŢűŰ:Nşľ”ŽLŃZ•ĽŚŽś,úŒÉ-ăżu¸ÁŠYSQž˜÷7.ŠI|˛‹ýŒŰ†ű^őÓβĺWó˝Ëӏ{7üśUžŸÜŇé2ľi%íeŢmĂŞŒŤZÝĚy>ZJ“óä΃ŠĹŚt‡Q’yJJźœň◼Veúúm;ľßÁËůˆĆmNá%٣ˏŻš—Ěž_cŃüßM–5’šđ×? =ĆśôŠ+SN2˝ţ‡ŤÔáŇőxc(ÍBJ“zi_ú~O™.Ÿ ńšô}FœœźR—?Gţ‡•u™Te#m=žÉšÇô–šeĆńÍĹ´ÚđfƒŤŮÚňi´ă–šĺß'Ś1Y 8!PBîŞ*%´’ˇWtzúEŁ%eš‹÷ŕňśëfg,v˛żSé}pőx哨ĆŇŢ)Lý)řKő=,Ą<Šy2EţžÖűŸ°éşĚV5<9žÝĎ>ľŐmÜĂęÍG§ÓÎQVínęúěĺĽő2ŧšÓţ§âúÎŻâő9ZӖ-í)-ßżcŸQŐäędţ#Óя˜ďŽ:b֝7áx]‹qKɀm4ŽM™) (B€!@făîeQ´Ńc5ŰeMɞ¨uóřOsN0|Ćé3ÁŠ#-Ť9ĺōífUő–PÉńąOv´'uő=˜ż‰˛tđŽ8áĆăNŻsóÄl“ŠEňľúłřŤ>U§ŚĹI­Űݟ?W›¨˙͛—}ÎÔĆ@ąd…ąd[-‘+uýË(étÚo؛4Xł6RŚ”€(ąd*Mđ6€Vř;CŚ”š=qč**S¨ßNyrăO„›:ĆŠâä{^(¤žőĹ;9čQuO~ç šm]9Ć;oÁ\“>ÜĘÚŘć÷ĺ/ÁÉXný…‘Şă€T[t•ł pâšwYš7)i^NZg=čÔ^çdΡ\Sq™mqŽţfvl’fnĎ>Y嗶ôŐŻ&t×vGőű2*ˇKv‡ćuU˙°iđ46ˇ§Ă ŤÜœżč@r§Ui÷*Ś•ŤG9=)-‘¨dś×ƒrĺŒÜK%öéňÓľżfJňfîʞŰË+}’HżÜ/܁:fAż%ľäR|‘ĂŔSbsżš%ĐFl&¨¸˛}Ćĺůl‹v’î]™„Ú{uÉ+u|x1ި[nß 'bÁś–ć“ipÉM ^vęŚ]\íš;laë{qî§/avďs““pĺ%ËŘ֕ÖďmËm=Šœľ=­ěÍ):ä Ű\ŤWĺOďő//‚"Śë’îö{‘qŕ'DEM­™lËeÔźƒC#ŕՙGôߓIŃ).FŹś`YÁ•"ŘŘśĐ*ߐNŔ#Ełś,›ä*‚> ¸{ňOą˜ÇmŢţĹ2Yd°B"‹P4š|Şú|ě(Şy˝†–•ŽţÜ(¤Ó5Žůł "š'Ü_š(Ŕړ.ˇšŠň/ŔŮśœŸ%S2™6ëŠď_sMQË{UĘćΪ䊴ŠraýHwř”5Â[qš•†o…ǐi)Ť[2[]Íü))$ů3(öîă;7ů#ăŰĘ9;LŠŇäiÇÜË^Â[>Á9J˘?Ł-;˛ď{*†›án´œ,ą‹Ůö%ň•*žĺ“§iŁ.MÓAJߓI4čÍŢáśž•ˇvMßsšČŰi/ÜŽŸąŹą¸űI”ž›ÝÓ9éßő:đŮ´’2­4Œ5šľEŤVCI¨’OmČĹ?EIRDÓ˝ňţ…”Ô?SHĺ>Ž TV§ćăŽWѲ]<%''ižhń¸é›‹ězáÖĽú ţĚÇQ—X­w垎?däë‹>ŽGÓý?#šĹ‘äu¸=źnϋÓő_Éä×(ˆ¸MŮćęúŮő9u8¨ű+ŻÜ뇏ܚœ““ošźsšÓŠ_Ó.žJRę2(B;ŇŢRöGŁŤő\ BIJőĎy1áoXğëٚ]ŚéŽlSË9+Ź‘­?_?bOÖ}2xÔ§Ój›n¨ů=oŠçë–8ćЖ>U}Ď#›˝śú'ęíú]KÖ-}>H&•¸J[ţil:Oę\–NN5ĂľOţ‡ŔYd—'L]fl3SÇ-2\37‡ń&OŇËŹŹąY\佸ý[ôÜYRYş -˙T&~V>ą×Źš˙™Ýîí/ąîĹüQÖÇ4e—Lŕ•8%V>*ÖßS?đÜeX&ďü˛˙sĺő>ŸŸŁ›Y#Ş=ĽTŽňţ+Ď<ż&(Běúłő›Ôş?‡ ĆYe˛‹Ůˇű˜Ë ~]Ş“Ůďٙp¸Ýqú>l˝DĽ n0_Ľdćű˙îs}(cpœ',¤Ł%łűœőUń Ň{ţƞGuĘóG~ťÓóôM9ĂnÍn™ĺ”UZ–ţ(iŽ™?Óżą&ă´\m¸˛dÇýI˘+K;ҕîża,ڎ4ů˘ÉýBmŤ÷7)j†ôŮÉÇkŻÁŽAśť%DtšŘ"€MŁVd›ß;Ş˝éщÇ#MF’ófŤsVü]QÎ’˙̓CŽŽŃIGčeˆÝ m4Š+Űc ;ŽĆé˜rQĺŇB+QI!tÎK6­Úuô:]ŽëęYgą\Ť†Ś•ť1ťe[÷!śľ{żcWˇűÓŘF*2o{aZŤDK•wô#OîH­( âďşkš¤Ż‘włŕżr JJ Ď4ććí:ŽÄôđă5äĆWč‡vT”[@ ‹9ÎuŞMŇĽfJn›lŸŞ˝źžËڏĘS´ęťžŰڏ'7ötÇÓIů5Ž\'GĺRÜćÓŹ˘Ľ’´y%ŃĘţY/ş=Zö#mšÇ;¤˛WĎ˅ăýM]íîsŇÚm'KšęęâޗťŁ‚”Ôž—ť^ONĺŽŘ˝V:cČńĘҌ­UIYšlôt¸çríř5•’n¤öó4,őő3ŒœáşĺŁČ˜Ç)”Ü,!M Ĺ2PîbÂÜWÉVä ើ—ŽÉ‚qińĆôxÍ&‰q™{7§ëăüWŃéßmUŮ*ţç—˙‰łeĎP„aşŽYůžëÁ§žh˜ź]tžoč8:ě9:oŠňAW;ÖçĂţ őIG NJPNjśvŇ>Oę]OM(˧gő<ýNyő9Ľ›&rçLi,˝­Ž-Ó{:!bŔ Đ ˆ( °@(!@€ @*JšŘ7l×ԍ @ZĄĽƒiAŚš.荶Ű}Č *EuEMĽp6§iÓ9ƒwłŁ9Íâ>žËÖJÇ)vrÜôË?RŁŻ¨’zˇJK’:jPSiާý‹—$SuWˇąă˝tŰ9rëČĺĽ/ý&í;ü™nßԄÖŃuż¨rđbOvƒ’[7LhVďą “lŠ'Ë°2÷äË^Š.‰4z¸š7֜ěÓ1[¤őo_ƒŽ˘ŠľĂ7ɅÎi'Wn’ŽÖeEžă[}§*Ú*Ď7Ĺgş×“ŸĂu[0âę¸:-|Ş#‹|ɘc}äy_Ç5 çvLšż§îtPŢ‚šĚnçjóFr\îu‹Ô­DyŇi$•"ç–Ô#Š’ÝY…Ç%ĹŇ:ŃLLŹéR‡˝ Mnţ̴̈9.—[ŠUŠ)Š°ęřv• †ÁPni+Dú”BWĚhn݄/v¨Q ź5ný‡!Řś‚˛­w˛&ۧVk’$PjůH(­Żą@•R˛¤’!SÖŰ d˛§KÉ˝“vZ]˜ šW¸¤VJ ˆHř-ěŕš-vŠ˜B‹t[Bě3fˆ5KÜlĚŚ, }Xť3a4ŹŚ/r݁ŚĐÔe’÷Ř j¨ÍěFö(Մ̥f´lÔQŁ}ßäľ\8Jc؈Š–÷2P-  D`ŕąăö%‘iqîKö.Ô’m'ĺ–é3(šZt„Ý5{r>,—;taĺŒ_Í$Yťé6ô,˛_ű™”Üštpřđ˙2 4.”‘|rü6ďłĺĽ[=Î+4/ő~KńĄţdčž9~vŒ^í/¸[ňy×RĽľ4źš]LMłW)ôn=tŐ IüĎđsÖäŞö9ä“půZo͙“uvôNpNjy+îxňu›ůSŒ|YÇu'­Űü•nčőńńIßś-XÍŢíŃŢ.5ËkŘăĽEďÁŇ ĆČëdӕżnŇ΢Šof§7Ë šqšŰB‚ŚřěynXaýfë§y{g)6ęÍşQ÷<ů3Ę-iJŸgšM-ëč/yÝŇY'OE†ë—_SËń%§Jtżš*íîY˙Ď~ęů˝ŠŚš N+”—–ybÜiÇj“›ś_˙žďÚ|Žůz”•A_ěyžL’ćUěˆÉŞ‘ŰŚZʼnŠ5úܡ_J<íŰߓž<6÷’ďOS×)dČş\kD•9N)ˇďěxeŽ÷ö;G¨řtÔ ä¸Řĺ—>LŇrœ›7ŒłŠ5nƒ–Ć!ŰiĽl"*XATÔg(IJ-Ś¸hČű0ţ!Í>›ŕő8Ł–I5–ă$y˙›ĎÇ9jŒžeRŢ/”˙'Î:bČŁ(ëZ˘žčĺžp}îŸ×œztů`“{<›żŰÉšúT3âyđ9F5mśŞĎ•Edœ`ţKľćŤčިş͒›‘wgŞ"žëorćŽÉéT†9ăżRąłWőaĆŠśßÔĚ]?cM4Î\˜Ü/^–]‘ÚMťŽÉ4ťłJ7ŰI#œ›Ť}1)ß/Zi[DÔľ]lYĎ[łÝ­ufÍăV÷fb­ŃčXö_čc“9Œ5ľÖ’ŞťE­—Ř4×*‘çĎ,2ÇŻf2ĘĽüE8ˇ^œ–Ťwř9KŚŘŚjžÁČ4ÚMY7ş¤—Ôw.äHŁ_@šŕą^G A×űœáŠMJšěuV‚_7^´&—^ĂMrmŠU“•ş ĂRşíä8×( [ę™.¸5Ž7Ŕ[lʕö4§ˇ?`ăkk@cB}ÅohSN•EŢŔD¨’IífĽiĐp~m\ŽşŠ’ü ŒŠw4•˝˜˘hŽŔĘÜťy*˙˝Ć–ŔÍ{’™ŃDič‡W¨Ň6mČ$uЉ ťą˝t2*PŚ€Ÿ°˘ž ŁňďÁQ]/žĆÜbsĄŘ4jŇRîÍ8ŚŹ8Ôm­ĚŚî“(ii•ńÁŠŚ•’)KeČn^ŰQ\+’RKČ–•` –Öřśę˜J€GnQŁ% 2s˛ ÔaĂvŰ(Ćţ Ł{łŤ‹eÓ\ şsKŘҗ†Í¨)=™IVŔNJâ’Oż‚%˘i{űsҟ;7ťöD{pŻÜsh+4Űîţ–ZŚ°%GނĄk° kş#OÉ­ť‹}˜Ş-ĐäwŘh”iArřœŁ ßîrɝFÔO4ćć÷vwÆŢęmŹD§j+J9$Ű5^ N-3ӎ3Lí.†“Wd|ňhJŁěMM2Ćr|: vÚÇ&­UmÇxˇÜťÖ͓žlśm&Ůšwop‘Ń5ŕËçm‰ĽÚE[:E4Ş(Š6éˆCOsœ“žÜăŽužÇU‘˘ĽKSkŮLůrËŚŚ1Ů%‡nœĺ˝xG—,§)m~çMnsnM[ܒý;=ɆZÉryŁiíą\iű“‡Lś} 'ˇ+˛‘–Ťš&›ŢĚ´ŇÜ,Ăt‡G-Mp>4ŞŹm|oÓY"âčçošŻˆß$m25%B§FAJŮ aTR˘nh€ R+ŚƒC`š\˘˘=¸fwłu{ÓŁ¤°źxá’N55iw3lW+~MF9 ţ%Ł"œRuÚJŃŠgÍ(¸ź˛Ň˙ŚöGN˜ńcŠK>EI¤ˇł+&*McŠ-ů8U—eîgĂ~čőKŻĎRŒ%đă*MCk^ţO4Ľ)ť“mű™oؖYŒž†‰ĵít­ř%€!H¤P)ELęšqçćěÎ'HCR˝_cžrktvŝă[6ŐYöqzœćĄŽU$ŕâԞĘűŸQÓ˝Ű=o…4֛ó$rĎ MÂVœg‰äQn¸§ÍÜßĂPJ4ˇtˇüžš¸ő=eG'ËśŠ%KěyzˆKžu|iáœtŽ_ӍěK˛5ÉR]ŮTäվʳ+š¨ĘťZú#’öŮM%ťLäá$âÚ}Ó#Œ’ˇM+śťRLă*MiýÉlŇÝPDIľu_p­ö:Ć^ćÜ+n/€<í´ŞÉÉßá'ÎâX¸ů Ž×l—Ć˙Cł‚JڗĐÆŽŰ_,ťVĽžĚĚen™ľ§TÍF-ßĘĆĆ•žU•IsEЛa㡳ýÇ@šWŔ“EQJ­‡Ľs˛"2Żąe&ƒŽÜ*T÷*š‘oÁÍŽÔéšIVŰxOؖN¸˝Żp5b÷3vTýÂŁŒfîŒĚš]ÄG\ůŐ&Ä0Í˝˘ĎFRS\!u­W<˛ün['ěsKtíx;Nľ:vsřqrťkčy0Ęc“]Ů´q„czL|X4­;ňoá§ú¤Ú7đńhkNţQ­ń޲ť;ź™&äŰOcˇÜôË[¤ÉQ‹óő:ŢL1&ëĎLŞ'­*W§ciE­N)™ŸýýÂËôóbĹ)I%Ééj›§ix#˝öűQˇ¤pĺäóúY,kď’7}Ĺž*ýĚÓo}¨äŇ]ʸ*\śZŽÖ†”ÖĚŁo‚é÷IŃŃ8´'4łŽÜŁvA-U mWƒjšŮE[Řqńš´¨¤u>,ą\ˇgI$űXŮ&Ú(Ě[~ť4ŠěÚd˝ĺǃI+ż°ĽŮ"))7qVVŇt’"{řl â–ëbĆVżKű˜É´”´ť_sI][ű"éMůi?¸kݢ´ď÷ ůţĄđĘmý‹kJWŘĚÝąš:IßčŁHҊJ‘TvÜenŃŞ.‘ĽsŃśôkIŞe iĎIhՁŚ(Q҂ş´˝Ř4Ĺ 5A-Ŕ”kęnŤŒ˝űgJo~=Œ¸¤ö7Dv×ţ-Z§ŔŐŮÝx.ŇăđĹ5UF%FšmŁZeăř*š’jJ˜ÖFšJĆĽÂ9ż•ůFŁ'ÓTĽ4‘ĆOLžY?ŠęŇçmQÍÂ-%%šWNjZŤVćőF1Řĺ(Ó,vĺ%-ě)ln0ŒťţÂXô˝ÁŚRŘW~ĹN†¨đČ9¸ü×Íöe[puĽ%˛1({¸Kr¤ÍU+ Ë.Lš1Eƛdm-ۤs§‘§ÂłŻîú-zqŰÇnM:ěM7ó]ďÜ­üŞ)Š­ŽŃÎŞßdżbÚŞi# łgî,€ Z3Š†°Č9%2›VO°”fŐ'^ĺ.̢]v*ű8˛6ťZ"ˇľn,ĹŞ 92ŽŠV7=”WwäódË<Nőán•Ú\YÎPvčďÇp˙ő‹ˇ lčíb–2U%Ă\‘aÔ÷żŠ%‚żLŹďňc.­Mn.?„ˇ’lËÓosś,jPÚ?RfĢŰTnÝ1/n HËOšŢ1Y Şírsn­=ËŚĽs[ԗ †ĆxdkÚšKɸÍ÷1E[„­Úc™R3M-2*ičÄžsšçÇ´­ž…ÍÝ?ţ‰ü—D¤’tŸĐçmö6÷17˘.Őű3Œ›şmÚ_:RznťG))[n-xěE“%ړ_A)9ˇ)ˇ)>ěőńq\olev˒[÷*šŤł”Şë¸i.Né§ilŐ÷Ý2rŽ*Mm{ť+hłL¸Ú8ÉS;;|3HUĆ°#a ʒ`dtJÚٽÎŔŠşKm˝ŠČ•ö,`äę)ˇá ç&ŤoÁČ5(N-Ü^ÜÖć7I{—qAEÁvԶ؝†ĹGIf”Ÿ4ť%˛G6Ř´G+dôŔ˛UäŽF@4ś@€  @( (‹qv@Oc¤ž­Ń…&¸d°5֑ę麇ŠIĹ&űŚš>„˛ŕębŁ˘MĽó9oGǍÚÓť=83|+RmjTčóňaŻJŢNžXdMwÝv2ĄgևYŇuú|Y5%4ۗfżąÍô <#>žIIÉĹĹŽ7óÁËJůŽ5ɎV~Ÿ. %&ŸÓƒ‹IÝ"vÇ<.)dZ_•ÜŰrœWÄ­6ăt–•Ó:c›Ú7Moš~ôËĄŸĂmŞ{SěϢá&¤{#9^źMxŃäĚň,ŤK‚OÂŘ+ˇ§s•KKuăcю FSL¨şş,bßut(Ä­x¸8:0ń§ÍŁŘâź–Ň؆œ>÷˝x0⓽;ř[&Œ=–Ű2Ľ6U~WĐ匜Œ_ÜőťlÄŁ}ëčDy§U9:ťŘ’KąŐEE=NţÄqßměťG=-+đZłj(ÂTÜkŻqż‘§udů—Тś7ďFZbÚŘhk‡ČŐŰ÷3eVŹ!÷AVjwR[?™äĽ—Wpłnß FUŠ3M9EÁŠxdÇ7 ٧•´‘éǛÜ.m—Qn-nŒ?Ői]”š–ç™ÜlŚ]ţ ĘZ]UżIążŘSľš•'ărśŚ’D¤FímɄÝ˙¸—ą7ďBŮmx‹eş.ÍlÒwŕËk„~ĹÝž[&Ëî[n€+˝÷4ŇŻs”˛$űśj3žE˛¤ťšđşÝG<ˇ{œŽ“­[[÷ł<ź?ŹDh†ˆhB˘@¨ŔbŠl !Ą@Ľ 3@ŃŀbČ@­% !§Á–…$(VŠ˘˛ą‹“Řú á ä܏dŕî;3ŞęrUmő8ňá–]E{-.YĎ4⥴“öłÇ9Ę\ɲE“ťRúvĂ9Ś–Ěő÷ŤŘó`œœ´ŽJŽćy÷śgľŤfÓ2šEjKvś<ÚŽ›†U´œj—(ŕú9š­žWÜőbŮޔţ§id_ę•Ĺp‘ęâĘÉźŤĎÉlşÂ<˙đôŕţm×q i­śTŸšŹš5*Šq_S‹ÔřܜœŰëÏ+ý˽ӕFÓÝYÍÍǡäó;éśźre&š%ś‚ŇĺzšP5Âîgh%MŮ%^w ˕?Żą# Mßஹ´˙cQöh#˘IŻiÖŰŁ6×/o ´Ůix˛G’j~6*۝Ź (řĺp7|¤ŮdŻ†EE9Gľ†íoŔI÷ť2íşť4m5mŐ} itšis}ŔŇT—÷šĺšĽŕi"0•śÚŰą´ś¤¨ź P Ýď؍[^ ĆČH´ŠEQŽx÷5[Ľçňmc__ŠM9(ęm˙O÷*ƓŮi.ÄŰČV4ŘQkÜÚŽĹŚA&Zڑ֐qEYFqc¨ß“Ł‚f˘žZđBFwN”çąUĎHĽ|”6L8lÁ§ˇŘŽÎÚ+z7Ç ÓƒŒšH|Ěęá]‰§Č4ÄxߓiÓ؍+ŮƒoćvƞÄF•w*łş|ěZŘŰI˘iuO Ӟ”÷O쌴źîi¤–ÍŻĄ4(śďvąšCŰIŹ“ÓŘΧ-âČĘĆëušŒŻuśĺ|ßs*÷l X‹Ţ٨Ĺ&íăÍl’E]9<Ň[E%ö9ĘY,őĘŁť•żůQ7‘=yató¨ˇĺű˘iiěŮéQqç ý ’QjÜdO=¸ńł5&Š4fŰŢ­{›Ží$’°:čůUŤúpÔŽ›~ ŤTť×ĂÉ/ŠáIE+{wW6Ľş.ť]‘˝Z—ęg7 ďżĐˆˇîȞˇ˛NŒŹm÷očn8U¤tž3ýgşâŕĺ/™ěmcil™ŐĹ/ÓˇŃo{&YÜ˝Ž´Ôc\ö\ŰîT×;} +^HÍŘë wČĐä˘äŇuœ[Z9éuU@`ŒéĄˇĹ#2[‘FŹ€ ˜˘é(¤{–8íĆŕ`Ë^ěŹÍ€IY¤—“.—ÔŠRŕ ěJVU%Ŕkd˝ĂăܛŽQe%Mˇ^J,CJš#JQwĹVi+§ł~ŠˇŻcśrăăś'۞Ž*xŇť0㝼Ta^<–žéšřŚ’Ť=rł­^œÁj‚ ˛ÍFĘŤš§Thďˇ&7˝Í;:¨ĹÇć䊽"ý<Ň=QzĄgŽKĆčéë:ię8săĺ&˝Ž.ŮeđáŞ/™ÎR[˛šź›ČÇ=ś5ÇÇ1ű-ŤbšmÉ2*Wg+gM’mŚďsV¤žm™ĚmiŠiěd ´ *ž61ŤÝZđWĚxđZKƒ=ƅŁ&­4ů)śR)vo˝ŚÁ dV›¤eśV@@€PhP !@  GHäí#†rĆeíŠRÝ:ŁxzŒ¸$œ]ÓÚ÷<ń•#˘-œrăń˙‰ˇś}Ds[Ékĺů^•ť÷8Îiż—c8ňIľúąmjÓ%Ďs–sWĽ–ÚI/ÜËćü°ăŐ4ŁŮţMfÇ%'ňŇł-éÁKJóÜé))ÎĚJ­pKM„v‹o"Ţž§ş-%ľ6|ękć´¨ôôšâĽR"Dz0zŻýC•>~ÇH¤ăţĚłŃÝ6Čے˝MÓ2÷'Ř5&Q‰UœĽ}MşˇOęMĐfšł)3ŁWšŃŠ^QíE{†Ňi;ĘI3¤ÎźŁ.+Łçm)w%§É§<Żk—°’ž6fşV4ďł#‰Š}8 öi¨ˇ¸†§’ÜÔ§wˇáešMíąÓ2ĘzMťÖÄŁœ2ŰJGK]™Œ°¸Ţ–ĐRě ‰Ďą¤6-­ö˘*Q*–čťQŢŔŒŠ^î—c?3˛˘‹ˇšÚÚšîW]šĚV¨şänuŒ5+{ETŮš'ťRĺő›Ž›~ę7Á$´ěö:cž>Ś;O˙\”Żş_TGń#žĎčI´ßƒ6× ŁŻ†ű„ŞňËÂüÎO–FˇFźdďKľ„ĺKîwqŰLv.á4óé˝y;¸Œ&œˇűři*˘8ZŘ+-#ŒZşü/łü™qtçœS‰ÉFś¤ýĎcÇqł—Čĺ§"ĐżćŮ1Śtá^vö7˘NäďŏĺÜŚŁŽJŸ’Ë˘Í I'ŞšiQUĘńJ–™{—OT?&T˛$”ÓJď~ĐĎi2ˇ–(ľq‹¸×=ќ¸%ÔbpnQkü§|SŞšZ}čܧđň%R”ľ°Ţ—QçÁđ°âŒ#Uý\ł˝.2w˙-ŸG,Y%,‹ d_,Ľ\‰ă×؛]třď§qmFWěÎqĂiľĎ}Ď~h¨ˇÍv<łqŮF:˝Ę͉q_×ř1,;şf˙J˝ čٙ[ŽđG= v3$wŒum§bŹ ˝˘ÂiçŠwÝý’UnŽË“Ý32Œš­;~A§“$—ťf7Űą×áťáŮŻ„Ó§ČG-›Ž?'xâóÉľř §8BřŮsĐąŞ­M–8ÔjŃѨĽ˛ HËƜ\Şžç/‚ďegŞ1\™zTőI­ř*éć–'QĘp=y_-NĎL—Á+iĘJ™+rîÍÇĺ™eŘ5ąŞŽÄeD‹4Úňs‘–öÍWۓIíäŠ-ňś —eMÝ#jZ@eA}C’ŽÜ•´źœfŰÜ km÷­>vŕ‰ńlĆLÔ´Śo mˤŽSٞ˜~š<ŠîvÉ6ŁśÖzyqň˛$錰ZŻÉŹpšŞ9'NΊICŝpššg-™)Ën QÖ1Ulç&—’_ŚděŠŰ Ý„ČŰWCVě̈́§E7?W’Ăş“Žć–RáY‰E'MťCLď}F¸ŘŻĺąVęĚd­<•Ÿu—J܎OŘşžZ2fşČĹ @7ź‘ś@m’ŘP¨4š:\_c’ljeŰ6@R*‘€!H(şEAŠK` ‚(!H) € ą=_+81J¤’ňg.ĺJôĽŢ߸oTśďŰÁ¨Ćâܸ#ń2ÓsÄąîÁ c‹JöŁŹd´˝]ť‚QŽňWŮ´rɑ$Ü]śGOFei×,đ¸émUˆšEĘäýĚdš¤—3LrtáIßąqŚš”wką˜jÎŘąËUvJöźz‰Ri-מĺŚrœ”˘ďňrůpĆIĆűY!“téšWÓŃ)IęƒKÉŇ8ő7m4E=PoMĽíd”ŐR{řoQĽJŽRšŤmĽD•Ţ΀ă>i'˙šÖQˇ¸ÓA94JfĺvŒ‘̝"˙Š$ťs’•]Ť"\vŞf\nK¸Úž(ă’üű#ÓĄ‘DŢ9řý#Í ď'Dž*ý+cŃĽ˘×zfç6V„›Ů3Ś8II6śf痴VĺĹŽVî—Đí–YkšŇ+ľő!2<‰[ŞňŒ,žĚă8­›‹ˇVĽKnFŚăM㖝5GEI:îc,.>×h)˛¤mE>91ąŠŮ ŘéđýËĽ}Ŕ奴j0QŢ_ƒn“Ł66ƒ“tť •‘­Ét=ƒňUĆăśâ5çsXĚžĄtá“ă˝_Đ心Ý+ŽZűœç$“žÇ§ćŸihEÎT‰m=žčíŞ8ăĽnűŃĘRÔî’7ŽVßńO‰6˙Sü•dŸůŸäČ7ăE:_ŞMřšršťíG>ٟ:eqmi§Ýł˘X˛ă54*mÓěNŔŇ*[šşŘĘ-ů*Qňe†ü܋"’Řh@@(”d¨Ź„EŽÎ̢ŮQŇ×ahć¤]TěŹé_>äěG+°]%Ž@"œ°B)Č(ŘśB¤ÎŘŚâů<ö[ céáÍ Mîvtϓy+t}HIW6źž^n9?”%×BZSݙĽŞí‰JŢÜś™çZÓ˝čmVG'qýËi݀Ĺ߃pÇ<äƒnÚ\5N7•rvÉ4 ńÂ0󫲎2„—k|lkŕěܧŚ+—MýŒĆ |ĘrOŘ­NI§+MŰžlŞÂŒ[nKěFâŸĘŰńľĐĄîŽk2É=clÜM§×cŹűÔ­ÖŰltş3GMVöŘŠ'ţç4ýś6šěY—Ĺšť1‘Ż.ŔŠJNŒd†ÖšűFËŠżéýÂ&&á*|3şgœŞ–ţODcPWł Ÿr$jRQMťŰŘç›*„îÍá…ÎôÎYL[Qný†­n|×ÔdRn2hőôůe:י7ţSŽ|>=Â[öë˘Óˇ-ýĘŁňŇ57tÖĎűœďó}w1†3/u3ĘĎQŇ0Mţ¤ƒQő[ö9ÂÖéŚ]űťeä˜cÔc+{Z5FQŤ8şŒbžT—Đę˘äb5w[ŁI¨GŕąÇ(;ƕw‰¸Ń3k”4Ĺ´ý‹?Ć­’n´łă—őEWfčËɏyjM.hášä§’iŁ]F\/äŠKčvdžßo6_ý?Xş_‰şQŞ:týv9ËJ†ţěđC ËÖjř˝<ťJ_CéŮzi?‰zćÓ˜aŒş˝ˇŽyŢßAáľrj>ȎOuˇ÷= §z•pŃŐáz”’TżcĚôNŢ8ŕmśÓ‰—ęÚÚň{V]÷đrę$ńäŃ…›4´­\%ݖ§ ¸cW6ĄJäęŮŰǚ*X寔qÝuż mŠGfâ­KßŘôOŁŽÔďgî{ViâRVűk§‡JN’ßË3đä÷=ż˝Ú˙ąviâxRđţĄG˛Łž\jÓOsĘĺ6ÜTC7§fŞ?5YÂzvýŽ°Ĺ:šEűLkyWŠ@y'ˇfpqnG˛j7ÉĹŐşŕ•Îą[:Î-R:bĆěíćÚĐ˝™VG‘Áž?9EŽQęoŕ˝2I× ó䓺|ąÉđrďłŘęÚOdbMEl•ŘecÜҢFM˘Ľn—, 'ą™7[eĹԖçĘű†ü™K{eě^dĄs}c-ş‰éŒ’Ó˛_388Ivgľ`xĺsjűœrĎStnLfœć{˝8F-´zgŚŞŐř8Â.R¤IŠ)\š&SyM_MűuSTiĆ1Ľg8´ńßp˘éI÷:šéźš]ďąÉĹUŁRWÁ™|Ťv“÷%˛5ŒaěBŚŤ‹~äT‘iFΑҗ̓žœW!ŮRÍ˝7ˇľvłĚäě€l˜éTÚá‰KQ EfÁ@P¤˛„ š#@,A@PB׀@€°–@ € )@  ¤€@… p­ďÁĚ튒{nc;ŹjWw5đ’îučÚRmíŘáĽÍZJ˘F QT¸ćĎx˝„ŐśÓ]ś9|9dkcŃ ‘’UiýŽ-É(ŐUŘoN_ 8Ť|2ăŠěśgŽKĺzM-2Ž–ˇîCO"”ÖŞhôG¤ÖˆĹńˇ’-“ÓÝ÷ášüÖßŘâŻV;äM­?„\W$ťqaŽ‡"IAýIÖ⎯‹‡fůŽćąK4$á(ZžjÎÓPt´EWąqÓXÓîpË =â÷G\“P|6ź˘9Zů@óaÉ9ś¤¸:8ľĘÓ´ˇ{˟¨eΖŤ˛3ŁšÍÇęTŹÉ“+Ł/~ᔠ]˘nˇEąDS&YéÂéSfގ]Gú›ă›ÎDžœ°ĆۓޏB[mąÇůŤąčM&oŸ~F>˜ž)ËŇŽĎ#Ç%“CŮÝA6é#›Ç?‰+Řź|ž3F™}<RwśÖiÁA&ÚQŽĺřđßvsŐ˛Ţ ýY–Ľ%žĹůçáŞůK“čâsŠI#¤:ܢ˘ëÁ\%ÔśŻçÉÉçÔ4ş.)ľ_C2nö(ŤRTG;kR‹G494˘tx–Šď|Ż>UšPRqŠ{%śÇ/ćrŞŠpwœ6Íě}(˝5ۏ4źœgÔG2żŽ}NIƛKčq5˙čz˙ž“•É~ëŖY"ĽŠy>wÁ’ĹńWc§KŸá˝2oK|řńăfńEJ2MUJ•–1dů“Oł>¤gUN>Qdž6)b|>ěűřů<:žwˇËÁ—FEŤŽĄŁTTąÉI{.p–9¸ÍSE†ICôśžçlřć]ÁôZ’dSk”qĹÖí§"oÜîœ2oŸĐóĺ…ÇŘҗ“2W/béžRTWiq{™ҚŘքź3’zRwVm<•u°Ů‹˝™Ĺknö$ň8A˛ă7toIÖfP•*ňx2e–Gť&IĘRš;1gżf3Lkwm„´ÉKĆç4iGcI]gÔJNíŁŹšKŔ˜Éé*Š¸~—GHőovp˝Çs9q㗵=‘É-ť#$ůÉîqO¨Ë-*3żňŔÓé:Çw"_ó´ŰK+ŠZ•˙étUŸTR…ŻéáŻ÷9ü –ă&śďÉÍăŤQZŸ›˘˝_(ťRŠ÷Fú~˘Ÿë‹—Ž9`žYbxÔÝ–MÓéĽń)ÁęďOqŇ˝żĎľ$¤šđŒË><˛˝_“–<ţĽ5śÝÎżĘ╹ĹŮtÖé,P”á8WÖÎ_ KôÉětM„š~ěëđ űoähy"ŞIKšŐGźZ;>‘SŠ4żżŘÄpĎUŤŰŠ M-ÝűŁzÔeR§ô.Ž-%÷#…ĆÖŔtת´~§ŞrĐĽő8FN­QŞĘîľ]'Ç˙.Tß4HćiżdsO#>˙TkEÇKTžƒJéń#Jý‹ŻWƒÍđęUkÁÚćęžţ ŁnËľŘŒ§­íŕÜSŠÝnW)-Ťö"Ź´´–űÜ/„U-RŇö÷:ĆQŽÝŔňϧď#“ÄĄúclőĎ"|đpžH.XJá–mBé_sÁ9§i*löeq”řňxrd‚ËQŠżŠ§<˜xćڽιĂi7IąÎ yÇRúšž\Mĺ~dDӒq‚'ÄĺęŰđYOž-œ2ĺÔŠ-€ĆL‘şśŃĆWaľ{™“÷ ¤›íÁüÜţĹ˝MXE՞܅'Ę0ŇćÎ/:‹ůUýMc…ËŇ=92ë–ěć÷g%>cš—–RÚ?*78s´ŰsžŸ’ ĺÝř3…źsԝIMŽ ßs׆Ĺí×&W9nŢűîqmŮ[B1ż™ż•rk+$ٌ1&ň*áç%żäĚ%ŠwďŕÜ\_;ŁÇɖW/)Ón/ŁĹ5ő#r[>×SMĘ)W–rɑÎOe~Nř^Ký™ęŁuËŚqďš˝-ËvGŹéĽ‰ĎŘÜq˝)ÖĚR\”Ű›šL„T@*H€(€hX @ X " ŮE Č°iA  B”×.ŽhéŽZe^I—ő¨ôáq‹Ő%g|9\­%ňűœđĆ/,SIŚo¨Ž™ę‡3ŔéŹI9]>6=‹§ N{)=˝ý˙cĹŃäZ8Ž´śłčEk‚“•:ŢűýqÁÁŚéđsqr“Ţś;N•×s-]ĽĎú!]E&ěôő'ňř>"ůű5[ýŽX§%$╧tżcßÖfyńcŠZfŁżoŻŰý€řNPœă(ż—”{:nŁ¤ß/ąçęaĽ-ŞŻ{5‹5ĽeN-n<ą”ކž§.ŤŠX^˙2|ŃĎ,°ăšř{5ˇĘxóNR•:Ż,š[]ĄÔ)9FTĄĘ|Y¸ż—eÉŕ“´•Ú_ƒ×‚ž8ÓěTŰm{ţCi%dűŠîŘF%4¸ýĚ9>ôt’Lçđ•„rm_!Ż&Ţ=ěË]‚3Č !L€JpÓ%÷ uw„Ýͤ™*ý€śŰş4řhäńꕹ6÷܍ÓٚÇ;¤˛Vt%؍6W%{†ÉrˇŮ¨ŠÓŘť×`ˇłTŽš"°÷,bÚŮ}Í5JŮĂ6y$ŁIx7LJŇWITVíe™JӎÇ&ůdŐGŤ,bvԒťAUncQ™×f›dŁ*E°şZ˛Y%‚PˆP-’ĂdŘ°WŔ@X9*– –,  €‚”ÉJ X’Ŕ"Ŕ˘Č˜°ŠČ,TÝ7ţlN'§Łƒ–KŤHÎ_Öě{ńĽ'\ŁŽ8ĹI>XSŢöŽŽ ˝VĎ q땸mşđyňF›÷]‰Ÿ9)3ÓIÂŕś#^Üń¨ă­ć\Ż'đçoKđűYcjIĆď˝ šc,“Ú1ýEÖÇ>˘Xqď6•Ÿ?/S/đÓoÝR8uDłÎŢŃ\GÁÎs’ŠŤ~]œx¤›Ź[˛ss›”šd:ćÁ,4eim{nq;K5Ň(䅌œdĽMpĘ;ÖYtżĄ¨Ž_”yϡÔZ霚ćv|C—[•lÓś˘x&šÝwLöCŹĹ'_4[óÁóArăÇ/hűnć´ĺŠyäóő^žäÔşm.>/sŇ<ą?*ޏĄ‹Ş“éç’N^/†qÖ\wŻKÓćdÇɟ^]7–ů9đtŸý~3ŕů+ź3ž{‹‹iŚš?AŽ1ŽE' űî|†nŁ&œPJé4ˇ~獃+zg)§ƒąôý;ŤŸň˛éŁŠ8Ë]§ŰÇäůŇ[l{˝ŤKšiâ–IN’ŃÉߒtÎ/˝éLá°Éĺ[ŁëĆiFÝŮäY))Ć<÷ŇtYü×ö<9Ykž3SLú—MŻÁrœŁŚVœ_rźQxV9ÉĎJŤ|ˆÉ+đŐˇéŠŒyst‘{ăzYpG.6ţ+oĂLë/geWFZŇÝ/”Ë›~4śiđŽrOKŽ%ń%{ßaÓ$ęřúž9ő8›IN)żóm“Đ㑫I_tpÍVᒞϺ5´ŹŹ‘Œĺ­îřî>Y9+ňt“ĝI´¸JŒšă‹J/W‰¤eĆTžŞ‹îÎ.ی”Źí8ęÉúeŤËt‰đäâô(íÇ{/l¸Áˇ:uîwxę[MŰ\QÎ<ŰŐ;‡GŞĽí˙¨<Řă)dŇăqo{Hő¨˙.ޕjś­„qcr­JO˛[cĆ­=_MËś´Î 8dř˜›Ôˇ{Ş“¤eŠˇ9J^í/ô;bŔ§œO†ů5ĄĂŽOJ•>ڙ6iç͍ôđ_L›ĺ5ÁŹÖ´čj_ćH÷$Ą˛]ÔEӃ鰨ÖHJß~O4şE—KČĽqâŢßąôlP٧’8óGJiRáŰgIľu:;ÁSŮrm¨Gćj6jQăXŰi¤×eÚĚË™nëÜôĘmJůKƒ]Ş.ÓH”e r_wFáęMűntxăýQú(&öx˘m\š’‹‹Üę—ĘÔŠW‹F%QoK÷Üąę!ޛă}€i‚_ćf˘ţmšÉ%ťIĽ}Îżkć1°”Łm5řDJ 7MľěFĽvÖçHZUHÎÚÓm5{řěu×Iśƒ{*Űč&˘árO`<ňőťQLçüݸśë¸;AC~X×vyó§áť˝ÎręޤÓŘç,0“żšť+$”WʕŠŚw]%Ô9÷hă’m^í˘:K}žœœňdŒcľšmbYšŞo~üœ[wwšiMśö0ÖäŰşC#J›vW;\œę‘••]-Íá†Yúg,änSŁWťăÜŽ*RRŽĽËEË ]NŇešşćůƒ[IlÓ#¸Ůíe—Ó›đjť ę1r‘çɝľQZQŹ8î^„ę$ţ&›ŮJCیÔШ¤‡KŘŞ™ĎUMŮvʚcš“I[hÓg^Ÿő:äçɍY’ŞžťMŁ×8Üg‘ěÚ3ǟ”Vţ+Ó\Łšă`ƒ^Š¨–ß&ŁŐžRđ$ö 5&ŇŽĆˇä– Pˆ!H¤( €€*€( ‘€HP¤R @4Œ˘ŞîTŻK-qěœw=Ž*J-Hů8˛hˇ[OŚËńq­Špyyxün猰Ë}W)Ă2ŽöžÇŐÚăMlxňařžŇFúY=r„×ÍGIÓÔńĘܗ qá… „ľËzt—“qrkm^H˘ÚvŞüqż‡“TŻ•Řď>ĽG ¤•ßwýŽoČ­IiňÎrÓ&?üĆă|PąMdˏ[J.Věúy#‰ăq’SOÁćéąEÇ\w’¸ńÉÚPŽe(pű’ľŒxóÎQu%ŽźžšӋ{îőS?BĽŽK ýŽ›“ŚÉ‰S{Œ˘CĺRůmq}ŽÝ65Nš{đťúwĽ56•sîtŮZuŚăĺ"ŁŃĽy$š^âíßbJü™“3$ŠŁAů9IŸ6ˇ \ŢĆ[Hé*9ËMň˝ś"i˝Ăö3ۤDl0ăL‰ď]Ę#äŠ;-;ÜZD¤—s&žě”ŕ+n‹BŹí…6Ś’ˇ§j8pMcȤßIšĂßlg˝tă–zqľ_ąănΝFG)ťgĎvřÍ}´Ů†,†śŢ”T¤ E°R DPB€€R€*‚‚(UÝŃŰ؀&× !@@(  € }‡GSŐć꼚Iéâ•Q׏ŽŰş–¸ÚŐim|0ÝśęˆT›áYë`mžHw]'P˙ůR_UFgƒ,?TěgĘ~ŽE[3´z<óV ţ†ĽĐőŤ‡>čyăú1“ŞÍ•TŚęŞ—ßÓú^\ťÍč_K9çôüŘ'4ŐĆ ő˝‘™–˘ęźźšxçr„’şÝ2p’”]4íě>¤ďüxj^cł.W)ę#Ĺs—oěwĆ˙—Âĺ/Ő-Ňgˇ¨Íƒ7E)cšŒŤŽ˙J>Mśfo9Úޗ$ŢIšĘ­óF@:#ś ’Ç'$Ý.R|žřĎúáŠĆżĘ÷>Zt{ş^§ü8Ź“šj¤Ž<¸ď˛7.Ÿů–ĺŰďśëěx2ĂáÉŽWgäôő™¤ň&šo˜Ę/ąćÔäŰoy=ýÍa,‹[ĹzSŒSŮŚ}lROoćmsî|WI´ŠűžÎ“ŠX˘Ô’iťŘœ¸înőŁý<ů*Ž›×uŰŕóaę!9RkěÎýL–< R’J[[<Úí§ŻjTĺögŚ!84ÓšxGĆéócœídVůÜú¸:Š{ÝW“9K•Ď˙.zZůťœ¤Ň“şť'YŐÂ3Př‘ů(üňÉ8%$ŤÜú}/Q’p_"QíDÓS-˝Éť<™Ľ“'YŁ]*ˇO„uy%%Z”_ąšŃs{´š$jݡ<‰ż§s/Löڏ.LîţSœú–•Qt–ťdŇŤKg†Yd팒OňwNáošăužVľv+ŽIÎöm2:Ľk"sm.+Á4*ť5Ä\’ŐśÉuaZěÄşťK74›|;p’żó#‚tř=MšEŢŢäŃšëǛ‹ÇvóO¨keąÁÍžYëž,Mî÷úž\ę1)× ĽőZéŹ7­§šŕ†WYęŽG*Ł¸\ţÍřÖ§´Ô¸Ěćŕü•-×&włJ;BňJšr›ů[9>NłUô9>6#5–­íšÍęO…ô+Ô˝‘—űKěs„ťM´P•nßsŸ2+ůžä[ű™Ť4÷ú{Ş@.¸%śčľä^ԀŠç„i_rđFšâäޘkkąÇ&eˇwěyŸS’šŒœSć™×;nŇËgMőXó´šßzNëŘóœP @ ° RôôO/ĆӊUk{đyŇmŇäű^™ŃJœç”šO˛9ňe1ĹdŰçuqË Ÿ3¸žŕă˘oˆËđ~áŠÝOĐ飋ŕj”ÓOˇúg>Ś´×†ß‰IÉŇVßcčáô|Ů Ľ9Ć–ÉîĎŃ˙'ľÇbű6ˇ,zJ{Iߑ—=žšœoŸ‡Óú~Ÿq„e>5K}ĎN.…äůžX/d{aÓB<ťWÜڒ‹Ó՜.Vˇ0yáéřëK—ě‹˙Œ^ÉI{ş=Ç*š4Ű;Â)%\˛>dńôé¸4â×ŢÍ>‡ ůĽKľŸM`Ç)śńŚÖöË,QŠßdéóWK˙—Ç“çúď§N}2ˊoN4Ü űŸĄřkľQůŸ[ő\Ď6^“F0ľ6Öí˘:qKré2łOÎÉęwˇŘ‡šÉ]v @˘œÚŠäéüŽ{ib“Ż Î&á’xďDĺđč—BJ2‹jQiű˘ĆJMĽ/f%“$ŐJrkݘôj%Žzŕę^Mĺę2ćU9śŽ@j{7štŃîÇÖuŮ#ţe$ś¸ÂĎě^ĽÔF`ă ŞâŒĺ7ôąçÍńFňťŸ{ĺĎJIĺ›uô<”§')6äůošőýĽžG)ęÓëƒ<`NëîôÝ;š´×֏T:YĆ*Ü~]˙O'n›ŚŽ,i6ŰŁŽË‡ÉâvpqĽĽě¨ŻkOö78Śˇ‚AľľŚ˙šrž×dyłtř䞞ÝŃëϟ,pyŽ*rPo˛oƒ3œq›Ś— rTÜŻÔąI×ŕôbj_Šoő:őPJ)Ň<ŃŰîVu§|‰WÔćąăâŸŘ‘œ˘îí.Ěë'­)Xoäc7z-3?𕒒”˘űř>Ž ŠjPŞěŸ&–h5[ę÷اŒyđŕĂŇĂL Ýxĺ9dmĹKKňÎđkŸ<rq¤­6"éĺ”u(EQ$˙§KŚKzé×ßÉĎâü˙ĽW`9c’„\iľÚŮŰT§ł­Ką%äáSóţ†ÝéŠ*~ÄŇą%˝VćŒe˝ßĐO#ŒŸÍm{ř“o楤mĺ~&~,Ľś›ZiŁ““J’@o&iAÔťű\­NMˇ^˛Ç)?Őó>vŕÎ_„Ľ˘q|oE‰^ydŒ ő=߃ 4ro&ďčtx°7' ko„ył`uŠF‘vĹ­ŹĎUÂ׆}ŸŠŽ6žLW+zÓżďů>"ɑRŒŞžĚôtůe)Tçťßrí6űńǃ¨WŽJ-oWÁË$^7%‘[sĹ,RˇŞ/ĘgŤăüLU);Jœť5î]í¨ŠBQsғ˝¤ŽË_„ž9˝ÚI8ĺŰćj)>R7kJMRúnOú­śŐęů›}ÝśUmx<ň“{'wÝěXÜVëblvxŰ÷ú™Ž6Ÿ ČŰŰćvť9_ ŤŘ›S#“w+oÍԟnËÉ×R“śčă(žWé|1ľU:Méz¸ůxDŽ]2¤ÚŁ–é?šŐţޡőĂ>E R2ňŰ[/w¤ňĘTž§/Śçžy$üŻKtúO&Ű8ż°řҌ\ZI>ZgĚYœ{ÓĚă;w\nŰ)äöeÎÔ.99ýÎɎQŢO›K“–YĆK…ż”yřîľß^5'IĹxLë‹=­*Të†xÝł T÷fdúęj­Łœú-EťOżƒË4Ş“Zk–yňçrt–ÉěĘדÝ&ˇ§ÉóÖ§7mšŽdšÝ׃˘Í­RMĂ6íźk3††šŽœĘ„`ůóŕŸĚ9?™oćĚüHśínůd6ËÚˇż ť‘i.ɖţÄŰ5“Imm˘đžÇ ÝE-1_s¤›{ns}>š­-%ŢÎü>6÷팮ž7&ݙ”›äôĺé´ŚăŘňľOsŮLlž—j;aío“ŠäěĽÎ/jDú/ăÓ.) ľoîq–xîŃÂY\śn$ŕËí­ł&­Ń–Ĺ6é&ÎńĂľŽJüœ˛ÔŁŽrV‘Ľƒ#ě—Üô)Ş¸ĹľějsqJIF—'<÷ŻFŢha’Čľ$ŃęjJ›[>e’+iVÖŮĂ'Xĺ˛IĽĺł.K˙{îšŘë- ž¨×ąóešRw˛ÚŠÔęŻo§꒭N¸  ,X °d R)’˘Š@@Š @(   (¤,!d°¨ € ĽFJopöÜÉl§çœŚńĘMÜvżě~ƒKĽŒ ä˛ăýPí$~Fq’”]4~‹ÓúŁ’-|ËKž>盗wĆý>”ŕňKü6檸á—&7-O<ž\ŢąMę>L.XôßĘ÷łŚł§ëńJX˛=kćřmoţ§+†RnÇI”ôÎHFpvŢţO„dڗäőgËIÉ'}ýÎĘĺ‘É׳"W'Ň4vđwéąÎ2oŮűĹ9)¸ÝŢ˙CكLĺĽĘ›j‚É^Ż }–6ĺ“U8Żk?đ”ZŚťŹ‘†'WĂŮ#5‘OÂŚMŽž9D5ąěžIÜwŘç<1Œn™viâk}ĚNUgYSž-ÓťŠĘWɌ”¸:KvŽ9?UfšIžÇ9śŇ,ĽWěcUÚ­ŠËxâ܎—Ę9Â⛽‰ťa°÷nŒ)ę[×[îkGŸÁZlŠxäŐüŚUł Ž[3gI8Ĺßš:‰´´~O)ęă⓺žÖČÝ@Ľoš Ż˘čĽŐNŢŘÓÝ˙˘<Š[?YéÝ6›ŚJRJ\ýÎ|™řĹĆnš`ôüxRřx’ć{łśLpŠ‹RĽá>N’Í)IĂÍšˆámšeiny-ˇŰśż§ĹŠä­řIö=ŘŢ(EGÚÎX–5IEýNőHÍjE~Lëmě›,bĺI&’:(éŮ"5śT/ŸÁĽtťFév2–ągLu{˜­ěܲĽô’RU$š1mËaäĺĽzcŠŘňçéqu”rB/RjÚÜîźy2í ośäú~gŹţÉŻĽĚŚżË=ŸäńKřŽPRŹm˙•KsöOS";:Î|ÓÂ?Ÿçé:ŽšN9°Î y[~N'ô\ŘŁŸńËôÍ4ĎĆu…×ŕČâ°<‘í(ogŁ–e팱קÍLŘ2ŕ–œŘ§ř”hćuaÓ šĺ§Ÿcčbôť2¸Á'áŸř{O“ŇńN8÷MŠíý_÷GÚMVǛ>lĽÔnc4ţuŐô]GE‘C¨ĆŕŢëÜóŸŃsáÁÔŇσJă\SŁçő?Ý\9_+_,ľşLÖ<óě¸?Đ?á>ŠA5ŸŸuNż'‡Šô/PéšŔň/8ţcŹäĆýłŞů ŢLY1KNHJĕaŇd–ňZş5lžŃçąônĄ4ߎ ŻNë$ž^›,žl“)}&Ü1ÁĺÉG™:?QŃÂX#qKtš<^•čTr,Ůą8:ůc.~§čúLi9ˇď]Ď76{şŽ¸MvĆ.ľä’Ő‹ăŘô^îˇ0Ą ąˇ´×(Ÿ+_ŠkŹož]‘C}‹÷:WĘBÝ3“ćÁ'NM+J<łĹ’OăC%JÜn˛Fš>„SNюŁÎŁNšýĘĹöĺŤLj2ůYçÉÓRuTýÎňÄătő/&2ćœ~\pSÚÔ["íâž)ÇxŤ_š!'wOč{–)<ť­ë棗Q‰AÚçšviŠ†F“m>̒ŽHĎLŽĚ˜ŰOj=1—ĹŽ‰:o‚ŒE8ÇUéűš“riyä‰iOŠŻ “N?*ŻÔź÷(ܞ˜F?‡ŕĂt÷Ş÷,dĽtżÜĺ=I/îY Šďiľět–I5ĺ3šĘđc×­ńö&“n917/–üw8ŚÔ”cŠŸOhoľľÉ†Ňi¤ŻÉŕ–śőZ‘˜ÂN\šx=ň„\ˇăžÇ<ŤEB'ť&ÄX–,ZŸĚÚ>szş™_…\ŮMSNäÎJMiTšÜŹÔŸMEd¤›9fP[E*H÷m>ŠEÓJ;nłCĘÔŰmˆ•› •Ę-#Í8In×úNp‹ty2&ß$ôĹz:~ĽfĹ(f2â]ţ‡Ś-Ć[Imî|yJQ[Höaę_Q(ĹĽ­*ç“rífOtąl´ĹožĆŁ9ŐR—řRt˝Ľ[} 94śTŸŕŽ¸ÇÚ-{ěX4îŇ_s”šwM#ză'+‡ľZ`Úü­ÝśţĽ”śýFEßJ÷hĚňB)jďřúŰnQ˝žţ䚸´ßÝž*TíW?bâÉ?›âԗd•PŃľŒ”/e$ÓäâÜ\šI—.Mśüny]ę­ÂZé;}ŻĹRq…VÜŃ˝ Kr,Ş’œwđVvÄôĘ[ś‹“Ž™„î>Ě2Ö¤öhĎ~62š{Vëš^ŰŘˊr§ł Tů‹S§ůť)ŇÓÉÎŻvtXö˛É.ŔsĽŕŠWr´M,ˆŞ›ÜڄnÖç=Íc•:­&ˇŰÂ4ńIFű3šnMŚ¸îoT⚻ &Ÿ°Ň’0łSÝrR #IŇăßÉzZ\†ëcW˛o¸—WicĎ “Xž&Ý]łœńĆ]OQ˘ĽĎÜóÉüŞĎĽ†^XíĆÍ^žiAřN´ŸÔď)*ÜŕÚ-Ž˜Ý’vî’úČeˇłŚ–4–ß7ŕgÓĄœ0MBMżęrFMF=š8\oÉŇ'ĆKQU#œ˛JJ›ş2CŹĆEkSÓŚöđBJ ˆ  € €HP € @  € @UĎĎwĽĺәâ“J2ňűžH–yMŸkÖ1d͏X­J ŠW(ńz_Q.›ŤNţIü˛úşşpË9.JOJógNť§qO<"”Ţ5účs ‹őO/)¸Ň~M˛?fwč}GX<*2OĺˇvźęRÓqŽŢç›,n7Uťw7%šPz“ižĚLiJéŸ5˝Ž¸ĽśÄ%}XĺřłzŸËF'N5ôÖç–zmIműľ/†ŇŮžţÁľĆĽŠ.E•ÍZ•ű+Z^Ő˛g’Y'Ň{ľş"U›QäăŠ6÷=RÇŞ)ł‹ÇŚEfš[KcW˛ýÎłŘóĺË-ĺLLmşŒŰŚgĆTÚś:{§UŘófęŻhlź÷<ď$ŸsźŕëşĆíôúm-mLĚT“›qzG›¨fÇ ŠCĂ5>śś°Ť~üŕüŹď/¸öG?ƒ,ÉĽŢ¨ňä깨ĽoR|ś¨EăqřtÚápx[śuœXÉÜL&Vöô.Ž_ĺÖe(jşGĎ)2âĆş>Œ'ń%%ěWx1dxĺkî}:R‚O‡ÜăËÇ1î$÷§ÍÎŤ+9ÎŻIIvŘńžŒ2ňÇj ¨Z[Sż @jxĺ ÔŠ˝č‘NRI+odA o,T&ńŞz]9'vtéúL˝LÔ1AÉżłő/Nxă)Í(ŤoąúĚXZŒV]ňiW|YǢôŒ}$“Čţ$ý–ÉŸF1ˇZ~Ǘ—’eÔvăĆÎë‚•ěˇ54zŁËő:žČÔpé}ŸŘáˇGŸhhËÎ/´•Łâćţé§Ôkǚxńž`•ţţç݌“[4ţçOĄźr¸úsżëMÓbépCéDz:¸˘?"2ޙ#wOî/žćÁ Ö`šçrJrşŒW՚ŻŻäšb‡ü]šĘÉ_–ŐĆčóő]˘NRkšŕő4¸OvyúĹtsŒ ä˙Ľ{ˇK÷'jůýĽCsË-SMĽ\#ęôŮáÔôđɎjQÔ¸té˙c8đG% oJŤň|œyrt>Ą8kŒznĄšbľ´rwľš“fŸfsUłÚů8ëRž]ďąózž˘}OSÓôЄ­Ď\—´ëGł§Éţ5ż’ƤmIFUtͧ§Š%/>N.)ĘęŃŇ˝¨ˇ¨ëHßĘűœţK“-Ws;g[wUٕ:8&Ńľ$ţŚś—]ĽÉĘXâ—ËkÁŤTŠIŞ­‹´ÓăúŞC¤O{ĎÚ×ýű™Áë?[žt8JK™=ľx>WńAü§T§Ž)aČ­$Š'Ý鞼x°Ëšye+öSǢWOžăćŐUwŕÇĽőŸĎtpÉ5y1˝3ßđÎúm.-–]WYÚĹęN2nű6sËŤ çWÓąŐâ“Ýo\ÚŁŇĄˇ‡¸ÚšŹŠ[Š|ÇŚRŒ ŻƒĂ5ó$ŁOŰsŹŁ-3i/%‰ś°ŢśĺtŮěÇ4ą¸ZRžěó9Eľ˝Óüš“ó—{ŕ¨ôä}ܓú3–şć’3Î[Gő1đ^ĎLĽěM.ވüňێLewd›o“S–e •Ep˘žç?•Î0ۚ&´ťŰ8`ńˇŞ÷îg$~uUmě‘éęzŒćąÎNÓßm‘Íő:Záó>É&ˆÎŢigіn4éRęy’”Ű{´żłMqՖŐńţ§Śp†…śA5kĺdÁ'ŽßýŁÍ84ą(FžĽuÁćÎąmJž./‘(ršäćă§uϓčĎjěŕńۤF4bëfţ^˘rž?îzqäÇÔF˘é%Z\œy<2ĆâžŰŚ–Čבť[LOĺƒ_=-9R›o̸ŁçaĘ Ý-.[7Ďě{ądÁĄăřŃĽťľ§ě˜öÜËőr(˝¤Ó|Ó2’Q§_ŽŸËjšQ’qmSžoŽsé%Ľľm&5WniÔÚš›śőIű/'O*M6ďŘĘÇ9:W}¨ƒ9ĄŠ4áŠËźßeؑk'ęR”ŰüšÉ‡$&ľ§ŰWs?i§Ԋšv†HA4ńJ2kwɗ.)Ć_ŕĆP[9ĽşúîĚĎÂJYrMmâŽ3ÍY#ŠQQ‚V⿪U{űôÍŽŸËԖ˜´ŠZn™ćœtÉüŽ-r§Ňĺ–^‘ÍčM=“ďíG AäK$˘Őź} ĽŰĂŠMŚŇUË9Í5ş;d„aޗ5űŁ”í$ˆ‹(éIJVÖăő13ZľŞ|'d–ŢäŠVö°ˇFoa}’Ř€ýČi"cšŇŮęŕţľĎ)Ú°§Ňéł)âKşŘů‡~›/ŸłäĆxůM%{r¨É8>Zt|ƚtů>ž9)´ŰůVíŸ6OVIKËłŸćâšY“nRîŰ$ŢŠ9W'td-ř؀ Ç$Ą54ţeĂ{™śŰ}Ř>ˇđ˙ŚÇŻëŋxąŤ—ż„Kd›ŁżđߧèžNŁ4á ”Z´Ůú}ŨĆ0OÂŁŚ,8ú|z1Â0‚Ů$ŠóÜę+łłĹž~Wn¸Í<°ČázŇm÷=”oݖ8”šŠcP‚Nœv0čÜeóĘ'ŋžNΤčá8Űo„FfŤ›Ë*.§{œž?šŃŇ-wݍFÝ Ž“Ú6ŒCƒĽ|ť™ŽwŰË(]ß,C`žnţMĎĺvŽ2•žM7íŃGŁ¤łF;=ž‡“%ěű§Ç,Žz–Ô]%vY`ă)'tăWvpxťaTqo$2xíw§Wz˜KkláÍÉ7Á蒽žäłMJ'ŕëÜ\v§äóꔥQzRäôăŒZŤwîMiœŞĹ;­V—ąŽŻ_Ăz.ýŽŽ-{ý Ë&ԕö5|œy2,ˇ{ŮöńKTěësÍ–mn;Śzé.mg"[ÄÄU3Ľ…IUđsMęäeÉŚ;nq†I)-TJł§¨ŸQvGdľ‘Žk“ŸQ‹âŕ”bôÉ­ŸšŃIy-Ť˘Żn̲Fq”jQÚQđ|îżsFx¤ôŹąŤćŸf},řuÉNLŇŤŤľážN˘3ŸNÖŰ=U˙ąŻ˝ľ§âşĚýKĚńgË)Kpäű^ÖžŻÖm劭ŢňG‡Öş?‡5ÔA|˛ÚKßÉópe– ĐËóEŮëÔĎœ÷qŻŮBS†XÂN”}ŤBçAę8ƒ4tÇ´—cÉ×ô“yg“ucçRďî|ő&ŁßŇőşŒ’z´ąÇ.—ROšĺ}‹•ĆYdá1oeŕC$ńÉJiŻ g„ÎjłqďqôSq•îzńĎĺnťňxąäŽX'Äźy:Ⓥç“Éq¸ÝVńŻĽŽ\7Lé’ sśő+ż™ö<ŘroO“Ő ÓođGon9đĆX\œR’ÝQć†I8--młłśYśÚožäŠzçŐnžĄŒœ=S%ÇúŸ0öúƒ’xă'şLńž/é@*ŁŚ<2~˜í坣ĐÉŤsŠfnr#ƒË-:VČÂäő#:ľ8ł†L91żš"gőGUOĽr‹o$7’kąÁŞVXÎP´›VŠű“čY!­ˇěFšW䪀 j*ƓmáĹ,™#§)7I#öž‡éŇôî–o,—ÄĘÓkü§ĚţčœşŠŤQÚ?Sôs•˙ąççä˙Ěk žŇRNŁđŇű™Œ’ÜÜ&ĽKuäó;^–;=ɑmh)w3)ÚĄ˛Ką6—Ěö8eÍ­é‹mĆSÚ_¤T1đ‰ś¤f0ową¸ăIÝ3+*—.ŽŃ”Vü“kfbŠ-žĹ”ŒŠę侸r˙Ž9#Š4śö=šQ‰.ČFĺq„[IU3Şůa8ĹRKosuňîŽro(§OdŹŇ{X8CT˘”Wą™Cv›oos”böOšÝCNfăĂTR]2u,oŽĚäŽ9“kőmô=¸öł˘¤Ó˘m%íĎ ŻęzVÇ(5ářą,­ě—ÜÁe´É“˛[—§|áźÖ×lőqÁ¨euÔFˇTé8ǖ—Ô“•lxdőÎK*żi™6öË*NšfďdyqcÓ+})IÎőZł;[á‘JSÚŐűœ˛-*ŤsĐÝžL¨)o:˘5.Œr ů7k•g5Ą|§lkNĂISCMű–*#ŁG jŐňNš~9+;ŰťWšáę+â5Âjţçyő üW?éWvx°Š˙3—$›xäҍť4¸źýVő=+Ǖ=ÓV•ŇňĎČu>N›+ǖ5%ř~çâÜŒW'ć={ Ë¨ţf8ĺ,9 ›’V˘ęˇ=9wŚsŽ~ŐáĂń°őщ5-ę×oߟcďźIF2RRŒˇN.ÓűŸŒ>× őjčćíKć…ö}×Üß&úŒă~Ÿc—)]mů=xĺZoÜđÂ7]ďąîÁ‹#ŽŠ–=t•ßôŚäŇ÷6ĺr숒kgş"N1’oňĚŤQkf•Śm¤Ő4rĂNďąßý –Ś ›OąÖQS‹‹VžĚĆ%óI~˜ËŰá˙tůפC§éŕçj{ZKƒňř˝7­ÍOM–Q|5CîbR­‘ŰkŒôǎߋč=Şę:ˆ,ŘĽ‹­Měčý/QÓâézƒŚ‚„b¸]Ď[É{YŒ‘Ôc>K›Ś8iř_Péeƒ3šßÝĹŽŢǐýž~–ˇ„V—ĚkcçgôîŸ4eÓŹs|N*ŤíÜď7ŐfŕüÉß[Ő`Žœ]FHÇgJNŒçéňtůĽ‹,tĘ/óô9Qßۛ´úΧ$ľO¨Ë'ĺ͘řŮTœž$ľ>÷š€ 5Ž[î÷>ŸŁúŽ^ŽF3—2ě| L¤ĘjÜĺÉ<í\”cŇ8ŚáŤě~OÓúůŕĘľÉĘÓgÝĹęř#SżQvxóáË×mĚĽöúSŒńGSŠŻ'‹.FíĽv_ćTŽ×îqžEŻ™ÍŞäÓyobK#şVuíIUœŠű$I?‘Ľą…I§ĘE´ě-•-ž¤Đ[¤hmŢü™n•E…‘ÇÝ #tôňuÇiď/ąĂV9˝V×ĐčӚ¸ţ—ܲ,oUě_‡­ď#žŃŠÔŰd”ăuş~E’ůšîskwˇbÍű˜–G іkŽHvîb’[ňuÉ-IKMyö9Ëtš-šg{\Mˇ|•ÉÎ1‹áp‘qUJţ‡L8”›“ý!dsÚ*’ŚĚˇň8ů÷:Î 7ó%[S1MśŁŔFiŞ[˛ÉާˇƒKÇ%jWi…fť>lŤžĆ •îŐů7ŁEÜ]Ž}Š8ÉJř%ł´Ž˝Œě•˝Źˆç[îW˘ňö/z"0ăKŒK”uqžI(+eV>¤VöłˇĂ‹…ęKęsžœ{9$ýĆ­ô‰%A*ů¤éçŠܔŸ„x˛ç–Yx]‘×+—ą×¨ęTž\v—wäĺ‡Ë:˝–íœö=_%~Ťßčz3ţĎŠŇą$˘–űR<§n˘jSI=’Łˆă–cŰJţ €č5Š(8éVű÷B1Ô¤í*ěß&AiĽm:!¸ÍDzkĂF˛aœ ŚŇÓ-öě7Żc ‚ @tĆښkąďRRÝpüž RIÓăÉî‚ěp˙č×I=ťFmVçŤt’OuÁâmW¸Sg›m˧Ť-ęŒÖëÁç×Y\ź˛ŹŽ÷ěiĆ9in=­íăë §“źOž}iE8ĘÝ5Řů™qźSŇ÷đĎO]xÖXŔŠX==$nOą2ş›K\Łƒ#ţ—÷:>’i]ŁŐnŒNZ`ĺŕó|ů[ÔG†pp›‹ä‰¤÷VYÉÎNO–dôÍ붝ßS9mzbůH"„ŸĂ›q÷8$ž“Nńę˛G†šúˆőkçNţ‡€Ś/4}â†|vťîŸƒĹ“LmÜ]y˘â͒-F2I{žŘő8ă”Ó~Ç=ç…ý4nö[žĚŤK›É߇ţ‡–.Qb”­íňíg\sňŠ›jzŹŽŻghÔńÎĽž¨wŽuIĽż,ř]Źâë,=Kxópćř“˙Cß+Y4NöŘňe—UŇWż_‰:ßÁ˝K,UŚ¤ˇ^QĎ˜cýIŇ˙SŽŃ“Ň’}Ě´AiisG^ł Ô­›˝FJ°•*6e#\(Ž9­6ÎśŽ9%ŤdEÇۊMł¤őVj8ř:ÇîYË(ĺ’/Š´aE;m%äôI%şě~ÔýSü<˜a´[ýiňź1Âĺu˛ä˜ÇÍţ!룓¨X04ńĂşň|FíŰ7–ZćäكŰ'ŒÔrŸ´…iH:vąĐu°ÉňÍF9<ĽúŒTÚvš3–3)Ąúg6×u ő áGcĺâërÉ|9Ëgľ÷>—G‡ŕc•%%=ľw8ü>2ÚĆ\š˛=//†Ů%;\†’ŽI%Šś;źFô÷$§jŤs/nÖKŘŇîŮ4ˇˇE –űkIż gMbĆŕˇßڎşăëj994魈ňÓI:A}+ˇ(š^žNsu9ˈ.ěéw“ŽôĎ_Öc†7INRUśénWI}+ęńŚůg,T[ůĽ^6>f§ä–Ůëř°ŸNzżŻĽ,Ť$içŒqżé\ł¤g ‰ü>ŐÉňN˝>g‡*—głú đ—D˜ęďo§pkż4{ş\maş´xc8d‹pv{şi'ƒKíÁăËŽŤŚ>Ü:—#I]¤rÔüňvĎ+”\{Şú]Š:îD­lŕŐŤ^L4ë†đ—Üéľ%OęÍ}Θäă˝ÝŞ~čć›Wi„öبé•F֗iœ§÷ˇą''˛1—:Ă›vÖȲ\Ž K$`ŽR¤#ŸęŻąóe’Sw'f°Ü§I6zg:ěť}i(¨jrĽĺžyőxÓĺșܲa­.×;Ÿ9ňg,lěö÷ćëcĄGšwlńJr›š;fŢIŒÔ&:RVƒP›„­@í,ňxÔŰS~N –KěA ôaę\#ĽŤG˜¤˛^Şiôá’3JKti$ř>dfâí6ŽĐꤚŐó#ϗ˙ČöSER’‹IŇnÎQÍ֙'íÜë{oąÂË=ŽĘţœ|W6‹Wę\źyS{]ĆW[[.â×ÎɆx˙RŘĚa)p›űQĘ2_54DŇ/iĎué6đ˙-?§5Ž͝u$ř#ů•Łž|ˇ)¤JlĺÔËN&ť˝ŽŠŃăę¤ŢVŸaÎňľ ”%%j-ýiÓM?sXň˸żÉŠçžDÔŞž†–˙ÁČę°eTôJź­ÎFľI*ˇ^ wô>—Jĺ,ZfĽqď.čé%(îݧٟ'\îő;^ć˛ć–I&öĽJŽ†Űąě˃I~¸Ć^ěńćÄđäŇäĽŢŅ́L1¸ý,Y$“P“OÂ2ââ馟†Ž‘Ď’ (ʒöF%9NZŚŰf§–űŚ„j›DRĘ.2q’ŚˆFŽŒYJΜ2śÝRŰ~ć”ę=ˇîy‘ŰéĽKľśiĎ,_¨ţϝ4đ]8ťűRXӝň|CĹđpü[_2Żßţ‡Őř˝ĎĎŻ;§§ƒw ťiR_2ü‘Ę1•Däó+[;ěeÉK#m/šÉŰO\2ŢÜłMŤ8,ńƒ¤ŃŐfv Xč‘hóË"‹´ÎË|—Śn5ĐY—4ŒšxѢo˛9¸Ű߄[aťUf[9ĺIŻa çOteťúđÍ*rľ§jŰ؛v"iďfe%A+{žl’Ó’ăľň\łiZÜă,ŸÔ˛5§|=TŕôäŠ+ĺv=ǓŚÄŇšwö=ˆ{Žy&•wÜĽźYÚR2âŹÓdŤ28ĺ‚ŐŤúŞŽŽ))ĽHő¸śű’Iđ,­Ě´ătš1)IŞ˝Ÿ'} ˇŘóÎR„Šc‹÷2ÜąßJońÉęĹ”ă d|Ňú•QCÓ9Ögą›ŢšnOŘErűi=W'<–低ŤÉÇ.M6ęÂĎmüE[îgRw&ÓŻť†ÝÂů/ćťö,ŤâŢHŞçc˒2•ěu†XíؙŚâ•ƒăzǧeęzhň=sŁ„ú?棸ÝdIrŸÉčăĎ_ĆšeŰóÇę˝7Ť]_ATď6?–_čĎʞž‡ŞÉŇgפżŞ/†Žź˜yΙĆężc‰ˇŠÔšŢF \ĺr˝ű6RNj.‡:tťž’Zg%'Mž;Ľ{RÜëjŤpäÚĽąĚ˝şĘiřö8ši’Ovv‹TŸsZ5#/[áDěčĽnƒ’ŕhÝoj4Í6’›,"ŤRWš× n]G<şîžŸŠzÖƒ#ƒŒ§5V“ŁńWRóĺm-0ˇQđŒő˛ue“,œĽ'mœOVL'N~ű Ú€)îčşźŸĺ/–ö<&ąKFHËĂ%›šfÉ_ŁNžÁěr†DéöŤłťŠ{ÇsÁ§yیÝđHcŐ ÔÓđiĹĘ^ŘĄ%ł[ӜbŁVrŃţ"mŃęœkő#ƒUşˇ\Š%kMxwÉĆQŮÉŇ\Űá2ćX~|­żd|žyU¸ÁqŚw/ř–ľŐőrĎ-1mc\/'˜€őÉ$ÔeH@¤(ú\ŃÂŢŤßÁőpÉ[iě|#ít źrě7>?hčŢĎĘ0÷Ż,ôI$ćä­5šçNŽ×ÜóéI&–ÝËŚŮ/W“t›až{™ú#v˘ë—gHŞÝŻŔ4óŐťě|ţ­Ig•÷ŕúŽş8u~&6—>ç^,źhůgŃé~ŃJ_Őäůň‹ŒœdŠ˘]œńóšÎŤ5GDeťć f3Q@°,bĺ$˘­˛Ž‰'™ůQtg+Šhĺ,r‹§™ƒęN-á•rŃó§F8óóDT @€A3Ź:Œ|ÚđÎ@–KíŘőP’ů˘â˙cŹşˆ4–¨ý™óBtsź8|úˆ¨ţ„ŃŹyă“höěx›DMĆV42áĆΒmôImÉ!ąĎU‘UÔżš×ęyrĆËŞŠ9m˛ˇŮ9áÍ998ďgš¤Ÿ[ý †wCŔş|Żúkݲ˙-“}—äúS0×ÍÁżŸ!óeMS!ô:ˆEŕ“ĽhđŒ3ň›T–´§÷îdҧmÚá$T )ś˙÷5 ;ęmmŮw3ľ=ˇ5)jţ”¸ŕƒ&‘’šFš=}<18\•Čň&ŁGł œ%—áÍm"ďNyËcô=:pé1ľ´j‘č„ž]ś8K*ž5Š%˛]ŽnNŞčů™eťkяń’=Қjťů9Nn9>§–9´÷ę­q^ěyşźÍKŮĄ‘Ę;KsćŹÉθK÷;Ç2QM4‚y=şűÝQŰkŽ{Ÿ1eujŸÔé šJ݆ŚOĄńećŠň|$ÜżSđx2ÉíëÉŃ6íCzň4ooJÍ)şÝ‡9C*ňé}ÍękŸ™MmdçŠÉw:ÁdpťÝ˜TůGh´ĄIR°˘œ“Ž6ýĚźŞęN™n2–čĎSąę5CxŁśĎ&-yb¤záJW¸M˝1qěnĎç$ťY˜u É+A›‹ÝÜUňSĎĘę÷7.Ł$Ł)Ľ'ÚËślv–žÄ–zá[/‘ă]ĚÍŇŘĺ.ĽF7G Jęt‰nÉ?]'’+—lć˛jäňźÉÉ˝žć^wń*-/kÉô ’[š–GŮE–:włQËŻŽÄÓ]WmM=ŮŇ\IăřÎĽivÜęę o¢élw›I›[˜y[ł2–ĘŘ$^.¸ŁšňeÎŹńO5ätޞčHˇ-=rÉ˝đHdNš}Ϟó?ąÍu1’‰§+“ëdj\=Öç“4~.,ŘZ§’ +ó[~ç•u-ÖöËń’ˇůb^ÓËoĎK ĐßxşkÁĘ3”%qtĎÓdč0ő°ź’q’ś´÷>]ĐϢšMŠÂ_ŚHöăÉ2sńąőýÉúnmJâ§ňýkô>ž c”œžjݟžô<ŽK6öÓŠ#č`’ˇ7ˇyš'óŽ˜ŢŸ~)4ˇłržSKcćăęž*‹iĹŸć#’KNţÇ6ŐśĽŠóů5˘M~7SÖcéa)ĺZTy´|.§ř’rr]>+´Ś÷üÇ ˛ô['ˇęT퍯cńŢŠęýVnŤ.X].WąÍÓNmĎ$uIóŘů˝WYjPšm>ô^řĺkcó“ˇ/nyW\ÝDó~ŞŻâé’NŁ  ŸkŚë0c‡Ë-¸ŞÜřĄ:1–?i˙[7V˛FĄ6›ýQ}ŃqOV*Oôööě|O‹=}Fç(-ľ/É91žFd˛ďodRś•ńe[JËŢDťQ[žmýΚokg'–**Ő jě•ztŠ§ˇnNY%ó6•} ,é_÷97ϸ‰\3bŽF“ŤěĎâá'Ę>§ęMw<\^˜ĘŞś=YÝřÔyŠ@ßŃâĽń"ö’ŻtĎîčz…ü&ťÚug.Yn=%^§3ĹňVěđŢżdRćŐly% AüÉŻŠ8d˜ô2;(@€ @ ¤@¤€˝ˆ@Úˑ;S“Ą­DzˇýQľěvÇÔcœ”RiűžEđäß7ąƒáĹ=žˇö4 šş<7Rĺ‡:rěßsՃ¨ř‰ĹŞ’ěy3ÂăVźu¨%îxOw¨ÎÜckËG„őqMauP$ürŃčúŤËÔľ˘*Ü/s\đäĎ}4c^*ßĐĚĘ[¨<€öő] ńJ'(Ę7şÜňIS§š}ÄĘ_C  Đ€Ő‚IďČKg¸î@ŞŔ@P ˆP€ŽŽ]Děěóşi8eŒ“Ýv,g?ë_adq_/sPË)m+É4gůL_;żsČçŠÓ˝ÍVýÂíëŽYIí_s´r:ůy´§ŽŐ?<´ej/o'(äwIŇ&I&šąĺśrKćžĚĺ)íˇq'ňœÜˇösšV•ö=8Z_Ş[œ‡Ă¤žžÁ{˛ô1äÁ›Ô׺ćĚőŽhhĘŽzżÁĂĽ’Ţ/}ĎLééK—ڍ:Nß' t>ĽŽRż‚äҒßgt™őĄ†)ź’œ!ýRug‹ŤÉ/ĺrăX%4ÖďÇżšđ›o—Áč˜üÔţŻˇÔúĆ<3ŃÓŻŠťÉíř<Ůýk¨É qŽ%ć6ĺů>`:NUŠNRýRoę̖›WNWOé˝_Q$Ą†j/úšĽFí“Ú{yëő‰t9ŁâŹ–ŻŠŁËŢřîn¤Ł?YÔuQ˓Rú$pb  §NĎąŠnXąÍ7Mn|sŮŃfZ^)>x9răźw>“ÓîBUşĽŘč˛|śß†uĂKW%Â]Íkœcó.o—Ty|VGŠÍ5ż(üćd–iĽĆ§GÚę˛<=4ĽRHřgŁ‚{ŹT„ •ş!źuń#n•L‰FrŠá:!dőIˇË܅ˆĹ7 ŠK”`ŢY+ëBQĽ\IĄšËđŠęžlӜ~Ÿdš>\ĺŞN]ŰłËÇÇ.öžß^JŽ[¤é4öoÁň°ç–)ÚvťŁŰ ­­pmZތgÇqknşvm;_Řąv‘źxÔŇrm7ľ“CO“‘`¤ťlyúÝđ?›ĂŁŹŠšĺęÚXŞ÷léÇý˘<@Ü Ó <‰Iľ|5ŘćiŐ*[÷%ďĄčĎ)âʔ¤ÚKeŰđ!™Mľ7łážÇ%)fČ­üÍR.™a•Î ŢÇ/­_hĆDÓQuˇƒŤZÝBâŢ×Ę8掜˛IR7Ž]řŽ`jŞŻ~ @ (@P @P@P() A€ i4]#a¤ŰĽëƗtcJ\šW(ĚEf3ĂŘú¸œU7M×'ÉfŁ9FŠŐ;8ňaćŰÝÖâ×(Ż™~čůÇťw‘5>Wt3tŽU($Źç†~Ç!áŁG’OćůQÚXú|uŽVßvuó›ÔěŰÂ^^‘hSÄďŘĎMŇO6EŠT9lLĺ›6ëŇaƒÇŽJŰěÎń†”VŸěuXáŠbś\YÎrj/O',îTtÂăŠĘ{DۜqËüĆ[ęG›Ë–ţ§W˘1ӏhűîË5ăSwĘ:勭i§[]ňxşŽç’’’UąŮZŮţ śú™\năVíäţE%źÝű#„ş|‰ŇŻ'ŐQľk‚8ŢÔtœŮDxၟiI%ôécĄ¸š9§ÁôtFˇMWƒ†HE§.=„ćË{./\K*joŸcĚ}X¨ÉčÉź^Ěůů°¸MĽş]ĎO^SlËŢŤ˜ŰJ ¨€(B(N˜ Gś9ç—Tn=űž˜IĆĽ:Şě|¤Ú5ń%Uc)2šŹxYw]ŤÜËNOÉǤËxÚoƒĐái;ŁĂž>9išvËzväӒ­™WmĚ:ocیŤƒ´jŽ[œÜ‹ô +ŹjöäŇ{Ł‹žű"[ľ¸]ťĘjÝłQ|4Ď4ťm íŞTť°mŐoŞŇł4íňuœéŇ9ęr—ÍšďżsźZćř8iśŸŕ˛–ˆÔśe6íźškŸc/"Ó\žć_•$ý™–”§łŰčClĘÔźŚuĆފRKÜB.že˛Ľ˝Šr$ޤȴ§Ş÷#šVÖíœuňëp;Î.kmŸ'/ˆ˘÷ŮËÇäˌe˝4ĈŐí{4anĆԉ.6h¨˛mş|"Śťœĺ*ďf\ɤz>.ĘťcÔľ\{ž%'Řşšä.ëŘú™ĽŮĹŐlî_“Ȳ*ÜR}ĘťŽů3[jšđsł›Ť§aËÁۧ†ĚŠˇŘ9IďÁÍ“vKÝmxhÔU. /fi6Ţɖ50ˇÚuąďÍ䫧[ŰÝ==+ĺŢFŁ“*jäč­K§ÖĂđńÉ6Ł>W6“Őz˝ϤËcoxÎţ_§ąéÁ6—,úËţďcXĺqî:Iäůx˝Ľřu<ҜűÉ:_c×Ňú7MÓÉ­:Ł[šSr=?]Źo^>Ä˓+öׄŽpép⼸ivŁˇŕ߆ľ5'îč–›ťŽÇýD:l92äý1VëšÎnŻOÍ˙䜎ůSR„tťî|k:už~Ł&Ylç'*ńg#éc5$y>Ô@€ąn2Mv űX2¨éš\­ĎRœf÷ƒOÜů],ÓĂWMţŁŠ‡IŠ2KVŽ7ýĎÂĚźcXޜşüąŒ%ŠRzœvGĆj™éŽoÔëŢ.Nüšë1ßřŠ%ĺ#ю°Ö?ŹîÚń€ŞWtB€CQäÉźqՒ1ňčgW=<`—ę<ÓɎ9RíĹ:iŠ´ÎQbÜZiÓG<řći§Ôˇ'OosOĺKmŮçéú¸ĘŁ“iyězĽžÍLą¸ÝQ•+:F´˜ădm7flůZŘĆĎÉŇŇJęĚɧĆÄĹWę uHÄ[OĎÔ­6ésěÔÜĽlÜšŮ^l81-SMŽŃÝł‹őEţźśt˜e—¨ŻĄÄ•:ňp•Éž)zžIUB(ôaę#6•>跏)7QŰ­Ýîn2ůŽ„RÔľ=Ž°Ž%Şr–”rœV§˛<ů3?ҝĄŸ;Éj čígł÷ śľśŒš{‡ťšŘ"Š5%fœöäçĽĹ‘ştQ§'äŠ^佨$ěʍłUšZĄ´Ĺä–9 Y¤Ě]07vȞć­>QWjípU}ĚÝpnů"3+HF7MnŮśŻÜ˸ƝTŤ“˘’I¤ˇ1“ÝěŸMÉl‚ľ i“lďK$×xžxŤiHőŕ’Ă?6žŚ›Ĺ芌7ŠTšœRN.Ó;EÂjŇů_cœđ¤šŠI'ɧ^˜ś÷:b”ŻĺżąÎ;şLőăzŁĽUůň+~Ö9rɨŚĎ‡ëýd§•t°ÂĎ˙Qöşœ‘é:l™¸”Vß^Çă˛ÉśŰvŰśüř0ÝňpĺË_Ć0Ő(=N( € P!@ĆN.Ó:eÍ,ŐŽMŇĽěrşVžćNó×jR @5ťN—&ŐÓä i’’ěěÉB˝˝7QŠ8OžĆ:čTă5ėîy ôÉ?žř¸“jŐî™Ă9ᗜGÎ)é˅Nç ˝1׌Sp5:”4řFđă×+|#źńFpzRMqîsšÉ–’׌qqtŃŠ¸ăŽivîz#Ÿ8=ŚÎ čo‡ˇ“2ĆeíG™CTcIöjQ˝čĺÓőXÔ$éŽěĺÔ4˛ÉšŠoěyçščpľ ä€-íD€ €  ¨    R( P ( …  h” o5äű9eúźż'ČÁK"Óϓ鷲Wmňyůţ“í4“îu„T!ďÉ)˝ßšűÍKƒĚĐŰ~ĺQßr7ř9<ŽéÚâžíňä\DĹóšžnŮM˛öŕąŰvGż(–“¤śŢőš†ě׸KؐŠČ¨OŠ\pĹ8ńÁ2骊żp×ӃŰdcšÖ[Ł“ä2’ş´­šKa|”j2‹Ű"Ôź÷G.ŁŚřqS‹ŐÜŇ:cÄOuhíĹÉeńŹe5üŁćžAěÉŃÎ1“[Ńä’iîU‹ŽS/H@Ř@€€@§U(%ďůG˜¸Ë5GÓYąJ6˛*\ىőđŠŹqmů‘óÁÎpăöSëł>4Ż˘ ŻÍßKűPoăÇń^ß疖Ţ?›ŮěqÉŐeČŤV•â;œxĎPŔëÓĺxrŠ.;Ł‘G´}Če‹JZ˘•lěÎnŁ Ş1Ȓ˝Ď‹oČł‡Áčú­Ś”˘ě%lńcĎđrTpď}Ůď›Z\˝ř8ňaâ3-­'ˇ’Ĺş¨‘''Ś÷éŇs͜ŰWšŤKÉĘmo¸Đß4i#Šm#¤%ňĐ°i+d´˘Ń„Ú T܌ŁWh–E"jކ‘Ń:3ěn*ŮÓZmšNŇOƒ§nD^ž˝0ÄŰušŮŕŒ’MS˙ĄĎ§›ŽŢ|Ž§ńJbţTÚ{yÚÍ:ÍiăˏK­šŤ´$´ÖŸÁ锸+]ýŽ iu°[‹ ܕŻÁéÁˆÓkŽ:Ż'xćpj-$ÇŁ…7ݚ]N9=*Ráž\Ůžm¨ă MÉ'܋kŘę9mp÷;E˝_.íńGšžÉ|ĎÂ>w¨ú—ĂŒú|šKl“O…ţUţŚ°Ćçuç¨ĺë{ę3† ¸răxÜ{nü7Żéžöz“Vš=¸Ş…7Ý>˙sїęqF¤Ž÷aw7^=üyîz|Šď›Œ™Äś=’î (@€ ]ű‹ŞI#駲}ĎJżĆG˛NJî4yšďr ßröĽÉ˜ę{QŹŠž:šÉÓhçË5+lÍW%űS%‹´nŐYĽą”[ 7ŕË)R*š÷fŚKŽJŠľ`ÜcŞ\#œ.OcłČ“§ßč(ąČćŻNŸŠTŁ-—&Ria‚rt ŰĺlMnô['śąÎP•'MpĎ|şŻ‰A´ś§ţ§ÍĹďiŁXĺJJůÚÄoúj~>Y5ˇşéé듶üa“:mđWOÔ)ŤwˇŘ:Ç9ăiíÉÂoćÜőćŸőEÚ<Ů4ݓfUÎRVöúŢuŠ:¤ę+šĎ6X㋜ř켟36ić•Ë…Â\#§Ďż§+“×ÔzœĽ Á=œŸ/ýžëÇŒÔf݀@ @4äÚßsxňü>Ű3‘ŇSՍEŻ™pýŒŮž‘댔ŇqLÜҔZqšy<Ý3ŮĆ鎓ҝŐö<—xeŇYżh“‚Tő/ş$ąëN—%oDľFŽÎú”đ?óŐýMË3˙+6ÜăäÉ8ɧĘ2uĚí­¨ćz›ˆns㱓Ձ†üYœíÇakž>šr—dźśz-/ě‹_/’I\ů.}TNܙŤ YĽIQ…B¤žÓľÍ„mśĆyü8ęŤod\wn˘W‚JQ™r|GzRb*JSow˛=›Ôí\ÁÝË ĺ~+áÉ}IçţI9:JŮÎP„kśůgËjľšJ•R¨×ż’âu.j˒ZŞžËą7|´Ž` Ú )P ((   … €  €  €  €  €  €  …€ 'šš¸ývÝŻ' ,Ő{‚)L”˘•Ć6VkżKT”¤˘áşgŐÉKÓ-¤—ÄTϟÓhQ”dţv֕GÖĚńŻGÇ É|_‰Ş^;ž^mů.:Ż‘ü8×=Źă{S5™ŰłžçŞ˝Ă˘=‰ViՑ§F›Řˆ ^EŃeÁ;pQ. &´ěŤî-.v'04KCĄ4Ť°*ä{ÉŞ$RÚŁM¨˘+ Ýöڑ—ť°FrŮ[Ł×ƒ/ŔՕÇS’Ľo“É­|ŤcNN[śY•ąqňšŚHC#mĹĹż›/I%óAŠŻnOK•!ÇÍtǟ)í|uéóZiÓTČ{ó`YždŇ}ěᓤË)¤ĽëgođzfRŹťyÁ\ZtŐ 4ŇP!@ötđ†‡5ťŞú\›ŽĎcǃ&‰S{=™éIÖüNY|ˇV5ůş*•ŞWš-˝/gٖ)§IŁŢL:ks”“gŞmÖęŃÇ"I-šžŔŽMmD{#n?)ŽŔ- d÷2÷+2öB â\ž=ĎF8¨ĆíżŤ8cR¨ľ˛łÓě¸cxšŒĽ*ˇÚ7ŇĺyzS”řڑŽ™Â˛kşŽÇŞ?/đĽM­ŢĎGS^YnVHóuš5g’Ž–śW[žxă’tÖĎšŇQŠľ˝šĐâířŕó۞ޏ0ÔӔ!)I9]vłŐ‡#Sڎ{éÔŐ$\˛YdÓśym^O|Ş1śö‰×ŤĘŁ2^çČ͙ätśŠ7‡Ę˙Œg{ŇfÍ,ÓˇÇeŕä {$×Q” śdi§Ÿş=xň|L{ňy56”[ŮĂ-)íg.L|ą˙QěŤ\ro’ŒŁĂq¤Îq–űł]˙ÔňËăv–nićę ŕ—ŮŁÎ})B3ēć/osĎÔaŮ8ĹmÍźy%Ňc~ŤĘzziZ”Žčó¨š]&艴nÉf–Í˝ŰÂÓĺNŐy1‹ç‚lč”lđĺ5l#:iŠEÉ%ŕĘN슪VŇF:™ÁăÓiÉ>ĆĽQŒëĹż˙$m¤šg\¸ÚŠi§J™œ1ź‰ö[ž•­´—“|™řĺ4Ż<0ĘI4•1,J)îŰ^Çlň’ÂTť×'™IĽWąqše؀ŞI'ň§őŤ„Ž‚ĹĽŰ~ĚËŤŘŞN<2 v,y:ü'rkěrMiŞßÉ×iEÓŢ> ĺ-ô”ž(Ż(ç(ii_=ĎjŒfŽů<ÝD4ËmŇG<2Ę]R]š$š{ďîBĆۤŹôcĖô›:eœÇÚźÍ4éőĎ –íSňqx'ڙ1ĺƎ@ӌŁĘh‡Eůt÷˛@T›Ú˙!Śš €€H €  €   …  FQŤ(Śăf ă~KŻGOßÄĽ?ÉíęsŹłN1q„"ŁÝý{7ÓB9ú5(ĽpUKsË(ďG‹—;r˛ˇŒ“ˇ9\ŹĹ›•Ť9Żs­‘7txúˆČQĽĺ•ËcTHXŕv :h‰{  +[Qod¨”GŔ×bŰ"ŕYÜżVKśÜd˘¸3R •lűđÝ :ŞűptŻšŮF$öJ%ňŇزÚrDß/’*6öěśÉb•ěQy4ăEŠ$ך”žfnźƒO~•Ćĺtš^)öc Ü㛡†WŤŇü5ąčăĺúČÓćՓĄË7qu˝&yNÓ)}Đ € P )v)śhôôŮ*JoKďŕŕiă2šŠˇŃqQuŰą–ż/šŽ•ęĆÔ¸\3ŤTŃáĎŚĽÚÇ÷ěbwfˇěeşDQSú˜Éí]ś*Výˆ8 Řܢ÷ł~B .űŃĂ9ľÇ)3´oáŃHĺ%ăteĹžÇxƢFšJŚ#'Žřm*đwm$yú‹řN—ÔëŽZńGč[?ŽÖ:c–őäőăMĽoeŘńĆŽŰ;cÉĽrEŽó„u)ëJť›JRzŽÝn>4ięvëc ꋾy#Jâܔܮš:ĆzjŤąçSQ[÷ŘĺŸ+†9;ú~'–žnť.ŹşŮső<†Ľťťś÷fOn3Ći€¤) !H( ÝĽě@§E&Ł%żfz,ůçlyÚÚ[űž~N-÷Š=Š6ś8uYJ+žěíŽkÎǓŤw™Ż8'ňí,۔rJ ¤ů2ëÔWlyĺé\qć˙‰očy { %÷¸˝K>7'w§ľá$ĺI˜đĚeǍžič˒/I˙Ôó\q˜ÍF›Ĺ“Eívwę—řq~űQćŠŐ$źłÓŐíŽ1ŽĎ)<ĺ„”ŁňxŞ<’‹‹v¸7‹#„ZT˝Ë-Ť{îŘĆ\rĐäj*_2´dlŘé‘ĂRp_RüZT’c‘ ă5Ş;|HËiĹ}Qˆf2zŒ6zĽÁuG%ĽßąćÜŠ7şěbńKŘďh㓤dÖôyă–Iîěö`͏'ĘÓOňŽYqĺďÚo^ŮřššB-ęŁÔ፽2JüŁœđĹoGsП;ŮÎ]4ÚŃŮÂI]Zöěr›i÷,ĘĎC„°J-÷^N'ľ[îqËăŠ-ÎřrŰuG? î2éoł7‹ŻWű™Ë) ĂV›Kc'YäůĽI+Ts[ą7ŽÄŕ†” @ (    ŁqVs\‹¤j3_WŇ˝OGŽxsáŐż×Wű—¨Q׎ńËtϒ{ú9§ŕK–î_^=Ď(ł/Ł5Ľos’Ţ:¸ŁŐ%pŇůěyi¤×ƒĘ݈™R˝‰De]vQš*Ůœ4J(•Ź‘‡ˇ"ě ^ [”źîpBŻ]ŹÓ‡ËąžĺKć@t„)nkžéWc[$Eb˝‰ĽsVjënIJŤ 3ZZÜź=ÂܢĹ|ĆÚzP†ÜTüŻ`˛,W ýÎą{=÷8Žv.Ş—„Ń*śŢíŸ$td”|3ëIŸ/ŠwžG^ ÝfšR( ‘• ]Dú|şrS¤žÇśéŃňĎwO“^-˙Tv8scšäNSwF.™Tždj´Ë‹<í$dtRZ[\˜–—şŘ‹d]=ŒE4îSEżÓQQ’§ş$c§nĆbmCŘ͕şçƒ7a+3ůĄ$šhÇO5§á¤Ô—“Ż<ʧ‹śĚŢ=ĎżŽüKýÍU˘ăQʡu|3-N.Ÿ(ĂM/–›WGg˘QԕSur‹ÉQI-ýƒ[sMˇÂ9eƒ”VštW~ŖŰÝ!.ŽÜß1í'ŰęCSw&îěÉďP(@ @P TßząăÇ(­u)wižBÂn¸ňc›ý7„đN2Ú.KĘES/ęIý 4żÉűœçɏú9ăĂ9ĘŠŻv‹>Ÿ,9ƒűnz1őß.Ÿš×âĹń$ţäźšËč|˙‡’˙DżiÝVçť*–IRČăśél˜d§QnGLy%šŽAtJÚŇív‹“¤­›Ü]ÝîW.S_R$Ţé1ą Ł&­&T$Ő¤_ÔßŘl@+ţ– €ęnM(¤–ýÉą‹mQčÂÔqIˇĎcÎjöm*Q¨Z{nθńŰ[ňj%şząe”ŁrěmO~NI(ŞFWłłÇŸv口şz–TŐĺMřŽć#'¤\ŸéŕćӟĂq´ČŠ:’jÎÎO<›/,F,’ÚÓ÷7ńĺ­é&Ršĺ†%źÚßšĺSpŸË+IţOTáŠh“úYÁÂTÎźZłU]cÔ×ę‚lç<˛žĎeáY†2î@[ŽX[iN?šËKŤě FřOžSîg^#Ő%*’Ż ”ZWiŻ(ťVAHP) TAQŽ I-ůTi3źZÓOűdtƒÜąœŁëÎQÍyŁýkuâ]Ď.Xüڗ“] íËżŤxýQÖJŽök“ĹɏŽZuĆůG“‡ą†÷78î׃&T…@UÝLŇzŘÖü­š2-ŽŔ{.ýƖ˜Nť˘”–üÂď’.MJ:]EJƗÁ¤žŰćOtA”†Š”ŁËäĺ'Në2j;ߑœ[|šŚś]Ę,]łlÂtÍˎM(ˇš–™Ó¸ě÷37Ś[sŸą¨Bך•l얕{Wb‘ĽŁeŃNß=ŒĘ×Dܡ÷%iŇM:¤’|‘Ő.ďÁŰMłžlËu2wnŁ9VzŒŤr|öGĚnŰo–o.G–vţČćzřđđŒ€¨€ €čtŤňÍĹ|ÍîϞz:<šrčŚ{ä–ăt=P‹ßÁŻ{FĚöňżŠÇ.;˝âĆâ÷ľ̒ľł5ńTśœSFڗLwöW{  hFŰäÔbĺ˛üY‚’ĎÄnJŁĽŞ”ąĚŠďžĺ’IüŽŃ'C Ň ´ÚTíř Č ‚( ‚VIJ ‹ÝÍÁÓLDŻV98Ę2Rq’|ř>“”rÂ9c-VŞ{VçÉSŐŘőús“ę(ÇRžÍ_îg—,YÂŮ]˛Á5­-Ď•=Ńôĺ(IS\\ŘÔ¸ŘđťŘňŃK–%ÓI+‡Ěƒ>5ç@˛‹ŽÍP‹~Á•I´4üśn<_“UąN)y7 $ř,’iœřîIJÖËcžšÜÔf¸kcIj—;e7[‹r:éV—ść48KűtłŠŒošĹž‰üĘŤo'5Žö[î ŽĎ“˘á>ć㉪ڂé#ť:2%TFţop4›[2$•%Î÷G.N“ůœk˛ —?SN-ńŘşjF“Š[ý<c›uśáĹÚł3–‘)VSĽąózŒŸ';. ő9eńN“GœôqqëůVÜ B€Ý.9K*’[GvÎxŕňdŒ-Ńö%†1Ĺ´|÷9ňçă4˛8÷kěX˘ŐüŰ$ňĎ+LI+%…Śť’IQ\dˇh5îu‹ÔˇvĐ#ÎʙšĹE§\˜IvE\RVČÂä &ÖĆ`´ŢËŘŰů’¤Ë` juă“p_3u˛ěHńˇ,ÔcNű‘cĹ5)uJökż“˝Łă§,g˛Kcovo>äa¨îjŅąWćrę#ţ ž‡Î>Śuţ żôłĺžžLŐN˜ ;/$P‹œ’Bpxćă.Qé鹨dŒŚéŽÓ%ĆŻ†sů'–§Œ¤A@ @ ) I_DĽŽQVÓIđĚ׀Ž˜¤ÓĽlď,y$âŇIv˘ôxšůšäöĽěyóäÖ]51ŰÍđăSŢ^QÎ}=ĽąěJŸ›9ÎLŁ^1ó×LęírqÉ´ÝŸG4´AľűŸ;"joR§Éߏ,˛îąfŤ t1Ç\Ň=ápż>–:§ôVzçƒ8r双–GĚ!ŠŞ›^ćNŕÝŰ ‚ @€Żf@¤‚( •¨#˘táÍ4r6Ř?ÓM’ĽŻŸ˙5œŽÝKźŻŰc‰íĂúĆ@ ( @¨¨öúN“Ť×_.5Š˙cߑjĘőÉĽÉÓĐář~i¨üîuŤÚŒőVçúiv<|ˇy:Iü^y(ďRvbś;ŹMí÷ŇhÂ8Ő}B…×cłQ[†ś §Ÿń'ťět­¸ “^;ŻbJŰŘçĄEÜŰďą%€âé"('ÝýŽşSf\ ľżÔ %^ĆvĄ C#j-ˇĎI7Tř*ŽĆm­ďsŞŒkgů3qmŮ-dU%lĚôÝ%HŤn6$çăîUžÉý̧ňŤäFTk)EEęÝVçË|žžŤ2—ËőŁĘz¸ą˛n  vÁÓüdŢŞŚtˇ]Ôq;ôý4˛5&Ş>|žĚ]6lůýCq–ÝÖç,&ň2pÄRS¤q7Ľ˝”&˜AÍŇV}}>n’98ůZđŽřrI5X¸×ĚIŕÉź_Ôˆ—MŻąÝ—~‰^V˝sc‡AŁ9×;#ŐIžn[ź›ÇÓÍ<’–ŰžYóňĂDęěűŰ3Ť„Ł–Ú/WzK4ó€B59EľŰ’oČM§ýĘŇIÓżąŸ´d†”Ł Ľri{Ů@Şť) ¤Őľ…˛Śńu3Ă%(IŠ.éŸsŁëá×bŽ,’˙ńgćÍBMI4c<&sľĆř÷§”95>Ý˧×Ím>K—#’„ŇĽ%Ď&á’’ƒŽ–ÖÔś<7§ĄăËÓ(MíĘÝ,˝~gyeżsŐ9Rs}–Ç‹–vážë•ť¨=@EÖ$žXŚśľgŮř1”R”m.›Ňi˙$iž-p} -3Í˞ňëéÓzíĹG> 飣ƟîޒÜâޘhË{nt­ŒI6ˆ3ŢÍ4šŞ$c}ÍĆ:€á˘Ľdp\>ܞŠĹmˇÔ敮6ú”Óš„’ůhTĺWG|zU*­¸+Ĺm4ߔMšyĽŻş8OÓc<‰Ă&”ůÔ¸=ňFě‘ů‘Źy.>™¸Ęŕ ąF0ŠľË#˝—ŘôdnŹäî(›ßk­0Ő'¨ńő_2ŽÔĎ^Ľ+žç)bRޡ÷5:f÷$‡Ł'M’6ŇľÎݎ˛Y}0€€Uol…ál@= 4&ĺťď{ †dłÝ@i@ {P¤(Ľ@ÔUł4Tß`•úœn/ĄÂš´ •ŻĄŃÂ9Œm:´:/—ÓŁŻĺJÉR„Ü$ŸĐđeí螛–-=:jIĎŇů<:ž†ŸĺžšĘN +j8f‡ÂĆç'i#+_.îm›MlŸ=zňIĽIł}ŹÓ’KÁ†ŽŔřm+"VqśŸÔźž Š|Őîj×!I#{%ɔűŮUľl*ńÜjüvériĹ$•i> IŃ]_?ƒ2ß`˘úš˝ś1Á[;i’*Łşś5]ĐÖŁłe™ěS“T”SŮr{rf„qĘÚM§^O—.NüX˙ęłPwJ‘ Š$}ŸNĎ,˜V)ođ¸ú3ă&zz\ňÙN-ŞćťŁ9á厒eăvý ĂŻ §g‹$)î}ž`ÉĐÇ&Đ×/›÷>gQ‰ĂŸĎ“Ă÷§˘ęöáŽćHôšĆ’Hónţ…˘¤vu5Á—ލĹRfiŤľd+šIn•ŋâMŠIEUŰ4¤—'9]mŔFóâ„0kƒm7KoÜóŇXÚ{ěiďOęŽwˇrŒ¨vŮ?v[¨É{ݚ7ę38ŇŰđÖű7gžKçmuv\ł.=ű†kRřrÓłŁćɟJ^–28ř;đŢŹbÎŮuP@=˝'§SîyşxŠç„eĹî}XŞÚ)$qĺËSK&Ý\*1÷WG ͨşĺěvˇťďÜó璔ÔWÔóˇ}<}LŞ >O)רžŹŽ¸[_Ö.`؝]:ňBęztŢŢĽ%ŠZî;p@P(@P @PbœšI[{#߃ÓőNJru[w%ĘOfˇéäǃ&Yé„műˆúnw$%ÝŮôĄŽ8 ”"üGŕáyŻÓsןŚă‚zŢžŢ(ôăéđbkF8§ĺšY`×Í°r‹áýW,ŻşÜ’zuM*Ş5{Óä䝣U{raˇF”Ł˝3œ’K‚qßbĹŤóî=í’_ÜÖD–ç-i5Ťě­F4ÍŠißŘËtžŚu¤ˇŚÜâűżŁ9;OgřŞăđf SM6ę¤ŢîĹ¤•3šT‘¨˝.’ÝîJŤ’ĚEh~ÇeM|ˁ˘ŐŽäM*IÂŢć%Ž/ąnIRV‘¤ő+É<4ŰHĺ>Osş8O7śőř5+:qk›<}VUĆ5/nçšđr”TžÜ–˸͛|~čςZĽ$ś<î×'˛]Íš )   CK•Kdű–ppç&ËKL–¨™ť÷ˇK’'Ö¨=źěYv RúXÂyĄś˘Ý6š8ŃۤĽŐbráMúGę)ă„Rn’ăÁ–´ăÖďS|šY㌡FՑ):Š{î|÷ĽŇI7śí×ݞ/T”cďe_SՒIb´ß˛gÉę楑j_ĽW#I•éËJ>7ÂhÄbÔ.÷ođŸrš+{ěËrqwÁ‡ş%¸Žv"+^ĺíą7/Ř ăŚ´ŢÇłFÔŤ˝umF<ĺ+#“}ĚIŢŔm6ť•rr,VîĚ9žíĐM˝JôŞúˇG)d„mˇmIĺí““ovwLJôŰĐúŠ)6ˇ^—ŐϲŠú#žţ#S›œœŸ,ČÔ@GHěsFÓ5ŻÖz ‚ôŘęm|Ďs=d5eM^ü/cËčYŢ^“& ßԟł=yuJi9VÜłçňng^œd¸Jň88ËsZu2ăŐ)4Ů­4EŇűiŢüžˆcÚҲdNélźicÍ%šśŽbo"ü[ĽhŹ¤ŠÚ1ˇs2“ű˜śÚ)ˇX­WLć÷›N\v,W~ÄĘăäŠ35˝ý‰Şśkîiť™¸Ľó:÷#,¸Ţé?Šß<ś=y:ŹqÚ-ɞ “y&ĺ.Yߋ.ë5 wa' Š.QöpŤw$ŮńOąŃf×˝Ż†źy§[\}ť;­űž<š*ŰUQ=™$:ŞćϙÖeRm*ßÁÇ|ŽšÉä ą€¤(@ B€uéc)u8Ô.ő.ĐŐö>/ŚĺXzČÉ÷N7ŕű1{éN÷<ÜţݸÓ&Ý­qŰĺüŚ”Łšç”ZăsŒnÇ™¨Ş+ž(ąůy*HŇtťIsÉÉÎöś9ZľŘËqrJ—cmËÂ3)Yc$ŹŠžÝĽN:[9J ]WÜŠÚMř"•=˜*ž)3ôîjß&d“ä%fÍFĐQ^ćÔhŠŞ×dUhvŮ[™nbŢ5Şčč•&šh`ZiÓÝŃŃcpŐ:ĺ÷dGœ?U[9jmŇŘôfůŁżÔŕâÚ¸­Ň˛ÄÔ㓵r\łPĘďÁ–őGęXĹs’ůwÁ„–ŻR”$îţĆ!’Ü­p#RI­ŁćőXœ27ý/ƒęcqJ˘ěă–ˇ§sXeăv͛|˘ł`xć’Ý>=Ž'ŞY{Œ€€@Šôô1RęŕšUżö<ô}?EĞLš$—ËŻÉœîąŚ=×ÓJRŸëJ×rĆę÷{$1GâfVÖüűœ˘ł$ޝ.Ž'Š;ěËkI?•÷>WSśwśüŸB93äRĘĄŞ)4ܞĚůˇ-mˇn÷aœŞ=śňfÉ]əK`Ă)4řŘşwÜéiEœőj`T^ĹťJÉ*Ł:םKwżc ŢOcrˇ˛"Çş}ȍm^ç&ääŻcŽ–aƑUŠrpÍ&ŁWÎçjĽşú3ŽzŇź8żł9<Ěz€€ĄP¤(Í&`Ň+5ö‡˛Ćdąˇ_žŤţŮöşžšQŠz•ső?%Ňg—MÔăÍc+Ťĺx?]<Ë7JĽĽ-Qty9ńÖ^NÜW­<Z2ű“‹LAüEŮRĺœÚqŸ;[vĹ:i3y^ëđqľ\đVí?4F˝šO{ÜâÖáćiÓ9)JSˇűs­Oť9é§ÉčqÔ­ěsqIđ+cžXŞ^Cúr-K€•ÍqťłĂ֝ȡڸđ{ßĚ꼍3]Łą×‹ű1\€Ľ”(P¤P›NÓŚBšćɑ%96‘€@ €(‚ ŃÓ(ÉÓ[×ÜúęOD5%Şˇ>dă$ÓŚŻ†nxŁ&šGoQź:ŻtdÚ\­…ŐîŽxĺ{Žw/§sĚďśr|Žâů$eÍą&աلEWšť]¸2ŞžÜ–)%ťrﱞYľłŮě+—Üfś —Ý“tOˇ`ËŘimŘ]"㓤{ŢÇlQŽH[@tQÚě탛VrQĽ˛Řú}5𯿃5|ľycř1zżB|“-I*v’˝™Ó­qœT+‡fqÜ –MňDßëϒJŽqOúš~K’ˇ­ýˆĺvß&ˇÂ-˝śG ÓŢĎDÝ&Ÿ,ĺMßĐą›gó-„1ĹÇt׍Í8S éNÍ0F0jŽ˝ŽvüWłGX´ÓofrŐvš°6Ń$žçĎ>¤˘¤Ÿ­3ćÉTšđÎü7ŞĹöČěĽE>ϧECŚ¸Ęܡě|cëôp„qŚ÷}Ž\Ţ´ÖßNIĂŢ)Ijlńś´jŠrzz‰Wřzľ(ŧő9¸J˝üŞáWf'ŐNž%™ˇ]¨ńJ.2wÍg'˙™Ë{[2ĽŤ—Ô1{I-)&ťnßci7'Fş„ß?ĺašŢUŤeŰš#1ߓŹŕ›şG7m׀&\=‰%-żs¤vHTIW°¤ű˘˝Œş"3)ĽÇ&5ľśßsn— sPÇ­7˛Ż%“}Dśc7\'$ˇ“Ůx<™r9ĘΝD–­+„yĎW3iě(P€ B ˘ĽgżÓúě,Ô%ób—+ÇšóÓ:ĆV[&SUŮÜ~šşRTüeN:j/jGËé3šŕ…~¨-/čzţ'ËGĎË.žœlłnď Qův~2zŐQďbY"ÖôČťy¤ľ; 4vůRâ‘ÎVűli”ÔKŮďH5Hç7ň×ÜćÝř3)é{sŘ֕\ž|ÓřQsdË&úfÖső+qNĺýœÝśß,˛“”›|˛Źp˜Ć@lPD @ B€=˝fĽđŰçƒÄuéޜđoɜćń°}‹˙-ÚěU’ăĆţ Š*OšľÉ=.Ÿ“Äí2aKTť u*äç(¸ÉĆÓ÷Z˘ĺi5Ę*íŃ6ßsPkWĚ­}NI˝š˘ÂqSÝmÝ0ťtoćö4ŢŰ~ć%“â*[%Ř/pmŠWr9_}‚Ňƚd6Ť~ćŠĹј´QşO‡ö Jˋ–ç\*jI¤ĚŚŃĽoţ¤kŞőŇJ4ŮęéĺTäö\W“çăČŇJ[ŻXä¨Ő´ˆ–tôĺÉ {Ť^I“ĺÄçŽW{<šÔ~Zm˙sś'(ŕ–­ŰCIöá(˝Jś:|8<2“u$ś1Ť{\w9ĺmmŤĺ~×ŢŻő$'V›úpۛ9JqRˇť6ç]9v¸1&ŽO‰ mTbon8 Úˑ—*mÖěʞŻŃےĽżĐ2ŕäĽ'Šşăc৒Mpzg-.n-ľć!߆{Ź€ş ( €¤ … Š‹@Ą'eMˆű^—–óáůc.3ăV翌p|(Ó8óza{}^ž-ä›|óą˜)K4ĺQ\Žěőzş˙U>×T|גZWąćłˇ]łžŽĐ§oŠĘŤuf˛K\íwŁj p„řvƒÝŮFŒŚˆ3'HÍ•I4qY%Ś{Ż$eŽéLĹę§IWýÇő;ävăcN+–bRĽˇ íg,ůŇZ ¸îYͨ˝OsÇ9[=\8jnšeÝs“ś@ůVŔ@R@P -™’ŚTŻ^ ŻԗדęJO#ŠM-ż'ÇĂ(ęZ–ÇЄô䌗ěyůő¸źw]=1–•ĽňŐ:G6ÔçŠpieŠ…$ímÁÁŰmjľzvúSO—ą^u§“Éš_°6Ԓ˝™‡Oٜľ&ťœ3u1„i;—ׂÉoQŸ'|ůc‡ˇoǓćfÍ,Ňšp¸Frd–I\™=8qĚëě!@T @  @€P T­ěďŕ¸cr{ˇGś<'GÎƚXÓ\rv7îxsÖÎUÚŘóÚĽWď~Nů/Ż É盼/úmc“LdśóîeOS°áp{|ŢÇ:pŤ[š6őE5]Í<‘ęhůů:ŠŚă÷<қ“š6Ů×}ĽÍőž|iŢŞ9eëá œ™ól–npă=§{?âťĐż&ńú‹ŐóĹ%ĺ !Ż‹ÄňŻł˛oNHׇąÝfRIÖŢÇŔłŐŇő‡vŢÎö9gĂŠ¸ÔΞŢ,°žĽ-žWOĂӍ.ç‰ní?Š2u kádÝÔtóýz”ď,;¨Şßšéy[Úö>~6Ő_'idptšňK rwRjü3dűmäç’kć{âÉËg˛jÖg/%šŰJ–öÎSƒOĺebzx$äÔ_ÓąŞŘĂť Zʨńľö9圣M¸ĎŠCs‡Ćž8|Űř˛ÉżIXĚôEŤŢ^9e''l‡Ż |f™€…P @…B€R€( @¤*(rPŠ.Měa=Ă+ Ă|ŠĽŃbřý~('ŚĺwWUšŕÁ ­ŸĄţÂţ,şš´ÓŠŰéÇýö<œ—Ë7LfýjpJWőGÇjęšGÓő]2ë‹˝—ŕůӊnŃĘŢÝ>˜I_szŠŞťŁ“–ŕnnö9ÎM5JŃž^üœoŽ••‘6Y4öiÚkÁ5:Ü#´Tcy^ţ;œu^Ęţ§e8ÇĘĺŢθI—UÇ;qî3)y19$ŒdĚĺö<ӛł´ŕĆ]¤Ë,—&MčŕݲśCĽ­ă4‚ŠH   B€€­€B€Ą …  ˘„Č4ĽLôcꊭ\/–Á2“)Ş>ŒşŘ*Pż7G)ő§ˇŢĎ˝ŒÎiN7†UŰݛ­[Ć*ýîˑßĎ-ýĚxáŽ&ŰY&¸“ü‡’o™?ɂšÔ@‚ B(,=‘ę´ŕTîkműéÔ§™NVŐîŮć:EăÓOS]ŒxÉ.žÇż‹oştzšÔŽOŽçÉŞXšĐ—=Ď~<ߟö8raqťž—§w=/M7ô#‹ˇÍ•š^˝§ľŰŰjߊŰŚŇ݃ašWO“2¨§äó­YrŞ•Öëٍ2ëÔÂ* v‘âϒR––ön§$žhžĚňřąűJ€0w@U{–P’Ţśňdô`’“Ń/ýĚĺl›…yÁšĂLÚ0hPP  P@@@@ @P!H!H€@PE* A&ë4aƒšSoWLýťĹŇđ~ƒWÓzGOÔIĺ‚tŢç9gefçWé<§ëm~Y$˘˝ĚË;|$Ž2móšŰŠËź˜Ęď¨JVa‚3şH€4”  @ 4J €´€  ( ‚Š€ PZP Pˆ ( „Ł@*€2 Q( % … B‚ˆ B P HRˆ R‚)   !@Pőt™"Ž/“Ę –>SCéŠ\ŸbĹͧoč|čäœxghős_Ş™çź9OIˇŽÝ¤–Ç,š^=œočÎęrKkŘÔ:ŞQŰŘ|Ykf؊œÝӒ*—ÝĹwŕO6ÚcÁĆÍăĹoľŰyr9Ý÷wąČ0uǨ(4 (€TéÔ!)şŠąčzá– Mo\žl˜ĺĆÇŁjWę2ۧošć™ŮoâHó¨7Áš=' ŽíňÎ|młu@ą@H@ (!H@P…PQ@Ţ4Üś2tÄôüÍäścŇ=xąJYĄëťiÓGŤ¨‹†OŐ›z‰ĎŇá<™ĺ–)˝ý/ýٖ9(¸JZ­§m-űYĺłSN˜šv§š´ÂŽí+ßÎă&,¸—ĎăRŁ ł%{ŁœŁFŇ}Î}dWňíŽÔkť¤ž™kswŚ-ˇ˛<8ňäKi:÷ÜłÉ)ŻšGlxlťrË-Í3'ŞM“°´[=.l˛vÜ­™nĂPlœ—°"ŁD5$JP”(  @J4‚Š”( J4Í€¨ ( Bˆ )Z(€´J‚  B  €  €  €@€Q@…H@PQ EhPT%H P!€ @¤(@¤)@# …(¤ € @¨ť4’[™jŠ;7Ť}÷^ć2ËÄs,Ş•sÜôCdžŸkGźŤfqä™]EӐ4C €  Á ( ! (*€RśIžSqv3ś,r”Şri^ƲbÓ9Ô_dsů&ô<ľIÚŻsyçc’ŰT><żúS}ŒJNrmňÉńď=ý ‚ŽÁ@4ř˘P@€ @R ()¤@ !@ !¤B˘ÝFŒ›Œ.‰–şÚ>ĎŁBX°K#UńIľłŕÖŠ9yo{ť=^Ÿ‰C§˝;$ăiÚÝţÇńŸÄ×=.ńkýÝ\ëŚ,EńÁZojŘĘm˝š:Áˇłľ^Ç7G7–玠őJ’îvČéşäđőrI(Ý˓|sË-3•Ôry’ÄáVŰäăť Yx=˛IéĂeQ+2Ę•#)š˛H,F+b‹ş@WěTdť @EP@ RHPĄP" &,"˛ )U!l (0 € @ @P…J! Eb…@ ˘%€H ´‹EPh  „ZE ! @ BŠ€@´€P€P!˘ P@¤((P@@!Hˆ(ĄŔ@¤)A‚2ŁIÚŻAœąňšGxeŃg=Rlv!œ8ć+°ŃŃT`_BP" *žž“˘ří<“Xá噶OcÉš:IśĎĄÓrB:ó˙„ź5ó?ąéÁŠ=6i|n¸źńI˝š#›IŇŮy7ŚˇLĚ šî˙ĐćŰćĺÍ<îëÁÁś} ˝$[´čńe†‰8ÝŃîăĎ5‹Ďe—ˇ4čmËä¤  Z!obQP!Ao€Ź4€ˆŐ]”@RP /%\2Ĺy+Ť!¤d *P(ŕĐ4ě€K€h‚É`VB€Ą ‰@BŠ (˘Ń( X  )‚˘=Ղ b÷ÜԑĚÜ^ە(‘dŐlgQŕŃš­š÷2 Ü ˆ,%€ ˛™ ˇDąB‚– D ‚Ŕ –Т P#( „5D{ @Y … * 2Đ)Q’•‘PŃD@  D …HĄ=¨YQ, ŔDŠ B*¤BŠB áPÖľż—šîҔœx—)î|ăIéá´ÎYńů}›}l˝Te-rÇŞßNÉłçu9ţ4•^”r”Ľ.[20âńťŤr´P JQE6–,P˘‚Đ(ˆ˜CAčlĹ!ˇ€#!y Š…˘öŠ%P|°‹’Ó%S5M­Y˘ŕË ŠY . ‰CIP   E @Ń@Œ‘V ˆ¨ @'p”Rd( …D*`;‹( …ź@€ (Ł€ ( P ĐŘŁ Ó!(@@Ti3Ň*WŻŚŔňĘ1Jܝ#ô~éĐˆ9rm8ţ–śhřPđN3ŮÇR´~ŁŃţ\9f¤Ľ9]Fîë÷đqĘ]Ջ<Úe(eĘđÜ~]Qťć÷ň|Źóř™^™ÉÇł—-žžľÎz–%šPćQjŇg†nŠ[Ű[ŮçÎöé‹ ÓůšüSÓký ĘJžę&nŞ. GvL0š^šË)?XŽĄůŁŠ›žfĽ-÷ŞűlMߤÓČů {ťPPą`(ČŘ@ ŘPU˘Ł7eşaŒś 'a`„P2PČ@ “%˛˘ł%nŔ@Z   (  @(PK)(*Ń  \€%Č-Šň*€`  ‚Ŕ ŽÁAeठ€ ;JŁäETjĚ;ĄnDĐaWؔhˇ`JRŞ$]ť‹dä¨pi÷eňjÚDŮŐýHŁf^ĺ ĄE6–ĂIˇ:`Űŕ•ˇ°Ń´­€ATˇ ~Űh @ (úp´NW¸ú”hl˛@TU‹`˘  [J!P(DĄA€!IBČŞ( *ŽE#MŮ(B˛ką˘ŠT@ -^ŕz:_Őj.TŽ’łíú?]‘Nq)8IĹžoťv?= 8Ëg_CßŃN0Ď7AsíďF3‰.žĚvYĺ”_Q‘ĽÚëö8ÍŚö{źńřo&L9cŚkdą6ÚţČđu&?™K…%G—,-˝:̒JZZžOŸ(ԙďq›Ú_+çÁçę1¸ťnýÎÜ7]1ŸëÎ܌ô2€*¨śÎ˙Ë=)Š''ý+“ΛOgLҔ“mIŤä͙}™0,kyŤđq/Ց–K't@@÷€(¤6B¨ÖŔGČ!HŠe€R(!@€ B[ PB€Ŕ‚ŠB٤‚H  P* ČVP B(( N@¨0(  €˘‹% B*$h}Iô( (`(CrŽ•Ş.Őěř0 ˆ•÷ ‹@¨€˘€Dd(DP…P˘ ,]Ŕ_’7e@P ('Ŕ¤l Éa‚*ŰÁP`Ň#ˆÉ ‚… AŽä4š˘2Ł,E B€*§ł * S#7ő2EeƒD ú€mŰ咊PŹƒ@&҃)Ł€ĄH…Ń(ŰIŃYؖŢŮw|˘PVZ!ş#DTHPŠTŹ5@AÜľî(¨+*TT‡! Ű öF[°'sZw,bĘ J#E „amŘÚ Ü)%š/ľ2ý€S=ÂľĽVĆJ­AlŒ.Ř!*÷%Ó5{0S° “ĄMw*DhŇ (ŕrEŚT+r3TFťŰ(ĄJśh´ÇťpChRŮ Šˆ %ą(U¸ap‚@!@¤` €ľľ‘„T d’´:bĘá+MŻĄÍ€ą‹Ôž'ÎH$řr‹Qr÷wąčɅúƒSžXÎQ…V¸Úvź}ĎĎŮŇňER“Żn?‡oˇIĎ KN8JUúŁ-\ů_÷ÁÇ/O(ăŠGRöLňaëe˜4ŸšÜÄóęŠ-Ľßc–\VÝŹĎ]&\;ŤIůGžQk”tžI>őô96ß,돗ÚuôU0iA°°k܈ZhŒŠÂ@ ,ƒt ť—‘L¨‚ŔŚE tJ*ŚĘ‹vwÏ&ŮrĺĂ*ýZT•ţÍ~眄şž–}4ŁŠŠBjă8ń$p5Č Ź•Y¤•pĽąSiDhśŸ"Ž dŒSîGd6ČLQh(B€ľ°h¨Ĺí-J! Bˆ!AhR€î(;!hŔ@P(VĺÚP4mh@TE˘ŔP €E);<ďąQ!˝;öaĹ.̆زżPŠô€˝Ŕ]Y@Q™/úHŠ!Bő/p (( 7B… B“żP´FiS ”JÜŐěQˆ3@ĐĄŁl‚ĐŇ…JD˝Í€ěĐŠ"š WtĽöbŠ–ĹöÉ{ąUHŇV˛ŃYľš!ś¨ÉZ `ťJ*Bü[VôZ+D§äŠą˘.MR}ĚÓŃ >€FB´ŠlZP4@!(Đp(0X@RŢŔd dŠ0ŠBŽCŘZLPČT^H(QŚ5an ĽTü†ś*m’•E>ĺÓö °JgG)‘Ăܚ6ĹDҍw5ątm‚#˘Ű„;Ű5oŠ*ŠąMŸ iŻÁ–ŸŘ[B÷ŕ^ÁDĐť@Ú4…YEJEqđZ qĄ˝šŚř P]łN†ďsDúRŠîT—dŒŃwÚŚFŒŤ4§ä&Š|ňoĺ|2U˘ŚŘŇFĘ-v3ő"풚tĚ°¨ M‚•¸˘ľT,"S'ÔŃ6aY­Ë§Üť/`m;•#O܉xҡ”l?ŹU0ŢŰ0'z $Âçť:( ZÄŻ”KWšśŸ) ›NU“śbÚo`¨řfMť˝ř {llpĹn芋Éi=ÍĽImą_‚ŚŘŁI* >ę‰ÉrVĺ^器ĽÉ[ě‚mĚkc-P]łeD4š"Ô-Q¤‰Nů*miĆË@Ű:LľGJ&m›*Vi-†á6É;4ÚňŽmS ˛Ľj CƒI•p ° éOŘi^AśŚźŠĐ6Ém—a@K°Ę—ą_ ŒPn66šUŘ EK¸VˇŘ6„ Ŕ°EZ bʈT•Leú!mŽŞŸ!$y „eÚ{ |›Ő|ś5A m žÔJ;ŽäR/p,¨Ę“Fžä ­'eh´n\ŞmşŢ׼DŁA’Š `* ź…šjˆEAEJ*@(R)P˘€% ˆ*B%‘P e TsTĹ0m’’‹@` ś*śO¸H¨ź/qlpMڡ왚đQ¸Tăę6˛Řä ôB‹[{‚U0V+`¨PkKJÖá6Ŕú˘ !QËȢ(-ŠeUÜ*Ë{ iĐ RŠH( ‹E\—k*m’Q˝;’śA­$d]‚EÜľ¸Hƒ;–™Ş/÷)śh†člĐҟcUAƒiÁSąC¸Dť-y %ą/`FCVˆ÷ /ŘŐXKYîˇ+.’W'aŘ´*´!Z PU˘ýƒäg‚š¤J÷҈kK'÷ x°3D4(†Ů¨”‚í(‹@ÚS°)h”Ů ‚ú"Ł%˘¸Šň Ľ1F¨ľŕ&ŮĄFô×;“tÂm”Š†‘šFš3@Ú$ZP"E ‹¸D jŹ€FüŁ&šşAY^挶Kˇľ˘oeŢścKnI뺘ęłRUiż•?Ľž\ř2tŮĽ‡4tΚť†œč…/ f‹E5}KX5ŘúX˝ŽÍ‚9ąă‹Œ’qůŐ´x3ᖠ˛Ç7(ěôÉ5ű e[Oȕ TľĽů2íoFĺv•"m]ÓÓҝlĚrÚîm)K9Ęőˇű‚4Ł&­v4Ło}ŒSŇÝ:OŸsOhĹęmľĹpTŘą„§=8âäü-Ě/cëzŁ/Pĺ].ŃĚć’ROúInĄ#É˙ę×NłžžkŞ•s|g6ŃőýSčgĂÇ'ŸăňŹ‰ĽeٟÍ›&yęÉŚ˙劍ţ ľn1>+A79$—ĚÝěj 5&äŁJŐŢţƓQźŘ§†rǛĄ5Ę{Q”‘ęę2ő#Ł& §~őß˝ö<Ň{—ň%+%}#¸K[§ąě‡ĽőšzUÔâŔç‰đâÓoz㑹ˇ‹eČŰągŚÔ“M:iň™še\Şeż=œŠž T8ÓŻk ś)—’Đ m6î)]ĄM ŔŢŐŘ.;Y‹í@&›žÔ$֛\˜m‘ť[ƒKĘmfŻšˇşŞÜË*–ŔŁ‚ě>űv+•˘ŠíA;s•ŚěFiv5-ٖśŮ$ďžÄuBŠ˜T˘Ňđ;đ+Ŕ…°^ÔĚžMĽśä¤Ř zpt™şŒnXpĺĘÓ§˘I~SĹŤŠ†W†=7LŠÎ-ʔW.ߟd٧‚ź1LűýWĄăęqăĎé‰C ‹rygUţÄ˙á^ŁáÜzœn{lÓKßryĂĆž[c3ˇ+g֗đçŠ.1Áý&SéýgM),˝>EĽÓ–›_ž ĺ)Ť` P[ěFš)Vű0ŒÖëąi§EÚĚ×˝Á$ŢěÓTé˛i ť'°ż(  ŤúƒŽô]-đGvjžĹQm7ŕ*w!ľˇçÁ–Ÿ`›fˇ.†iÁ¤śÜéđ˛üŒńOá]kÓľýBďńç w‡Âůž&§ˇËĽÖţćt]ŢËŘs`ú~—鯏ę Ô'đ’ůœ Úrńľ{w?C›Đ:wÓ¨bǏqzڎŚßü­˝Œ\äşjMż[Łő=/Śtk YłtšńˇĘă Ýî÷Żmü˛ô>ŸHEăÂŰĽ–Ňáđˇpń~BŮ_ˇ'Ľu-Ę]7OÔĎUęɏKk<řăÔÎK8d“Тßěki§Ś×k?CĐ˙,˝ö|˙ţő dŒŽ¨ęrrÚ/ÇÔÔÎT¸×ÇŘËiěŐt~…ƒ¤’ŸY“Ł%óC*ÝsĂşńäűX°tß,đbĆĄ8ÓpŠJKą›É>–bţwJRQŒ[“á%v_…’•ă;­šŽOčyzėÂOV‹ÚüœšđSlQ¨cɒJ0„Ľ)p’śĎĽčŘú™Ü:ÄíĘ:ş÷NŸ}Őô?E%ńş~› Zt§Ÿáö1–ZjMż ş­Ť]6fŸáłOÓú¸âžWÓeP‡ęn-Qűl˙ŞŔłtńÉ |9MišşwOę|źž™ÖőyVMN8Ü~ÁÔIÔUv§żŐ™™ŽŸ”ŕ֙Ňz]7I×/ÁűNôl+ydĄ<­%ŠB’ĽNŻĎ“ś.“˛NP˞q‹Óđł\ šńŠ_Ý1ňCĹřBP­Q”mZľV‰Gěý§8Y)¨NPnű_ ńť?3ŸÓ:ޙÇătÓZÝF•ŰńąźrÚY§Š…łŕÉÓäxóc–9ŽŇTL_ âGă9(wpIżÜÓ;r,1Ď$´c‹”Ÿ +g܇đóÍéPę°ÎsË%qÇK{]śýŽ]ž>™cϊo}MNIŽßűů3ĺŐ|­´’śüwŇ}#¨Yqő_e|ŘŢOš.űŻ>ÇŻ7]‹%épŸňůwšI¡łIqą._ƒóXąË6UŽ4¤řÔÔWĺ‰BxďTZít}ŻYÎňáxÖ Ô2$Úw’OMß;Ş|î|˙çúÉtňĂ.˘O%Ś[ńĹYeľ.žM[{žçÔč=n%(ő¸”ęŢ5äžÇ‚8ňĘndĺÊ[—izs\|žřzoQ—áü(,"´˘íĽďăżŕë›Đşě*.xRÔé-qśür7ůŤô„Žß&8ŠËÖ7Ĝi2Ă ĽŠyTnŤv—>Ýʛq˘éđWěT Ľ (ŤÝlW_҂m–¨Ëć’=đĎ*P„%,’ý1JěéŐĂa‰BŚ1ӗ˘ÓMwű…•äVłz%śÜ›]6gäXĺđÚľ:ŰÇ Ű†‘GWŚÖΒ{ .ˇ äçŚÇĂŚw[BšG6 “›Tö7C€ťeŤ^¤iŤŕš~€ÚX˛´ˆŔůDorŰ°•ň‹D/„˘ă*i§Í4ś™nŮ~Uiˇ{;Ř֙>ŸWĂzSýj;} ˘sÜí…tň’y”Ô"žm [ńVc"‚Ńj´žmI-˙ۀ2™Vý‰7$žÉşˇÂ=Ý'Śeęf–9cžďĺŽDĽ$žíXލśoO͗ˎXáÓĆţ'ÁÎňGné?ífpzQę QĂÖFQÄé)ÂJś÷TŸ˛1ä՗ę>„žú]qI>Çč°ô>ŻŇ)ü<8ďwŽâŰíWvŠ˙…e8ĆKŠP“Ę.7Rđˇ/œ&5ůÄÜúSô.ścŞ3–”ÚqßÝ>?UĐu=g.)ĽŠĹKKŠ}<–XY_Đ7Yéý7\ĄüĆ=ZĹÝQé—Ółâeţčĺ Ĺ<˜ĺŠ˝Gl_Ăž+Ĺ)ľŢSgŐ1‡?žrŐ-_3şö^ĆźŻęxÇç:Ÿ@ĎńrG N9'ú§-ťďĽ-¨˝¤ëÉ,}Os‚qĆŁL'ˇ.Q_÷űĽóŠăůS†ŕéóáÁ'´%&Óú´ß⏝?ᎯáÚ͊S{´ďŸŠú &v _‹~‡×ÂÔşi5ć2OýHşť YcĐęŽ5MOß˝w?j ňV~8üNLę˛fĹ ¸%ĘKiüś­]sŠô/MÇÓJK]UIÁš;úh$— ‰sľf?Óúvˇ;éŕ˛ŕϏrŒÝšĘť*Ř쿆:‰tË‘YZšb’ŞűŸyú/§źĎ7ňËâ7mę|ý,őŕĂcŠN1áĘMżÉo%ú&ŻÄËŃýB)§ŇäjřJ˙ąšúo¨ĺĹţ.F81şŐ uÍlˇçűŸˇ䧃ňPôôŃǛ;Ûś”>#ÇI÷ˇŕúŇő.ƒĄÁŽ=<ąçĚ҄c§)vÝŻąőĽÍT˘¤ź5gŃtŤ*ĘşlK"âJ ÉrßľÖ˝>OŞú&_QÍńńĎfăOwł[U÷\öGƒ§ţępä՟s¤Ž*Wáßcő‰% &vM1řn§Ň:¨fkGÔiĽĘşužëľŮŽ›Ó:Řcř˙ÉK"ˇ5U˝?Áűp_’§ƒäaézxôŘňćéÔbŁ,?ÝđŠŐóßsý¤ęœœqĎÚ˝¨žŰˇäű@ϕ_üĚż…&Łňőqo~a_ę|Rč'éŮV)fÇ6ÖęÝ}QűÓăő?Ăřú‰ˇ.Ť;‹wRjM}ÜŢ<—í.3éůwtx ňŕ„ŢhÚY"Ő/műŸ{Ň˝^QčôćĆ°áWy4T"ű.wďďő:ËřqcĎ 'PńiŽ™Zm˛wô<™?†3ŚŁ4~’Ôˇť-¸ĺí;‰čłţw¨ę°ő.3ŽxĘ{EVŤŚ×†zą `ř)d“S’Zšw§mëýëěvô~ƒ¨čz‰)áJ5,‹'ęŽ.7ÉöL喯KŒÜíůx˙ JŢŽĽŻš˘ÔŰËÜĺŐ˙uŞXăŽPÍŞöŽŸ÷?ZŐ´÷ŰÜäÉ|cđš}Ô0ËKéŚýáó'ř<˙ĘfÇK.9ăwO\Łú5ňÔđ9Ó}˜Şäţ…›§ĂÔGNlPȗ JčňKŃ=:K~š?i5ţŚ§,fń×áŮrbž=:•jŠ’ďł?_“řs˘’ů^Hż:Ź˝/ `é˛ÉüYäÇ8é–9%R^ĺů"L+ň/AÔuŽK§Ä磚kbŽš}.xžł§Í-ëM_ĺ´č=7§Ë+Áu‘Ý>ŢČöźLÍç%)7Ś›wˇÇĐţ‹>ĽĘď'M†oĚ ™çÍčޝ™ˇ.– Ő|Ÿ/ö/Ë਴×)Ť?_?án‰ÉĘ3CÚÓKö1—řcD—ó™ôDž*t˝|˜§~QľśËoܞ6Ť?k/@értQéçZĄúrB*2űů:tދŃŕéáŠxŁ™ÁśĽ8Ť˙؟$_ ü§Mé’ęó8b’Ňń<‰ˇmS­Ňˇö9bčľ'”ľ{-<ŤxŕćŚáK‰Vçƒ7E×G*—I׾ďá厭ţźĐ™%Ÿ(úEƒ$Ľ‹âĆĽŽmĆř§ô>T=/˘ë˛ÎŐÍÍ'% ˜ß Üýş_Uœ”łK˘ĎŢĆé/fyşOI}_ ‘č5?‰uA? —ŕÔşű §čúÜL>68cpKCęv‚ßľíËšúžƒŚęĄ–oŞÇ‰)­RxňÍÜŻĂŮ.x>ˆ3rÚČLÝLşYM˙/ŐfRДŤnŰđzÁ…~sÔˆ˛ăZpô9qdI­yŁN?D|‰úßQ’.đá<Ż$Ö95ŞęŐň~č嗥éóßĹÁŽwΨŚne'Ó6?)Ô="8ÜWŚ~§mĘZŤžüř3ÖäôYt’].ąĚ÷‹ßo­žŃdô?NÉĎM˙émŸ úlą¸ŽŸOş“´kĎńŻĆçžYĂ8ĘSžę)r{ŕ~ŁđÜ×M*]­_ŕý–.žcŽ8ĺ5qŇŁ{?ŠÔ^[ô“őüű7CŐŕJY:lą—pý6ˇ]é,ý/OÔWÇÁ%qŽ)Ńg/ě<ĎńMBjNmlę•ďŘÂIĆMş—e\ŸšÉ螛‘Sé`Ťü­ŻěpĂ˝SXőÇRŞu*ü˘ü‘<+ň2qx”v´śůwOëßîs\n~ŻŤţÁ–Q}>W†–é§$˙}Oálę èÇ).MYfx§†O‡ ­ů>çŚú2őO_ŠËG#¨.8[œ?ř{Ô‡ôš?Eé=&n‹Ľ–,ŇRz›p–ÄĎ)ŽŞcňíâÇü5ĐaÇ'šy'ÝĘR¤>?HôéÇ$z|‹ŞČ›qŒ2$â˝ßýýĐdXÝëŒejŤŘóăÃPła‚‹pŃKhĽwÁĎĘşę?;ŐzVu•fępfÉ9ťKSQ^$Ő[÷<şâ˙ËčúšläĆăű/÷?o,ť|ŽÝîĆš7ţČł:ž1řœ3őĄŹ>9E.ŘáUő|żáđ†ItłęrešßáâUűď&—űŸŻ’›KkúšÇ_5ż¨ůć°z?KŐcŽ<0ę0çŠůĽ—Ń*Zü>ÇÔÁé¸úl“č1d’¤§jŰvÓÚϨŁÂE3rľ­Ft¨AŹqŠĽ˛á9J Î:eÝ]Ń eQĆ-4âš|íČŃKJIqK‚€Zb–î•něcnIÉjiťéŘOrV¤Ý;[´hçčş(tXĺćńˇj2vŁě˝@rţWĖG‡œŞä㝣¨bx1dŽHĎd˛*škő&>€á ŕ]š=,› %ößÁöAeą4üÇUčŢŁ)<Ů:ŚĄĽIdŠ%ËTů9ôPő˜äŏ'NňcOŒëjŽ/ąú°kΧ‹ó]WđŇę!ńpe”3Ow+Ov÷Ý}O™/@ę#ÔKĎÓ,Ťu6œ—•ąűYbÇ,‘É,psqVžćsôŘ:˜éϊüŃş:xż ‡ŇłeęňôĎ&rĹúĽ’ZWűŸs?§ô0†HăézfąÖ‰O5|Mź§łż'ÓÉčÝWŤ,rduŚĺ–M׎x#ôŒ+ qă›N/g8Ć{xv¸5sÚkOËu>nŤ,łféăÓB0¤đánkÝZűŮő=Ąč˙•Ž}Mupr•ŚŽ>Úč}<ž›Ÿů|˜ńőł‹ŚŕŇÓOÝŽUmšŽ_‡>5ÔćŽlK6–ę_^^Âĺ¸IۇŤz¤şNǗ'/‹ły#J?o>Çç3ô˝&>‚=D:ľ—,öXÜtÉoťtŮű ýzɸőxqdĹŕíÚ/SéÝ/U‡áeĂ’QM-Ň^1ĘE˛×ĆôŽłăęăÖźšąüřÜ_ŇŻŘý\k.)ă—éœ\_ќú^›KÓăÁŽÜ!úu;÷šŘÎWwk&ŁóÓţé˛akÉ iŐ “–íﳍmŘüÖ~›?O›ŕĺÇ(ĎĂîF#Œ[MĹ6¸mpjrX—żâĂÍG$œˇ+JŇöś­űótřqôŸQ‹*rŞw‹˙Śř?e/IôůIˇŇbˇáQźžŸŇe†8O%Ą>ĆžF|ŽĹéÝLş8ĺř8ë$–Œ’ĘŁöVĎ_ü+>LřŁ‡L˜ôÜŰÉ[˙Lż<Łő™0Ă&5ŽQZSM*]—áÁdy#­Şr­ëřů*řGâúGÉŇ7>łV*ŠI䊊mqm­˙×ő:–?ƒÎ._â)?éö9ć}f9ă‡M‡ ƒVܝ%íˇűäŠă‰ÇÓeˊ2éú~˘sRjRŠŐô¤:Œ/5“ œ9QMI?{IłöÓzlďâäÁđłKy|9ľżŐrsę= ęg’sĹS6âë?rü‘< Óż‡×_ŃăÎóËrjQqžnáLPÎĽ“¨ř˜ďxi§_[>çMÓĂŚÁ8˙L}’żÂHębçZ˜Ç序GłMK ęĺŇÁ•Oöi3ćú‡O§KDzŹVö‡Q&ü´×ŘýŮ'dŽ™Ć2‹í%hł’—ţw,pŽäYńĘOœi;_ľ•UíĎîłú'§őŐ>ž1ň=?Řŕ˙†ý9˙FOţó$gÂżšÉF)š>Ë{:ËŚę1ăSž ‘ÇţiAŃúÉ ú{áe_IpzGRy§JZe“ĺü!ňCÂżNRĽr}‘ŞR†Ü×Ďč'Î8?ŹQĘ]G;ŐŇáwËĐŹŸ/řx?1ŇzTĄŸ<%%™Çâ/‡–:Ň˙ŇŇţĺÉčK—$łĎă<Š8ÜâŕĽ~SWäý.^ƒŚËŇŽžXŇĆżMsŁ5ŇôŤĽŒŁšgí,“Ő§nĆ|Úń~ŚčóK­x!=2K$Ł-îčűWŁúo§CşĚůä›i¸ĽOĆܟŁx’ȧB.ţo—y#—[Ńcë0ĘŒ5I%ŞPR{§‹ŕżMôšáĂÔôŮsĆ–ú_Ηľűň÷8uޑŸ4ąô˜łő­2ՎăźŞßƒő=69âÁdpr‚Ňœ#Jž‡RyŘxżŸÇÓşÉĺpĹÓg’˝œąéü%čŢĄ i}4ŻÚI˙Šűoĺp˙2ş‡ňĽJNMŇöF'éý6Iëž(Ë"šžˇŞÓľšŻ‘<]Šŕ„’éú…éE´yŢ,ĘUţçś>•j?đ˙P_ÇLáŠ?ŘűB‰sľu‘ę=7'Qžúšü,ó¸bǏ FM-›kľžY#é}7D˛˙:ŢYFX¤ő)xŞýî×™Š•'6ľwŤ˘ůÔńÇaôżřŽ?‰éđj Ôž6Tßá/îw˙ឡćpYĄI]¸ž?ľýĎÖ JýËňSÂ?-áŒŃë!™#“§ţŠ'Nž‡ŇĹĐKŇôŽ“|ÚĽź~'ȗѵżäúŕÍÎßdĆGçúľÖőąŐ‡Ó㊜ż—+iň|ť}F_MÉ×tŤŤŃ8g˝RĂt›âUkfëÁú<ż[öü‡QŇô™z\rǏ­ÇÔO˙•Zëö_Üé‡řg&~’9VycÉ%˙——–žťłő`ż%I„~:_Ă^ Ÿ˙*^ęîyç螡†œş9Jďôľ/ěĎ܂ü•<#đÓúĕôBwIü6żĐýŚuţĄ—§O‘ź˜íK.y4żľś}ŕ.{÷c§Íé˝;ŞÔçÖőš2IńoBJďąčÉŇdŃ]?Pđ˝Iޕ-’ŕőŤ§Ćë:WÉÔÎ]?\ŁúTĽUöQ<Ůú_U–HăëúŒů°I|ËĽŒWŮńý™ú _#O—‡ŇżářőtSɒIWĂÍ?•ďwÇ&^.ˇ—Ô}A,kőC˙Ň˙cëäiůçÔzK…Ĺ`y%ľŠbzĽÚîHĆ\ޕŃ5Ôbô졧T25Kۗţ‡č˛c†X8dŠ”_)đĎFč:ˆĽ< nm2̧Úió_ń?M‹V<:Ţ1uţ´żąëé=g'[†sÁĐ斚[I%oݝ1z§b[tĘ^ómeé¸>ˆ& żLž…˙ÓĂű‹qú;HbřY%Őő_şTăćĺÜůő~‹Ó!<},§ÖO,œ˛JRůmóÚżŘ~Ÿ‘„sĺɒ1IhOD? ˇłłťézy]ŕÄܒϵÓńýW_ŸÔşźréúHFpŢ*ÔŢÉoĺ^×Ë"–LQƒČíĽVżúV˙„~ˇ'§ô™!Ś]<ťů—ůCĽôţ—Ł”ĽƒŒĽĚ›roîÍüšôχëäăţÂÔfľBZTšM÷ťÝ_íGŐčzgÓôkJ-*ěëˇdŻîzeQkuj­rS+}ľ$^’. éđaRqŃ7m9'˙¤ĺ˘†U†jÄŁĽĂçŢŢ÷_CęySQůżQôĄŇőn"ęÉ'Ťü›÷ľˇěŐçOă}Căŕ’ţj=\ŠKZ†Ňă˝Qäx˙™ę§‹GőF)[HýܹªTf>y>$0ăŒÚ­J):úšœšfáˇâŁé=~IWň٧ź•pz?řwÔSPƒľuŠl~Äĺ§Ç‡Íčý~)éţ[$śťŠżěyçŃuX˙_Mš7Ĺăhţ€ ňÓăçRÇ(ިIW”Yă”cń¸I­IťZ“ŕţˆqĎŃôÝE|lçJ“qÝ"üżáń˙ŻŔǤŇUm_+ţŃěéýŹęúu›(¸>šV~ž^…éŇN°ioźf×úœńz>ŸRÁŐő8”˝˘ŢIô“ žß—ÉčŢĄŽn/¤Čýâ­~äőů%Ś=&d˙掕ůgí#Ńü,ňϏ.G’PQŠÍ¸ýkÉß˝âiŐ˙/~J׃ň˝' uR͆sĂ Q‹ůÖIkŐçc—Źúl—¨5ŇtŽ0ŇŠEŰ}ŽšHý‰řšôG]VŞŢž¤ů.öž=?Ç rÓNŮú›'Y‡ŁyMŇäĂ8ď= Ť‡jŃ÷rúwIšSœđG\Ő9-™ă— áŒÜş~Ł> í íţćŽrąá”~{/]‹-ĹúIĽ+z âÓú§űe×tYŁWĽă“_ŞJM6ţźţl÷äţžŤ‡SŽœj—Ůžyőřdĺ†XŸ˛“˙T]â͙ėLýO,rôxç=ĽŽŢ+‡ěů}7ą|n›ÔĄ ‰ékNďëkđj]Şă’žš6ĺ4z1úo_Őľ.Ł ÷•-_ˇú˙ŹÍýă۔˙‡:Ůĺő8ŞíĎ}^oßsşčúďONúÎŞq’ů§)(ŻŁw÷GÝÇâÇERŠ¤hçç]ć1ŕč1äÍÓaÍ.ˇ>HÉ)ÓQűlŻígšĆ-Śâ› Ž ÚŇF1‚¨ĹE]ě‹Čn§ÓşN­ŠfÁIm|:ńąó˛ ôR“Ń<°‹ţ”ÓţçÚ™Xš•ůeü=ę=6e“ŚĎŽÓÚJN,Î9úĎIÖźŮ:|šiSJ;KŸňóË?V yßś|?™ţwŇs9.ˇŚÍšUJY­?GĘäôŻCôŽŚ2†)iš“§ –ëčŰ>䥪”T—†Źňu•ŃuIŕK"âPn-~’éůŢŁřmÇŤŽ=T^´ÜTă_kď˙{lßĂ~Ľ7pȗů&żÔýV/KÁż…<°ŒÎŽ2ói˙Ąß(C$ž;nŚő5쟏­—䧋đ™=/ŽĂźúLÉyQoűxĹŠT“I:mŽčŮqź”uÎ:ŁWM{Żs0Ŕă’R”ÔÔ˘–ńIˇÝşçńäż"xżĐtŻ:zz¨Bz’„giKďŘÜ0gëzéâÍ?…–nžtďWýOŘŽ—§ÔŸňؓ‹¸˝ orečđĺÍÎ:rŻë‹§÷ŽGČĎĆüšôL˜ó,}_Q đÜ[żôýÍOř{;ľƒŠéňÉJ•IŸĄËčÝ<őźrˎSťjmÝýLŕôˆáę!™őg(ťßžÔ_?ôńťôü›ôŽż˙ÚfŰţFp—Kž;KDîŠĹîEůk^Ŕ`ÇŃľćrdÇĚe­ROÍRĽŰ–{ăč3ęa ˝xfĂ5zĽň¸ż ŤŸKÓĎ'Ğ rŸůœţLâčđôř<1oWČ÷ż¸ů?ĺ_đר()V&˙ÉŻűűŸ9t=Kę'‚8&ňĂőA+hý–_LË<™'Qę᯲’Ľô<řw:jPő<Šjző8ď~nË3ýK‹ó}GO<*QËÖ˙w>çđ÷Šŕéz\ŘúŹî)I8§şŻcŐIő 2œßSŞKx|YÍSăłđ{˝?Łţ^y›éąáY4í š&Őö­†YK4LlŻN,˜§>žxôIí§töö;+KËö1‹,.O8Ă[Ő-*­ů9äčđeČç8ĘMů›ŻĹŃÉžŢlůşŘßĂču'˞hŇúŁŢ”ľ[jŤŠîrÇŇtřăĂüÖă43ÍÖ<Ëk• •ýöý6™łtú”2ľłMZŮ;ŰsËŐ>őÍ>ŤKŠZa,iÝ˙–Őˇô1Ÿ˘ë"á’=V~ŚQ’oľŽ/đŽ=OWënZpôPĆźŠ)“ń-} †€ŽLK%+íôdrIÓ9źŽ•*vGËumö“zĺ˛Ř|4Uż'EÚŐUŕ֕~ĹQ„{Ť6E¸E"€7JŘ´ű€e&Ľ]ŒĘw›OčKŽIŞ>QÉ6űÉß5"Úf†ö Ř1?-ýkK›üA5/(ˇ`#’Nťř‚9:Ů_ł@ÎżoÜk~?p4Ł˜Ôü°cTŹ\Ż7`ĂWÍ~̕[`l˓OôíćĚj’Úí’QÔîMşëŞ>Q—y&rŞŕ۸8ŃSkť ęzÚďRüGă÷ Ů5GĘ9NNhŠÂmŰT_rœÖČ)>Ě+ 3­%ťˇěÓěŔĐ&ľ˙hšâ—‘v&śű°gSö ëw¸ˇő]˜ÝżaKş@Š‘ü04 ]UyüĐőKČS—°OÂ.§\A•4ÝSł@˝Ű-]SˇúY הfI´ďcš˝Ÿ~śhšcMW&!?™ŽÂR’•_ě5ŽŠŁvďľ1IżrŃQ­qániÚOŰŰć č -ѝ[ÓT€ź€Z\°ÔźQňŽm§:Kĺ`tRRáŮN2Œ’ůeGMN¸ýŔĐ1ń6ý$řŃJűřŁirĚëđ›9Ľ-n[S6Ő/d§ýT•nŰ^KąX”xŁ)ygNĢˆŸťR –۲2Ř) 5˝•Ťäoŕ›ř(şlhŻX§ĺţGÍţf[#’@[’ćLFMϖĚ7~ÇXE%uL G%YA—?ůXsŰh°4fy+fŰěŒÜŸ.‰Ţű„iMľľ ošň+Â(v C’X R@‰EĄ@†PA€V‰E ˛JˆT˘QAĄF…(˘…,ˇä”JŘlœpfÂî(¤(  h ĐÓîh´AÍ&›ŽćÔ|”…E--ݲë^,¨ ~ĚjK…€ăĺY“ogH˛‰„¨#˛iđTŸ)F–Ňh+ 9'/.Ík’ćŸĐ €š| Nř攫š-=ő~ŕh’÷ýÉßvż t|?Üi—fÁ-Ž%Ý&’Ť{AqÚˇłIÚ°RĽł@PeIžĆ€6—-ZŰÜ˔çr¨ĆÓkžÄ’ž?Ő:Ş_c:[}ŠŒéiű#\ĆIýQtżdUŚč§1Šů`tn•ł2ZŞĽFwňÂAL— ŞNˇFwň˙!ˇďůRm+H)6ť#ű‹zŸhŮTżÍIœ‰ö(ęćť+úOÎÇ-žâă٢ |K“Ipi4Îv- :9$éßŕ)'Ă9˝Ý˝Ę; :߂ëö ĐI.Vg_ą5ż`,ăkjż,’¸Ćůűröü7ÝMMř_P›žSűRÔŤKŻffˇŰbŽ›÷ Ń„躀´ź•(/s;1° QńE¨žä¤ÉŚ¸`n—aKŔLY­÷ś.¸e mw˛üObRđMźG6ßľU@rNžďƒZÝ5łł,-€_ŮÝŢßS/qm04Ű|ś?$R.ŕ6ć‚lŔ~ĂW‘M“ ™|Ó'ŮŁj `9Á-“ăĂGd’ŕ(ç̗äŸć@h×#Z÷A´Œšř3`V÷ýKîeśß ˘Ř* °%’ŔĐ3e,‚€śK °(°(("ěĚý‹` BJP˘i((€¤°(%•0ŔBŠś,Č`[ fŁHĘ@#Š˙śM5ělPG=-ňE›GZÓ…ofř( p,vS-™EV,‚ K%A,P@€€P@ąd(‚B‹ą¤T`,X@˛ %[#( B€” (H•Ŕ”P` ,%‹@͋@ĹĄ¨ #Ž­Ôî¨B’ßýőDąŒ¤Ý::莫Ž8-/abUťlҊ\SJÚśúw(ir荊y—“5?bIKĚ~ŕoT_tSŽ•TčŇTź„mşńdr~fł-íť°*v÷u÷%=N›b×ubׂ‚vŮVÁI!¨‚˝ĚéŤ+‘.ŔX˛ (¤Ň€¤^öfŁ˘Q, pG"€Š€ PaÝpM˸öß`˝€†ö% cWěd§"YĆä˛Xű‚€żrěfź–€´™4˘ÓJP”ŠsŚ7v-˜Ý} `[)šměŽbëČ ÷5Nš0šúš´ü¤—„ËŚ/Ę3ˇ–žĆž˙7ěářcCö'הU䁥ű ŘÚŮŹčEŇź´štg\|Ż°Ľá žHĂn_ƒ“Ď.É mÜu–o˙ck$ť„ۨ2Ľ}Ë&jmE[ňrnY9lşM˝.q\É~LË,"ëąÉEwĄImźÍţ˜ţLëČű×Ńë°ÔŔ­É˙Sü™Ó÷-ąvű ŠŮl”J Đł Řł;wŤKkČ… CRܤԟ ÷âż 8e˛mĺ”Ŕ”U°ŤPK)P)!@Ŕ€QI`(PÜÉ`ZÉ`hY’˛ĆŕZ °Ň4›b‚F€Ň(Đ°P˘€3@ш2€Y Ő , K‚X‚)-ř‹(€R-‚"m‹`ś,, d°X˛-‚SPKQd[°P@€(/šv(olvć€Ć¤źWąa*’ŻÉ—ßëÜhh#ҚjĐ<ŠÎ/ĺľgˆő/•×vEŰvŽŹÜ­îšűšQUşý´Ip§Ř  8˛T×ý΀jsďŘÜ[|ŚŠ9WfţˆŸف\"űB'Ĺ^řą÷ü7ّÁŽY~,}ĚNjOb‰~âגY,#V,̀5bĚŘV,Č°5cQ,[)Ÿ¸BŒ–Ŕ´(–Đ2`°P@ؔ  ŀ-lY›ądďÉ~ŕ,P‰šl7 Óńeg~ĺśťąa^K_Ľ7ĺ™×/ü””Ľíř7Éş¤ÎZW„P;ƒ’ĘŇŚŹ|oůr.ÝN.9[ÝíěÍ|eÝ0ó/ ą/ę6˘—ÂĚź2Źą÷`šă䊧à fq”•)RF^HŽ˙ƒŸÁć*ĂîĆnäß÷!éX‘> }ËłN Í+|îvřQ÷*„P4ç]čëÚÜi^ E™N1ĺ™y˘ź°:—ÇWúKń}śÜbű"+˙)É[şěj>ěoâˇŮ‰3; Ş^JĽ'ýFx+w°ä’Ů3k&ŰŰf6đeŚűĐhŁ”ł7拧ČҀçť.“zâě"U ,07BŒî7ŽIóp%WqFż`% ŢčÖĆ[ żběћ-€ĄT ü ö€mŕ€ˇHˇF[ jg†P5bĚîՋ9Ř°6Ý2^ćE­^Ä ز-‚( ‚Š € ¤-¨P0H@ QdQd[@˛Łő¸Žý€;¸ŃĄDÜ (´Kň, B‰~ÂĐ,čv@P@(‰L  Cî_¸ŻvԒŕ&†•äŽ)e(ŽY‹^­+˝żš`ŒZ­âU:îăô+q[7ű“K¸#‘Öí2üe{Ş9ŇŻú–öA]–H7JHŃ咽Ňü°Żš6őβOź’*Í'Çö6î_ŽRü•f[ÜYn€ćłGĂ/ď¸~$?Ě]Q}Đi%ÉÎM­’łŞNš|˛ŁŒu}?š×J‚iÍEöśiF^R6,+M[ű9Ţúż&ě_°ՑqlżKžĹűŞ@E›Ë_ƒK*~ 8ÚěM_ČľŽkań"řg->ďö-*áţ@Óɍ˝ůˆĺ(jwTţĽřJš`mü5ťl…Wf>ÔŽ Šoî›ÄšdOâLΚá?ÉżéÜ•üĚ̒\JţĆT]p>n4żČCpÝr‹óxýÉŚ\ťű4WąSžĆ”{żÝ•éTŠö.ŸfoěżRKúh _RlřfŠxB˘ŔÍ{„˝Ń˝†Ôj‹WĂýĹGÇîM1đ†Â—f×Đ´my-Ż%Ż¸í]€Í˘ßłeşň]L ödű2ę`KBŃv›ka°gŘaůAůf‰OÉŞl ךiĐ4 &ŔŐ"ĐüŇźěi’“ě€Ÿ`[ĽH 3šoËEB,_šIKŔ Df´ŻbPĄ¤Ő :}ˤ×b4Ň(ť!°…ůŔßÇîGŤŰđŘľĂ{„ŸqL!÷ÁhW¸VTUťăŘ|8żę“T"…S-/"€TJ7ÁZžx_ÓŔ >ŔP/ŘX/Řś…@ ;€(˘Ŕ”(rU°‡Ř 6 &ű%!Hť 8Ş÷&•äŐ VŰ1§Ü´({ 7WËŔ§÷.ăp%}…{2î7=¸šÜýĹ3` P7AŤ@bźŠ7_pă``ĽÓľ @]"€” B€€´( B€€´( €¤ @ ( €˘€€´@  eR €´ƒîPÜoěPB€(†€ˆĄ@@Z-j…jˆĄ@@ZcrĐ %Đ 3BP % (  - €¤€PëÁ6íf€Úwi~ÂŚ×dtqqŸż!c“äíD šrQÓŮYĽáďôłbؤý‹]­~ ¤ůAYҗţŤřąix&Ÿ`]~¤ˆá˙1Şö%4Ÿ`6¸pP% ) @ €  ŸoŘmăö(:QkÜ  A*(n>ĹJP˘Q ˘Q AĄ÷(ÍŠ% (ű(Q@…/r¸oqą~ăî!Ą°Żq÷5°ŰÉFlZö5ˇ‘°ԋhť €—ôô.Ăb bË°7˙v/Řl){/Ř_°ŘR HT| (%GŘRöGŘi„P1&˜űhQ4Äi_÷@Zb˜ŇźŠ^`4źź€ĄEŘl˘Qj>ĹŰŘ ĐŁ[xDŘ Bm˙llhQ­†Ŕf‹E¤J@JZEĽä B‹ˇ‘KČĄ¤ÖŢFŔgIt˘ě6P˘ě6PĄHťJŘlŘlŰČŰČ…î6ě6 .Ă` .Ă`% -Ąh B‹hlĄEŘZP˘Ú(Q~äĽç÷E˘m˙lś… BĐ ˙îĹ Z€hZĄh hZ -Ąh B‹hZQ(ÖĂbŒĐŁBŔÍ 5°Ř ĐŁ[ €Í 5hZ4(Ջ@f…´64(ť €”(ś… J.Ĺ°3@ś†ŔJB‘v+č(ť¸…X…˛X…X…}ŔšElĄEŰČű(`!hl6D.Ă` €°Ř P 6B†Ă`(%J(P˘€% (P˘€% (P˘€3B3B3B™ wšŘlJ]†Ŕ@Pű€ ((‚P˘€ (ĂđĘ?˙ŮPDL-2.018/Lib/Transform/Cartography/earth_night.jpg0000644060175006010010000015347412562522365020364 0ustar chmNone˙Ř˙ŕJFIFGG˙ţCreated with The GIMP˙ŰC$<'$!!$J58,b.´(  ]Ŕhš’ęÔťK¸ő˛j}ÉGG$×ědÔ}÷BŞë]†żcT†šŕ˝F5ű1ö7_%؝ÖßşĽŮŇťŤ‚Á„ĺŮ —ąťf\•Ó@eš]Yľ8ü KŚäےęČŰînRř™ť"Ľžě–Í4d Š÷dˇÜX  T}Ń­+ŚćžĺÓô.•ÜĹžâßqFšž4žäÔű’Ŕڏré^Ć-÷˜ŁĽ m{—Ěö-Fúgąu'Ă-@X ˝ż¸Ë”ťĄG@rŐ.ăSîÉUÔZîq߸v$ÍŚŸAQ J÷˘˘€Śż¸ )wý ŚžŐăRöI 1Ťą¤ÓęŞę ÇR*oÜ)¸úXM˸,A ´@°]€_šhŸ Bě]ť ť–Â]KôhahĄbĚš¤aÍô%,š—s›mňBUtמéý Ľžç"ĹÓŕ”uŰÜz}ŒŠŽĆ“^ƑuGšLúJšî×ä×ĺÔť” I’Ęě›Ů#o“śJ6ôaÉ#:Ťƒ ś(۟bůˆć UÓĚAMŔŁŚ¨˜nú"@@*t@QŃ?ręŽç+*}ËGMËš„ßFU:çqQ˛9{™ŐÔ˒i6]šŢŽM–ĹVÜo}ŒžČßČ ‚Ś‰` P ˘ß˘ f´K°Ń.ŔdXßVhŠĺţb@ŰňŇ˙F€şŸrëfAFľËš5ËšSî5>ä]Oť -° -šP÷3š}^ŕkBîÍ$—-ö4ŠŠ‹(°n‰`jÉfJ(ś Ń@ Y,   #ƒ 2[Yl,ś–@nP¤°˝IdŐ¸Ř ´(”€ť %"(ďČĄH̖ۺ0ŇčŰum.KąĹAšQĄFÚF%ŚˇŘ=úŃ<ˇŃŢ6eŚš3›‘ŸsjIő8ÍfŽŕĚe{4€%@PeËّH”R27OvM[ěĹö3&™]¤a“TŻbd@(P)DRžćŇH°Hăľť6ŁG4ŽnM—˜ŽŽQ]Œź‘Ě ­y’&Šw % o¨€ L€.žŰ”@iD8(Qtű–€$şî)ˇX]ˆ,X 6 ,[°-žâČK}ՏĄšošRiň”JDĐ´QA,Z€jBĐRî[°Í>ĹI”v3Nöbßa~Ŕ)÷(7%žĹ-öiw é\\’äÓ|27l†jś›˙ÉűČć5Gť2äŸC QmOť q•rË­ŔŁŞ’aÉ'ÉČ :9ŞŘÎśM,Pş.˘ŠąIEĹĹ]óÔÍŽŠK¸ÔťŁ -m>˘ěäšętX3<~bÇ?-íŞśbŠ Ďli9ÂpOIŁ;×"Ž„˝Î{‹}ĹAĎ[&§ÝŠ:ƒˆv-Oť*›ë¸¨č yą5ąG@rÔűO¸ŞęFč“îoRŐ+ÝQ~Śe-ö~¨+@ÎŚ†§ÜTkŰŘÓ|’ÉUĐMw-ŽĺF.=ĹǸÁ/ŕ ,ŚX(Ź"n4”ÍMú‚Š4Fëäדl‚§śďr9Pěy;ˇ'żwFŕě+I$Šeşę-÷EDȈžÜł5š‘LŮl˘>ÔM×RŰČ*žĺqľË3e(ˇmĚ=Žź†—RAČi>#…đHŽ`։iŽ@!J-›RtsLť°:Š&S’LŞUłłU` Ż’-÷iľŃîAt´í~č9Č0Ő˝‰ÁšŐ*0ÉŞ€ ¤H !@Ro€!K9É+KÝđ4ě÷ܢŇÓłwů•nA­ˇŰ°”\]:ú; 4ÓŚ¨€lYÔWs%śQŇčĚä’ęFÓ(Č/Ԅ Ť¨+fé ‘J‰H$hËAYWĐ­mż%L­Yiö.›*Ř_°VŠ ‚’)ą"TX,X QlH, d[AaE˛X -ľĂä )űP`ŠˇÔQ bÚ|‹bŤdnŒŰd˘ŘÔČş˜Ô@ľ{ HČĄFîÁËlľԆ¤Őě5{A5{4Ŕ7ŸK܉íToşq2Š[ŇTGł„ÖŰn-Yu"€¤(Žş¨)šTšá´6 'Ÿ6H(O.IAnŁ)6‘Ě7|‹I„ş‹)v&”[M>äŚjŐ`Š#P­šÜŤř@”Z’&’´ `EĺÓî,śTeœKěm‘Y[> j_YCRî6dV‰FÁËšhŃ,ÎýKô śRŠ(ŰŠ)€7ŠPŐhĹ1BŽ܍ľ×ňj-™ŇűšJˆ§ĐŠű"¨ť’§} *ëp–Ŕ(¤wĐ ŞŸróĆĆy{˛§\Dő+d˝˝Ę—[(&kY†¨XŁvţ̌`#|Ł/bĄĽ2Žl‡Gą,ĚVAZk”@  MiľŇțwżĽ°"ö4H´ŃM ţLů‰’‘3؏#č…ÁҐ¤Ž~aظ:6ťYÎO}’űßrÝRŔ@ @X•ů’ÖĘ+Ż¸ęËŚ’wô:G.˜ĹE$×V‘źYž&ÚßRjK„Ó8pyˇY!ë'Hچ8ăŇá/5onKKO÷ÜËȜt¨Ľż=ZěbNÝśŰ|śX*PM7ťíDM+ĽOŚüËz#-QmíĽ=ĚŐS 6¤ă­ ĽýÍna:˝—Ő4Ý:KÜh–űpŻ~Ŕ]Ż‚7U˛D5Ş ăKwťkp&śÝśŰ÷:V,Š77 q&÷_dŽEQ”“i6—4¸8ĹJŁ-K˝QÖ >\sɊXá̸_÷ěqŕőâŒóx.rĺŸ1ĂšiŽŻˇ=,š…śeŇJ“cI¤˝Ŕ%DnŸŒŢĺ1`PES7{Za:tÓf\ĺ{=Ěš68ŁŮě Š (\Ý´›čZiîŒĆtkSčĘ,;Qł1vh¸€ ™M 4KLćň6gSř3GfŇä̲%ĆěäÝňÉžH• ĽŐÓŽ,‹ž,čĺ*Ó˛kŘm5Č7Ę .*Ń`Ĺ:şŘUďJ—°“śÜRŠ}Ѓé^Á$ö{{ˆ9‚É%*NŃ ťÉÓ’ԝ{znÔş4Í9ÉĹF]7÷˙`uœĺŠp‹Xäą˝–Ďď\œe'&ܡmݑ:ěúnd˘Űŕ†¸NŸÍ>}Š’[lísĹc% I%&Ťuc 0âɒqŽ8yń×ü§›ů^W™*vçœeôçęAÇ”˛Ľi7ęť_&eźĺĄ:ž ů˛ŃŚŁMÝéW÷äď/—JŠY$ъ_Úţ„ÔřbŞ5@ i5'ŘČ(ëO“g(ʎ‰Śk@ +­€6ťœ›ˇÜß$1ş €(XiֵޞľÉüĚZ‡—;Rüzš_uGNÉěůžQČnér‹ćWC˜mä}—&ČA@AA­ŃgĽ*şOg`@@€PB€ą‹— ţ€ôżŠ‹yuIďJ;Wëů Î..Œcî’‚ƒ´žÖzĎk$ąJ8˙ň–ÉŻßc Ԕ•¤žÔ՗SusĽI]ňúË-3~SŐ ­Zjöř9źsQRp•>Ó­ó¤‰+ő6ž…ăŸ.-_W˛i9inú> Ď6GŽ¤ŰÇÔ_ębăM)Éßx­Č3Mş­˙SŁÇ•W™$–ÚśTvË,xąĆň<óœ7R‹^_jož§’s”ÝÎNU˛śyů8 §‹3”ŰŢZŻ­œ–I[mÉőîCÔňGD`ž¨­éE|žUűĎÉÇźŠrę’Ů}YĽ8¸éßkŽŃ_ö%‘9CÓJ*—É•ҤÜn’ę–›Ž7Ú˘´/1Â95ŞÝˇOžÝ~MĺÇbÄá‘9I;Šć=ŻbŕÉ^dbáy ۔“n5žÝžÜî TŚä•.ZÔ§Ľ8§i4ú[–§ë—eXÜcĺFŁĎŞIˍţŸ@9GgošŘƒž $“ćű”VÔq­2ÝڒŁ?CM8㍥ęÝ>Śl-÷+Ľ/KuŃ˝ˆź6|Ţ'™ƒ#„’ÝŽÇ6ÜĽ&ŇmﲢĆQQwuß­˜]Ť‡#Ą( Ő:ě@5Ľďˇ ˙ě´Šť_@š4é=“÷˛[ŞéŘ ĺĂ,-)86Őúd|цßýŠŤŢ6ž@‰Ó°Ŕo„TéíŘý€ű´úQ˝¸j)9z"u ˝˝Á,  @€§ůóąf˘ĽčmŻu@dŽ@^ÖÔßš­–ëý€‚ë›L:<Čé×I]ěr[ďą m^ä€ :ŕ´J)íAťIWŘVőh ý€]¨€P  ŕŽH5¨7kb €( ˛ŠBň@D*~Č ÉLŮl •´ś )@…°'ЃKąxFSŻ“.VZ;ËĂdXVTľÁ˙twHď‡?†ĹáŞ8ĺ/-œ˛F2„}ŇŤ<Ć’RuËO¸óâ+ŠÜ‚ͤî[ˇ¸Œńš%$Ôz´­œÜ›ä‚ŽşSÝqŇȓčs˛ęhQÓŐeҟ(çŽ]ʲ;ܡ§Äj‡˜kR’ోœ”U&Ýné}˧p˘žVZq“O•ł!\Z'B0,tŞ_ źšĽŤKŞś×@2)´÷Jż0‰w/ŔéŔ e !€,*4e.!JŇP–¨†¤dŠč( Iu2@4ĽFAG_1{{œŠZ;ZŁ3•# Mťv* ʀ @ (î@ś9gŽsÇ(ǖ‘Äőx ٰ䟓•ă¸ú˝J6ž sV÷Q¤ş'Ô´ĺ*„dŰár%7źgŠÓŮ28ĽMžU˘I@€M+ô§ˇ^„[d@[űZŚ@TQd ~Ťî°KBČ(nÉhX %›ČńÔ4Jý+VÜ02En‘–Č-”…@, (Ů, 6ŔCÜ Ů-€(  @QHČ -—SdŚZK-íARĺ™o˛ rě4KK•=+—["Xm° €  ~cŞjÉnŒ–-.SRŃŐÎ#WŤűŻ‚iOs›äÜlZ3@ŢÎČ×^⠊+ˆÂ`jÓ{EڭՓuˇr#ɤŤSuDëščuɖ2Çp‹Q‹ľrż’äÓF´4â­Úŕç(Î?‰rŻčU˝ŤíżŐmm—MŤ„dűőŁPÄć›Ő—y%`sšJŐîťndƒŚ%ŽJk#q•ze{'ŔöTŇ~Ě~Ě (i~`{śű•&î•ŃĚ Đ4Č- *e2TQJ@AH…EËE žHd ( JšÜ?b‚×vtQž6ֆ¤šuş"oRŒš’íĐë;<ŐMܝ[•n˙ëňÍNŽ™^lę<ˆE)ˇëœd÷]žç€XIÂqœy‹´@§7‰~+ÄK6WŚrvÚăčf1ĂRו*V´Ĺˇ#bľ4€é“,m,1pInŰÝžć.MęmżsŞĹ+iŇĺYŻܲ:†˜żRN›űÚ>RđŇńă“Ęv›­“÷ýô9(c…yžŽmívsŝĂąIˇŽ[Ňčú3m8OKŹ‰ďŤŸ˛îpxĺ–9a’5Ěx§e”˘âă‡Kń&Ýş_“űr¨´íIˇľ*÷ßčUĽÂRÉ(ś•Eo|ü~ěRË)=˝)ôŽČˋJÚ˘'N×BĘNrr|°2UČJÚ]ű›Q”Ş)[]‘Dşá–ÖšŢúďľ(šzśMô7›ÉRţ†˝4żý*˙ 1ˡÇVeĆĽqŕŽßŠťlW]žŕ% 8Í4×@î˝TŤj ÷鿲 Ł)Fâ¤ô­öş_śŚÓPq„bŇ_Ývűť2’ˇů[˘(ˇŮtř7}ŔÜŁęQŽĘUW%ůł ŚÜ>MĹÉ%jZ%ťWIĐKƒő5’öŽŤć˙Ŕ”\yTď¨XýNqUÄoviGJ—VŞă§őO֟Ś•?ĐąĎV¸É)nśĺ{2dÇ,rpÉŞŮíůžL“¨ä“ÓÔcw§Ů#rj2„ń㚋^kóž yÝ_ ľéˇ_Ą d•%ËŤ­“5—_ןŠpÔ­)*°1Qt•ÝÓvGýŰ-š['ĘʝFß^€=;=ŰꪎŮsbž:‡‡Œ%I9jmżsJ9$”Ô˝áĂ1ÓkîÓ\;\ö5$ĽęŒ–Ű(ńą;nŸÉŰ błż2NIÝT|Z°9E54”´žöuÁáŢiR͊é<’Ťýű™ž8ŹQ’śíßÇO¸Ž6Ő5ĄŰWďŮŰŘ š1đţ&ądRŃ-ĽřfrůjmĂT÷ü\!)˝S…%ӞܙkKjԒęˆ;Á,Ţ[AKý"ëďżŰĄĘ)Ë{ľśöü?„ÉăüG“ƒrvzIÁÂN2MI:iôgŮđ˙Ă|„ńĐČĽmé”Ý_ˇĎąĂÄřâlƘĽ˛Ý˝­ě u˝őRJř;x‰G4Ł“ĘŒ•5Vű”y’|ÖÇI8šIĹ(Ĺžş6§5 EN“ĽĽ>YŽ“[žŤ€ N´¨Š9mĆâqxމGKVšw¸[éŒZˇŢ•}KĎ]Q––ĽwĘL ĹĆ2śľ%ӂW’Ôžč ›Äĺń/Vij})R_E°–w(Çd´đ×)vł”Ť„¸ë܀jYg)99ÉÉňŰvU–J.-&Ÿt›ű˜uSÉĺ%m}ßS“Nő5]š3mu6˛Ô4AŚÓÝo÷ä\łÍĽäÉ9¸ŞZŇö0tJƒvÔŐ%äĂKĽŕu=:y^ýirŻęBr—ômpÚč -7Â{Šß”.Ď؅Uľß¸1ťŚŠ+Ýђ´ŻbS´Óéôd-:°šS-ŮI@BíB† RŘim6–ː2 É( (Ň)”h F3l[A … „Pm´•ěˆ€[ A€@B ŕ*tjÓ0iZ[§LĄ]ÁŤN…_ rPÉ8)$˙ şbNƒÓ$ÓçuAŚ‹I˝)Úęż2žÔWńą|ŠŹ^cĆô7JMm$ĐÓJ^›îmŐtNŐďE†IF.)-ú™U˙ETęý+¸ŁŽM\œU%ˇűŘ߉yÔ2Íd”›×uń¸đ8ÖoRĎ kVҒŰäçĄFn.¤•îśż~$c ×RíÔéĺdŒg5'UNîJž88đ¸ŢĆî^Ľ'%ĎrÁSŚ›čťŤKĄŚî:{Ň|WĂ(ë“O •G$tOOIěÖÇ;[‹ďłˇ%měßĐ änOSmß}ĚŐ´˘ŸÁşvśúłM9nľ8Úß­ýČ9J.2qwhsqI4Ťö'ö dĽžďŰĄŤžžŔ@[*wśőĐ (*­˙"Xtě‚rqqJ1Ś›ˇ|˜ťú€ )Jrr“r“ĺˇÉ ČĄŇ•s\šUŁtÔş{†CR¤Ş˝W͙ … €Qč„TS„ĺ%{úUžuą¸e”$ĽR\0:Ĺ7Jýˇcy.KÄx‰ćŠKžýí-ú÷ęfQóaXpJ0ŽňMęŠ{+żö}—Ăř,˛Çâ|2œäé˙R:R ů^Tg‘jÔŇŮéVëŕá–ŒęŐN꾇Ňń#ĂO$|ź_Ęňیďčxż—tä䢜i;nŸÁppÓgҟđź˜|,˛U•ÜœÝ.–‰ńĎyź‰I)BY—Ď;_ĎCŰăą8xŊyăâ%Ky?[]ŽŘÝř>lg/6.:ŞŞŠŞ~ýNIĎSvšKˇűŸC‡Äüdcăç*~•ëUŰwҨá㧆Ľ‹Ăŕxž)ťšˇoŮ?đJ9ĺŒód„rcłTˇü6ťżú1—Dœ§+Š“Ť{ˇÔÓĘŰË97[|ű˙łQŐ%qj*›Śö_şý 2ŕ९ӊZm]Ž˙žÇxřoüŸŸ/ä\a§qŠ1zá(IĘŞ:ZŰöÎpŔžM2”c$­'nýś˝ŔÄĽ=roFé%Çď‚b…äJŇŢ­đnP”â´ĂđôKétž MĆMޤ÷{nš¨Ź9š¸NtiýŃIďé’úÚďwÉ_˘MBK$jőiż­?ň0dň›Č”˜´Ü’|ŽĎ`/‡đš|Vo' ÔŰۧÔĆLSÖxeŽ6Ÿ^“šrľšß÷܎œśM&î/U”šĹc„ť~•ť3˝$ÚŽ†Ś˘Üœ%'éZßýэ5ˇWÂŰI˝;_4(4ănöwŔĐŐŚŸĽú˝ŒőQrżJ˝žŐ{(şŚ’T›č‰J(şnř} ß@یa‘Ż1I'WܞžÝm’ĽĂęj•IÁ7$ˇI^Ý@Ż.IbŽ7+Œ_Ľ4şą§JRIŠ'z~ŰY•$魓{´FŠĄRqOM°1ř­ˇż;ő4ÚüVő>UR.%‘G,§ńéV˙6‹‡'—›Ěňá4şMlĽĺb›ňĺçFQÚ㼧Ü柯+™Ź–ö¤ŐŮőľqçěI¤íďÇ ˛ëż]&ńĘ2¸ˇśÉŽű÷#•JOń_÷>D`ÜÔcMž7’rÉ79VŠné%úp*rśĄuÚ;qeĹMfŔ˛JJ“ÔӋîsO†śkˇ@4ç?/ÉŃNŰĐľ}_&Ąâ§Œ#Ši”šś×k|}NM§nV÷wՑ:[?ČAŃdn*œ˘ľ[\Żš3XŰ{ŇýţţŚ}.-ŰŐ{*؀Vř\ĽĐE.źôލcË_)âY&ąˇnł÷g9ZŤä„Q‹ƒ“šRT”k“ _KŘIš;“mžŹ ))-תů"m2 䔕+Kۑ9šÉş¤ÝŇá UÎäŽČ•‚ý NZŇ[tTPîQřĽ+Ž<ŻGE‘.>i[8„ęö_Rž# đůeŠn2’{¸É5ůů{ éđ¨ÔVÍśŐ-Šr_PtŽiÇ„eQnŢŰýĚÉĹďşB×g÷P””œbڎíĽÁ“k$”tĹ´ş×_’sŃ/€!ZŘת4×ĚŔuÜkńlŁżą7Kň°­;Wtřî8÷C˘ ŕ…ś­ž ä…z’Ůôę€ćŚ÷żp,5KMęWŘČ[\Qem:}Ő’śˇ&ŢßEFąăžXĎD\”#Š×EÜç}oöěSč Ă- ĽFEŇŽ<ž\dœ#4×\{œŹ]HČ l€R (@€R(!@ H4¤řˇF@ŽQrˇÝ-x¤“pŐ4ˇÔ˘ężvqłŚ9Ë–H6œx`vţ[7ňď*Ĺ)BëZ‹i}x8Ĺ;MzWţ]Ą‡ÇĎÂĺOĂe–<2ZĽŽöŐđŸÁćńđńüLĄâ\ÜÖë_4÷rŒ|Üą‹zc'Ď4_8Ď'ĄT#鍪uîgŤTůěY7r•~'ł˘Œ¸5&Š>=Ę˝XĺęTˇŇŮŚĽ8¤œœŃťuěfM9o&éUĐpUšS­Őň˙tt‚Œ¤őäPtÝľvÎXĄŽZň,uűRڝűč”ń¨(ĂWţ[đŸîŽrÓQӝoní˙'q]—ÄĽ{Ýő&돷$ŮÝ'ěN‹q’”ZľUjÍG6XBpŒŞ3üKšŠŚŠ­ýÇWĆţá[piĽ)*}Vôiáo˛cjQâé[œýPßV–Óă•ěX*ʔĽĄ7N[íö GN´Ľ)(ňÚ[“kôöřŁ&I_>ÁÜőKe[ľ}éá׆ţb?Ěy‹ NôÓdń/Í?&Ţ9n“•żk÷ü̒ňŕĽ'ŠßčaÁĹÉéü/túÎ*-úĽJšJÂŤÝľđ^wqO§ŃĽí-]ěĽmG~ÍědŐ5ýˇDptk đęZćó_ŕÓ˛]îÎnM´émĐ ęśd TîşßÁV˙ä*˝Kŕh•'VŸb$ßNt“ÇÄu5\žŒ°„nQ›‚ŮÓmóôš]ŮŤeŽÓZ–îä—Ň™ÎNÝ]Ľ˛° Mú›KŮWľ×šřňâň|šÂšwŠ$Űö7š> áՃ&U“SôN*ŤŚč/B薝J/MŐ×SŚ<.IÍ-Q]ś_s¤çŠ8ńÇVL•ť‹Ú+á9C$1ĹŢ(ä“ë&é|WSžü×äzc.G?!Ö?v ž90đN2IĘ+ť˝×Ӓ*U؛|S‹ËQ‹‹ŠI§;Żcˆ˝řDś •żô*ŮŚťěmIAzí4Ԓkô0ääíîĘ,ąúŞ WòO…ú“w[Ő8Á.#-řç÷E¸ĘKg­ˆ8ƒSŠUIŤ]L€ @ çâ›ĆĄv2ôăÄŚâüíIŰ{+öüŔߎx˙˜Źx^F“ŠęéÜĆK.e MU:s¤›ŚU–1Ă,SĹ d”ÓŐmU|leĆ ś¤éGg\˝ŠPü0m$—U˝k“ÔÔÜ5şqWş÷;f°¸Ĺ)bx°ć”#E×ÖĎ3rŻÂŤž?É]ÂRŠďóɗ+IPŔ”ňĆ.J Úrjъßm밋qvšŞ7ŠR„ëLeŃŠp˘ç‰C.˜5+­U/Čć­ĘŤs¤e ^¸˝=.Šsľ˜–^U˝^Űt(U˝“ŕ‡\~T}YTŚŤhĹÖ˙'=šŮo} vV­ÓjIěŃr?[ŮĹđÓ3tö`nԚŽŃ]]?š!(Žb›ľžűoj˙ülšĆ1Ó(䏫zÜ~lÂßi:^ĺéVţRsVŇ\7š:§ŤŠŇqŒ'ŚĄ4—âŢž7]ţ‡>´Ľ~늍’_éŚšéwÇČŤF‡ܞŰo÷$ZÇZą§$ďÔökŕë­Q–ń…­ůś–ç|_ĂłçrˋłcŒˇ–×ĎUĎra9`ŽIĎ Ţź¸Vž9i|}•hVäÚQŽěëĺ¨ÉŚýUĂ˝ß4a-ÚJíZŽ€cE~-ˇÝuFŢdÉ5áńÎQ[ížŢ椔b˝4öwV¸ýý„w‚”#5%ˏŃqő…>ń%9¨Ĺ7&é%Ë59%9(ĹĽ{&bĺy%.8Ž~ŸsÉ âœĄ8¸Ę.š} đn˛SkuߡîÉŽďŻFQGLž>,Ď/Ĝc$˘ˇôężzú›yŁXԒʣłrW_6Ž˛”á‡$—Ąw~ź~ţ§)Ă7‘“Œă‰˝)ľł}ţfÎĺ0„Z­ÚGqq‹\l­WSÝ?ĂĽŕŁ)eËëgÁ;<G^¨fTŁu8ľôĽ`g&ʖ:[í-ßćeÉĺÚ­ĽIśř˙GU”ňK6Ś¸ƒOwˇĺő1˜˛â”%)¸Ér˝ž/ő`f fźßkÓžß Šgpš%}vúŒ“šPoOá¤ăWő÷ž'ĄFKń7+Œˇí[}@‘¨ţ)¸Óş\ŮÚ>*_ËOqÁŹ’ˇ'’ř}9g*’iGnk‡ôúkxžœđť”'űíľˇąœ=śôě”RŻšźň’JVăŮÚ\ń[§ęmď˛Iö $=rI:?‘zozžŚ“Z˘Š­ő{‘ˇłŇŇ­ż X6¤Ňuk§ßüT\šNśz¨eŠ‹‹ƒ“UËUňTľIEʤö““Ř|˝ 9ÉIşăjîäÉŁődďđď~䇕Vg̔/KŤŰnŔn*2rY'§Lv­íŽŸňWBM9¨íŠď k<öÍĂT¸iűÓÎÉŁFŻOÁ$ę‰KťůM.Íď^ĆV99¨ś˘ßţN€Ü\"çmď´˝žŚRĺ4äÚڟH ÝÓ[{!ŽoZŠÔÔméWŘ O$tyX”Ą“’”ŽŮĘ:Ż]U5˝lm-NĽ%ňřü„qdœôĽëjŇK•đ6÷uľ‚¨ńŐąoM^×ÁQN •ňŇčGŔŞtö~ä´'9䖬“r|[vFĐĘ4Š;ęŒioƒQhîěQQHÝlš`8*§ÔEHQű  (6ŰśěP­$ŁRśÖëąۅ°L[ÜĽŚŐĽ`eS }EşŞ uٍ×ű"NŠsiAc˝O]ţÚťŮ/W4Šv˘Œô%Iˇą…`˘€%Ł@ îRĐ€îíîŘ@P R &éÚîA6šŮIZž›2GmÍ:IUŰü€é‡ügˆňü>5m6ĄŞ¸\Ű8¸ĘQ’Ó%łž‡LJkV†˙ Ő]ŒĹĹËŐj=_,ŠË^”ßo¸Œ´ś”žžŐÉźď Ë'IcoҤ÷G=˘řMŘ‚‚Srқ^ž__ß$pi)Jš{ěČŽRťśÍçÇy\bŐWIŠţhM–š†ľŢ¸*ÝÓ{ˇË$¤œ­E%Ř €Œ†ŞˆŔE\’:ICĘrť–ŽźŃ˜AÍň—?‘–š{č … ¤RŔ@P…B B‚HP(€(  @ CŚԛ]"˙J0nq„ŇKŐłý@ôë˙üřÁdWŻ|{ßłíÜĺ‚1zĽ'J)ňŽßDYcžL1œa8áęi§Őîţç:’‚tôˇł.ĺ×,t[;î^‚ŰŻbŁxáćĎK’‹­śě˝†|9°¨Ç69CŞRTalt–i䊎IJu´u6č+œUŚôˇ[żd_)T!ä9ŹŠNéĂ}і–9¸šZď O*^_™^›Ľ}YÍÝďąß4–I4Ľ%ߗŃraÜäۓiRWŰĄ¨Ň¤ű–_Ӝeľ.•Ă÷˛A­W4ßĂä=ŐÖßB:u­Iéľi=Íe‚†iF-Ň~–öŰŁ#pŃĺŤ{ŰbKvÝš.ě Ébž'4üš$Ş<ęč߹ʯŞâËĘÝţA×Kúô *Ý˝ŰăqMSUňş ´–Ű{Vř`i\%-páĹßćiĹĆJU$śdTí˝™ÖZźĽ“+מˆę–ę˝ˆ9¨Ë–ŤÝ-ö=žÇřŻ ˜ü.YĆ/˜éţíŻăŠä— TZéśü‡PRB\ďőů é)IfY#™9JžĽ|öß­˜—™šÁÉž˛ÔŸ×Ž¤”"¤œĽukmúö"Ć´9ZIVÍŤršÉ8jŐéŠKTí×Řéâ8B^ZmcmyŸů7ĆסVj›ĂůIĎuË&Śî;*ř˙Goâ8×˙ á˛<\”ôęż˙DÓwűîAňąĹi”Z¤—Éčy%)6ŇWÚIE+ĽĐǃ”T§ŸĘ<Ľşv¸ý>§Ż&7ĽbËáńKҜâäřýýĘÓoĚN0¨Ö4땿ďţĎlż‡eŸ€YôG7$ŽrQNŻƒ„|f,3„đkŒ—âošŞŘéĹbĎ8=ƒ^GDd¤âŇî•îůűćqđúÖŹ-őWŤ{ýő3…q<šďf•$žODrxL~'+„YqďŚ9Ů|Ł8˛aǒrxSƒ_‚SŻÓ{–Y¸zqĘ.5ZĄ{˙“0”VH˙záę꽝lnRÇ,*>BoŠIßץßđďÁKDœsK$cM^Őʗ@<óŠŢ^\âˇÖŠŇž7ýđE9ĆW9=*;Ű⊱Ęj *ŢIT}/ň}?ŕĺŕź ńzžźŠ1Z“¸4ˇýü >ˆŒ0Ëʓ‚jOVžWˇýœ2çyfç%s|œyoS“QofţĆĺŞq^„śm>~ZäâW&ŇMś—Ŕz1xšxw/*iĹÇÖľsËGśď܀‚§Á`YňI&ľE9SŢŇÝĐu ¸śŁ&–íŃmŇMłŮ“.\­ĺ›Ţ[EŻJT’ĽÓŠ5ƒ6oŸ\9Óȕ˝î˝ň€Š_›'))zšŇŠűŃŢ>'7™‹$Ö7 ¨ŠÁ8ŇöŻp>zM´’śĎ|źGˆÇ á‚ňń¸Ľ8%W[Y×W2ŎŻSɎ*R\×]ˇ÷<Ę⦞™'ΨÝüvp˜Ą9k“Ň—+÷š™AâÖ˛EĹŠ8ľtţ>äY4ÉäÇčšvœmWÁÓ$¤ćőN2×´¤ĺ{ő`sǂyŚĄŽ—wśëŠŰ6ÇÂF7Ôˇ‚wżđO›/‡ĘđbČŁŽ1U,qÓŠwžy8ř_â|#ź9)uM&˜Ž¤Ô1ÜĽ%UnγǗ V<÷‰Gy)I_Ň<ßC›ţ#‘'ĺB[Tܡ÷g‘śŰmŰ|śyćŒ)iške'$˙*=˜ź7ˆž=XĄ‹>ŠNTŤďM3Á :Ą)y‘UTúű|›Ç’:#)Ú{=–ŸßĐę8g’pËx%ş‹ć1˙?Šĺž,˜e}Ú˘í}Îđ›ikJQěĺK÷ąÓTźĚS“ňfŤ‹řúâƒNI6’îiÁŻŐQ3až Ž5ŮÚ Ë^Šy—TëCęc…żäŔ´ęën,†——ýҝ_ +ý—#Ćĺ%‰äÓ~•$‰FoŽĹRkđśťÓčoˆx’Ž;’­N:ŽJNmť˙ޤŻÔÝu|—Mń*ůŘĹž7Â-ş§Âč,›‡oÜ ˇŁJIőˇĎúŞřëÜĘŕW°ňbx4?675iÂWˇN­îś#úŚWŚ¸ú”@WąVϋ%-GO[˛)@0€¤ó›ö)›[•EśŠ[ěj1”“¨ś—n„ů (śŇIśřHt˘YUę¤éü9j•ţŹÜńáńB8ĺÁśćçdq¤âÚkń$–öůăěŒŢéŠnżŃhMâʤ”ŽöŞ7†›–<Ż-ZŰv>šœ5lśü_ż“Sürvžö›\ЍRÔôßáJĽż;Ÿc˙˜đy„Żâ0šEEFŕé§íϡ>[žIc„rfSŠĹé\éí­Ÿżš•‰JkqärňÓIu|ß|źy°BSÄ°^'˛ŒäîűíÖ˝ŒKX<Öăr•RüIWďěwđx#dósăŔąăâKylú}šÂj92Ö(ˇžŃŤmü$LsŽ<3ŠŒă‘ŇSRI¨őĽţF áóçQń>#4SKKŃKo÷go‡gÍŽ1’×(+ҕ*ů<Ţ!`Y_——$ńĆÔ\—žËŸ=>+ÂC‰Ď 8ájľţ9űŚ×čx˛O$ňIË#o'ă×ׯú:cÉĺä–FŚóš­*Šó|}?3ż‹ń+Ĺg‡˙[d—ŠGhž´÷ôAâÉ ÎRqšCfĺŃ.7íÉÓFeĺJ9V—ř\dӇܐSĎ'UÓÓťßo{ýđz!‡ňĘpđٛIęœ[Ňţ_ŢĘ<óƧâ#ĺëĚÜŠšs7×nh÷Ëř.ĺqJX§mŰV÷_ř­ú|žŹQđđ8ĺ,“ËŸY#‡¸Ű{Gk_ž?âßĆ~lîzaÖ8~ţ_šœgâ2ŹxŇr}ÚD ůĽŸ&š¤Ÿ•#™čÉἌ‘Y˛%u‡ŤçcƒII¤íwî,bĺ%ŚŰá"2q’’tÖčB†Iă’qÓ(ơUi}9<ǡ$ĽŤTíߊMŰ<@zźŸƒĎ šc’1w˘[Ż§šŇyąfÉ/-yo#ş[oۡüŚÓ´ÚkŞégđ~'Â$źFĄkÓ9mžű}ŽoÂG;QœZRU]űő<ËÄĺňüšNR…R‹n—Â;BO|ŠĆ”xşď°|ř2x|š2ĆĽóiýIľ*ÔŇ|žĎăë68ř¸)ᏦqQŚÖ˙ěňä”!âdđ7ĄIčoščHÔ2ÜZôîľu+œœbĽęŇśTŒĘSŚŐ×⽞Ýΐó%ĽE'*Ő˛§_ôQĎMŠ+[oŃY§°Ćîu“ü{=ű|“?ˆË‘F9œš‚Ź~Ëąç[şn‘Ľo?T\ĄtŤ÷đXâÇ4–ľ í˛<řęݿϓŚŠ’Œ’{^ňŘŁŹ?‡gˎSĆńΕéŽHš?˘vyüš'Ă;b”1š(ĹëtŁ-TâÍJy' –iU]Iˇrňt=95)UéŁ.)5[ŽMú´¨šJ— öLí<~8ńźy¤ň5rR(žŔyéjzxéÁ|Ľý÷ ŢߎŰíő‡mŸ^DüśŢÍ?­.v•Uń{Y§ż"ˇŕ@X29(ŇśŻy*ű‘E$÷ˇů’Š”ˇ\ňƒQISmžvŕAë“P–™§()GŞapÍ-*-¸ˇ&ś}DňÜŽP‹q[÷Ľîa­Żň*Ő 'ԓ´×CqœšŤww`eú˘Ł);[GąÄőĆ{94÷şV¸îIřśđ/äâĽýîżš”ÜÔd°tř:Eš"Mî—ŇV‡@ 4ŚŇŽQ‚‚cŚýIľěÉťú0GňVYčsţäKGčnżŠW;=ž;ýH°ę„Ľ&ŁŃ´›ú 9¨šmŁ?‡Ç,’É)/S­1‹í}N:ŁF”•rŸQ)bÓQ†÷řŻüY„䢚WŐş*Ă=UŞÝ*Ţßů5,ÉĽŽ)-ęşüň%Ÿ#mĹéNę+…}€ĺĂߑבťvĘ:íÁx.-ŚŠŽPŞçbZŠ5i×T@w&čMI$˘•-믚 QP@:ڐ ´z’ž÷°¨AäœaŰt€Îýˆo$eŽr„•8śšěež-đoŕӌ”ô˝/‰tfófɕŻ2Z­s\™jRj š[´•˛ Öߑ)ťiqÉÚqŔź4)äyíš&’Š0˛OfId^ÔĽ ÍĘť>:ž !@€H¤ ×á łŠbrŠi7×/Żĺúě^>N>-dó#q„`Ťnşż6|żš^><Đ­P’’ž6>njńš3ăÁ㠔vŃ4ŐŠ>ź­ţ7ý@ů°Í?ŤËO˖ĘŰŤďĐçkŻcĐń9ŹJMśąęI>ťvř<ęÔ´MS[veŔŽ]pˆUw\|ŠÚ˙CHŽMŐśéRö*çš 2’ŮmÝđm¸¨¨Ă'âüWŻŠŐ%ťű•˝Mšnß,‰]îżŮ*ŃFŁ7ŠwŤű˘ŸäÉqRŒŁ}Űěj0óŠNRŽ.†\OŒgiŽU§_ŐsŐqvŰŢýMc~ ÁG¸ÉK^ş{­ăOž:xľĽĹĽn¨ťS\WÇ"I;ÓĐ=JÓÔş;ů0n+×ĹűrT$šqO˛ć%J4éW]ËŠŠ'ŠŻ­{nfýKp­¨%*ť§ž:đ#•ź‘“p¨´”\vk÷ÜׅɩěâŒe6ç7Š)W5ĹqŘbĂ áË9Ęm KLo­S}9üˆ.DĄxź´˛ĆOU-ťóoŕôx zŸyuE~>}żC¤Üd”¸ŢŞ‘"ĺŚJ/gĎEűŕůcŽSČńjqVăpĺ{ôŕBs•AÉÓ{.ęŠšGR‡™´Ý)>Z۲ŕ‘SŽICINR‹oËÚöž 0š<¸ąÂœľŠGz[űžź1ń_Ă˙ˆčđę3ÂŐEŠ/ß“SóV3JSUjëŻMžžć!&žĽ-2iŤ|ߡĺ÷^#&Iç–lÉy’žŠtO~Nš1y‹ËĎ_Š7­8uޗ>çťäÖÚjJöT•ŤŻĚ­MÇRU;É-žŹ šdǚY%’ň'zľ^ŻŠ1ByóyqĽ|şžďő:IÁÁ79­1ŇŠ'oË~ě˛ĐœŇŕĆJ:uKŤWžß k CÄb†HŻ)M:nľ'[ś×úžßâĹqxŻ °ŕĂľ8­›}˙CÁ৏‹Ă—&%’)ďş~čďáüäVKd)PĽn‘[>,ˇ¸(B ´(Ťř›˘Š*ÝŁ<uTâŰ|pťŽ3„c6šRá—vľ>Ľ uƒ”1šAÓľTŻ{úP–™KKq[;čG'I[ĽÂž–îČ*ßnžÜż6QƒÇłßä—Só´ĽÓŻú2šŒ•ĆčôÁC7â5KŚŰ„tŐ÷ł:Ż4”ˇQMŇšRăäÓđůaNxćĄ.lĘüFićžE'Ż%ޞˇČž˜ąă”ý*{ŻËý•Üc˝Ş?ž‡\ž&KĂŹ.ۊ¨Î)&—]×7ţÎ;W Ž=΋ĂäóŁă—Şš´˘Ú|}Ŕóˇ&­Ů“×–3”|źqj0^Ş•§ż<ŇäĺÁĽĽś­ˇÓŕń^ɎEś›žîLŕwՋѫU&IďŮňqšJMEÚîFÜŽ 4•o}Y„ÍăoZiŤOű¸˘N7[1“ ĄÎÓMľłáŸ[ř‡‡‹Ááĺ 1ÂńŚŚ řş[íąóŕÖ$öՎjœZýżŠ”œtNQ|§F@(ł˙ŽÎźń0}dęť}öɢZT´şn“ŽO^ rŒ\tźy!ssrĽĆËć˙Sˇ‡Ç“Ŕľ4˛źrňŰčí­‘ĎWŽ2ˑ)ˇ'ę˝Ű§_š˛ ┼7—äNj^ń˝ĎŰĹEC"…§(Ĺ)5߷ӏĄŔ˘‚(‚(!@…1äqtßŚŞşŠťË–˘ů›4ßşN‹âńMyy$˘Ł(Ňqę×)Ž‡ć#’á–-,qŇĽzžż'Ńţŕ°řĚËĘńŃyZŐĺÉ8śůižŰt-5Ĺ%Ľr}CP¸´ĽŞ[š/ş>żˆţâ0C.LŠ QkLuŠ$şěÖý“— ąiSÚRIé§Ăŕš´uńY?›ĚĽƒĂ,IŞPĆśCËM3Ź'ý)c“¨ţ%ňsŻmţB -oĄŇçanŞÝ]ŃŹŽ-zqůqm´Ţ˙K$$Ü\[ţÝ­vÜ+I))O\búE홉*Ťëů‘ľJ›ß”oÓ{|„uňüœoĚR†eR…ŢčäöÚ‰ń9|DŰÉ&řIjm$¸Hăú)ĽÚÎŘđĘp””&ŁźŇmE{˜Šƒ‹s›ŐjŁ\š§˘Q֔}.“ŮžŸä ¸ËŁŐ]¸_ť5RÓę”i-­Ý{QÉ5[¤uĹ’pÇœœŠ+Ťž <ţ.O7œ V™JŽÝÁ–4Ľ“ĂĂ"QkLŢÉ÷]ř9ĘJY0\T›Ľżú9ťŠŒŠ%ýˇşdĄ eÍâZĽĹ:Šżß_ƒ|ÜšrMB')iEż ąÍŠŰü4Ý6š,#W“Všogíąƒ”§Öń_Űi/oĄ¨EUF.SşŽ˜şóšŇYă“ĂăĆĄáśëՓ~˙ăߊŒYgůzeé—gíﲴ˘ąĺ–<ŠxÚM5$Ű[pöýŮÂôĘ:V™mUiţýÍĺ›ń>)ĎÄd“r{ÎktŻoČƧŞi㌤öŞßžŸ źŮă›ĂâÁ P‹ÄˇšuçűŕóF:ęz%*V-äxó(cNJÜU­ÝÉ× ż‡Đď†9ü|ƒ„ľËSqŒVöţ˙ŕY˛ř9?ţś ŨÓs’ŚÖ×ú}ɒy,0žXĎňP˝=5Ózł^'ŔäđrňüJ˜ŁŞQR[+ŕ8Ł…ĂLĐ˙ë8á)(Íß^ˇîßăńđxăćÇËÉrQSßŢ×űě1ËʔeŢM;8FQ’ćţÄXńyłx\œkLéÓÍš%ě™ä›PÝT›UuŇżäęńG9O;ŢZqK™-öö<ůźKʢź¸CNÉĆîťnĘ1šľ§éM'W÷9€íƒ$â§&ąÉz•_ÁÉ'&’MˇÂG§Č–8Í­Uę­ÔoÝËŻřö9Š¤ÓŠjťä‘œTÔĽŽ-]Ö˙`;Nы % ąť¸§IżíżĄ2MeÍ5éQŠƒŇŻ…ˇďŘŞď\ąFŚŠ7užÖq—Ĺ* ×Ňťń:_WemBr[7Ś“ƒď×ěĚ>U_ •VuĘÔam§‘m(¨/M{ő(ĺcťí\} ?Łáĺ‡Ęƒ”śs|Şě_1źšŚœŢšÝű%Ÿˇp0 Ń<˘Œ´ÍJ–Äœ˛QǢ”c-媞lvÇáÖlp”pĺ´ęm^š\ţG•xŠĆN[I¸éő­[Wš;$9ÖŽ_÷9ZyfŐS“ăƒ&Ţ=yźź˛Ű¨Ôw—ĐîüLRJrĹőŒç_˜Ąáĺ89j„{)J›3ĺ=˝QßÜ÷ˇidƒË“W´.]ižœ}ž yO °ĘŕľG#×}é>wř ńř\Z<\uB9kˆˇIž—ő=>3Âx¨a‰ń1Ű3ľ7‘;ýŁŐâ˙ˆă‡ƒ^ĂaXň4Ľ’xî1iǎďŸČófţ5<˜Ö)b†\WŠC*ľíTę€Ö<™3çY<,bçŽNŁ˘ő~[.v>żńL~äǚʗ™-*oŤIuŘü쿈ĺ׊đĆ)­í+}yÜň떝*OOaËĄä“Ćäá{9ső0@ P@€P@R(,dă%(śšáŁ łü;,żˆcńHa˕F1MGTö_^›žÚv™ŮÉJNQŠŠ|Gąpz%‡$0ÜŚŁĽ[łŒvwWôł3›M9[ľË §ĂOn;O?ńLŢ;Á,Ö7(5Ą¨zŸ˛ŁÁ–ŐQ”V7Öů_'4錚[žŸž^'Äe͗.ŠśŞI:­ö ó8+¨ýYt¨ÉĆÔť5ÇćŇkVĽŃ˘Ű¤­íĆükG–›Čš’â-r0+×)ˇ­6Óö;xœ¸3`ÄăéVFÝŠűüžuqiďĎ(+¤0­ÜçĽĹŤUlÓń)bY„¤œ•r×ÓcœÓ+wkśčë—=¸źQ†7ř˘÷o݁ÇËrÓľÚ[¤úšÉŠxňN9!(¸îâŐ3)CC“{ÚJ5Ęů"jˇ^Ž÷÷Ůü3Âăń>"ɞ8ŁŠË~›ľgOâžĂřląĹƒÄK:Œ:žm˙żšĺŊYŠ‘Éc‹ő4Ž—ÇŘçEEŚäë¤vľ×z éää”^UŽIŚĺ*k~żŽă6<´łe„b˛­Pá}Rúv0ćĺIäkBZS{˝˙՘ŇéÜ-%iv]˙B ËęyŮĘŠJ÷˙&˘˛ĺ”a NN_…(ާőůýrŽęWŠKvăťWÓ~Śńež)jŒPŃKNšˇ]ýŔĚTœ˝)šşQUnîť”îR–H]­’ziôd¸čóNJJ–­ţLビŠ§ę{Rž9ůŮ?âłăƒXĺáâ˘ĺZwŮýÁĎłřloÄc›RƒM˝¤˘ßîyŕšźmŇş’śŹÖL^_÷FIďp|˙Żůži? řźšuIÉĹF÷âďâÉáóOĂĘQǏKŮę‚m%÷}ĚĘĽŚRt­pŸ ř|]~řƤ’âQś’ῼíűěEKKPUrQáü“Ä䇇ń^6¸nDšiWń™ňżţź´(ăôÔ+zžŤžYä^HXÉĆJQm5şk 2Ţ8,“QsŒ/Ź¸0ÔҌœSNZá™ÓS’rW÷WVs=zU):N×ďě\Á×ibǓ**m^ŸosĆŁMJâúŐ J:bŁmÖ÷ŃßB6ĺłt—FĘ ę[˝—ŰĄU'ˇćBĄĐąu˝ŽĹj*+ńk˝Ó\nŘë†ýţEI´ßnEoCĄźy˝–Ľ^Ž„†e Bj)Ę+ű’ióĐĺ`W&âŁŃpU:§˝őř2•‹öD`„—˙˘ƒżîMŻÉËŕă p”|N,’—1Š~Ÿ›CW>˜ŘťkVét[+”ź>hŤxäŐ]­Ő|Ł‘ęRkV–Ö¤Óř8Ź3”Ş)>źŃ70Všĺ4B FŸáVm`¸jsŠwř]ŮŰÎsÁŠRPU˛ŤŢ÷îdÖb8ΛMtkŠƒÓŐZNť˘8FMśŞ÷Ů‚AçO+nw$ą¸¤í;躏¸ľĘ{űçŕócŠy‹jôˇş^ë§ÔƒÎ˙Ë˝6ä“uIí~ç?.{z^üŻ …řuŠÓutşłÝŞ^Ä9ř|šŠÓŠĹ4×M™Żáą^^yh–WÂ÷K†ţkdc&WY"°B s´ŢňKˇć†4¤Ü›nŰ|Š*ŠxÜľ$Ó­=~Iľ{›CĄ§ľWєXd”:F^ŇVzX˙%’>F;›OZmĘ?™ĺ7 ¨Ĺ§íŚŸbn“üi˝Ÿ7˝™ˇv÷~ćąĹĘt—;R%zd´śÖ÷욨ĆZŽôôóţÄ2SwÚ¸=ąź¸d–|qQ[Fm&ďˇŘă—°IFJ¤žÍu]ČŻG†đ9|F<™#(Â8V§)şˇŘňÉ=œśŰšäÓÍ)~'ŤŤOŠ4ĘiVöęďő:Ćq^Xä­ˇq˙Őő9í][üŠ…şŽœ5]QÓĺď~äŒ%;Óé[ĽÂ  S–÷^ȢÝUý袾/.MÚŢ×Ɏn‹‹q’áĹÓqşw|Ůqśę.Uéű{‘Y”Eqüm1’ŔŁ‹2â—ő’zşĹž+ĺăńşšÉ(/Dިü=ÎÖţ%á#N˛bšđąŽŠ'źľĎę|iR§nˇUŔ|Ţ& zuĘý Ű_4qŇői§Şę€€ë›BÓE'ę•ŢŚb1ÔčLœ6JꝻÜÄcĄďżÁMf^^ű€T !Vî€­Ű ťmđ  Ü Č:vśR8ĆYœRŽ×ľ” ĺiEmÂě@ *n œąęrÓIö˛JZşý J3NŠwž$§5ŇŐ˛oŁ(ɦԛt—ÇppœĄ*¸ś4×ÜČ5ĺ9šĹvŰčĂmň쀣Ij•E6ߍ4Ú|˘ŔĹ8Ç4g’/$TŽQşŐő$qšŠ8¸úUťu˙făŸË§#%ýŐoó؃răÓ芋˝×?9ç™C­˘ž”ëoƒŻńIăńWˆÇĄ7é”c˛´š[.~šŻT"ĺşn•˝—ti`šĂ˛Ú˝>ý—‘dĂŻŃĘn÷*Ÿ§Bn“rVŇ(ĆÔű#:‹ľŞĂľűßq%ŽŠ>ňŤˇŰĄˆšép¤ů]ʍ9BXŞNO"áôŽÇ7Vë€ďśětţœ\Ą%­^Ӌ 9MNjVBˇ'vŇŮ>Ŕ@A+tŚźŠ'ÎÚvF[s{˘›÷4ąš4’]=€×ĽşČÝ×)[{lM—Oóűę´Ii{§ŘËô´ÚÝďDV˝Rt÷kĽ_íÉŠE§%[íˇS:UŞo‚ĹĘîľmרƒjWŽQ}cr{^ĚĺŚ[ܸŚzź(gϢy|œm;›ámˇćrÍFz!'(ĽZťűyďžZÇY֛qôßu˝Z-LF–˙B BŃ(iž}@Üř˝č˘Ń  AR:YŹmĆjI'§zjѐç)dœ˛?ÄÝşT„TŚšŒ[QNM.‹š›ôĽož §%z[VŠ×TA.ÝťvÚi§Mnš:šk•Î/uÓmëc—?š¤ÓĽĂžl wÄRř;dĎŞ1ɎÓ NŚÝő9IdŽ8ڒ„›jÖĚçđ´ŇŐŇč9żí¨íNşš”Ç{śÖšéŢúőűĹŇN)mË.ÖÇxź^JIÉeŐóíŢÎ*QŤťŕ˛•­Ł]včĺ,q›Íżńi§ů%ÉÓ"QŒiď%şŽ78śPÝ°Ő=ëčČHI'ožćÝ4p4¤ŃsE’ŇŐ3´2Ç,ŰńRmRiŐmąÎ“Žç>§ŽQČá̖Ի˜]Žđ„'‰KĚK%Ő5ůŮĆQp•5@j É쭖^§}L.M]=ŠŠűłXĄ)劂‹}ĽGGá˙ú‹?™ rÓŚý_c…=Š+z¤äëwŘé‘âj}5+wr˙\pxMqȧšfĄŽšŢjşv8Ç"„+LdŸ1hŠéĆ-éăÇ'TőĆ׳^˙đx[mŰäú^#7ËŽNX[(Îíűßďcć™ű“ţ%âłř<ÙŻ+„âšM=ˇIo\~gĂ=_Ăüdźˆó#zdœf–ͧî§Â(KĹĘ\pć¸8´úţ´čůůqËY⚩ÂN-{ŁÝü*0ÍüK›=ÔľÍÝlˇ˙›ĆfYź~|Đv§’R‹öl5)JRr“śČíúŸŔşŸMś­ˆë–ă™MšÇ‡-ĚĎ$ňd–IIšÍˇ'ÝžLÇŢ⠎)§'_JŰd o1Eú¤–.ŸMö܀0’ęČXNś§ňAË°@*ŽŠýČo[—â“`$’ŚşŽ.Ě2ş4B€4BÜO’8źF<’MĆ.Ú]Œ(ˇÓ[sl(ś­-ť×Ä`xtIIOŐÂiU÷úžv“Ůđzpx…KX<˜eťÓOş÷3,r„qjOMÉ7tţ~(ƒĹ“i¸ŠjIŇkŠ¨KW<“"áĽňa:vgÍWríU[÷3]4÷/2ÝóÔŇ-]űŒŁĺÎă'&•>Űő9m{š^ÝŔŻ~Şý‘ZVÓÝѨhŐę“KŽţ3.,Ú^>R‚Ň×Wż/Ü;œœôÇt‹ýŠ˝÷ŞłP6żüں׳žÇ<ţxa ڜ$ŻT]¤ű?sImťŽŢçżĚŔü>|O.,ę—Nö˛jžD',nâ鞈ç†VŢ}ĽÎ¨Ž~„—‡rÓÄF2XÔŠmi_K<äś”­ęI.[ř,d㲤ßP7úsŹ’p]U[űßâá ř^\qA,ššVýˇßƒç]¤ť›NšIwŻŸß đÍdœňIĘrr“ÝśěĘsËäĎ9Éc–ň…ěŇďÜáĺIÁM/M×íEşŤŰą7OáqĎ>Ÿ‘â„w{sí˙'˛SɓÂe™‹NőĽľđ’vxriô¸ĘößÓTfö˘E[ÉćK˘–Ďň8eËćMľˇ´W@:řŒŘĽĂüM˝ĺٗŔx9xĚŇ\cÇ“$ťEcßá1ä˙âüVl/xĘ1É[T_ü|g—ˆđžWňđÊ2ôF¤Ÿ[|ˇÁóä٨ö]˜ľUşŕI§&ҥ؀ ŠEBIÂäřwÁÓ†yńĺšÉŽ/˝2’N_ÉŔHt†YcRJš’Śš˛J+Ľşč(lŐ˛¨´˛Eˇo{煹Áܜň\b˘é*‘BößčΚ=PŽˆ:„=OŸŻÇüÜ2đęŒÜíeöěee–)Šăr§˝'KáÓc,ő4ÜRJ)=;_šĎgkOĂ=r–%-Ë˚w7|łŸňŇɃΊ¨Śă˛m'\?v(ăšY'†1•hĆÝ*ážCÎ{ ´FpW4×1t—ż–QŇűŽä놝Ęô*Ôű 3ĺNŻKŞ°ŕŐ{îwžl™aĘrn*’}š¤rsN­%K§P1˙‘Ď~Œśö>˘ŸbÇäę0“}’  W$5ă$×(Ł­RŘŚbí6ˆ€€(  €@(Á@€,PR(„)ĄqšŠ{á°Ç“ĆÂrÇZ~šp:8äčs1Şú’đRm8ćĂ%ĽÍ靸ĽÜó%Véé\ÓäçŠěý/ňgyaՁeŒ­ŰN=bhr§§Umud7<~ZÉ6ŐŇčf:T˝Iľěč¨-‹)94ÝlŤd$ăIE;ęŰ!@ 8ŕX0ĺD4ÔĽ˛KŕäVC*ŁG&ÖŚĽ'˝u<ĺŕTšşRMG‡\îo?3>ˆ,’zm¸ŻĂžďâ3Í9rŐ÷ŁxSš]$Űk’NRœÜ§´¤Űm™ö¤ţ CqŐjŽŞ÷a9Ö¨śŠĽiýżBŒśďn}Š˝=Žďq})?žC—k…íČx˛FĽ,n*KRu[wDŽ9Nza'{Vĺœ$Ł śœdśva>ŕunX}+iî¤ŐŻj3 2rŰmˇĺßú1a´š ën+TbŇTžšŻą„ˇvôíË55-ĽÓżŠœŇŠ”Ł*˝”šŻpŞłĘ.RR–ŠrěçŤÜÁ FŰž§IežLpŒĽj˜ŽËŸňÎN˜ŁQMAşŮíf6čt[Ánšŕ¨’qŇŞ4úďɓR{Śˇ]62îěÚ¸ 7Ád’“K„ŔJă§Kkn{ło,ŁVŰiR˝éeËť5čjMI$¸ď#”¤ĺVŰ­•ˆŚř\z1âMFsžŒwZ’áŃÍN1]äžŰp~LgkšŤßěpĐźT㤓sI7%m$gÄřœŢ+/›žns¤­űAÜ&ŕÝ7MSWVŒŢI;mŰ|ś`:cȢš”m5ŃÓ9€=É(Ć5ĄtßwÜžeGd×Ë˙'žÎ‹*t§JUéI?ů(ÚRQri¸Ë­^çÔËüAËŔOĂ/.Ë%- öQő]ő>L#)RƒÔŰÚ+ŸąŠ¨ĆJÔ­m$ú2Viř‘żŠX’[Ĺ$é%ťýŮÇ&œşŇO$§+ŒÚŚžˆĺŞâ­î¸fŚł`çe8§ˇ =˙ŃG ÂPŤëĂB1”Ž“uťŁŃ‹ÄäÂÔáĽK‹qOő7ƒĹĎIOLg)mrWJťy|ˇ˝´¨ŤhR{6mÉ=ÜimÇĺK•8=2{ół˛$Ó}(™*×;îö 0 ÔĽŠŢ”ś­Œ€Ö)ĘÔ}=ŢÖIFPu$Ó÷,2J VőÂjŃźž&ybŁ(Á%˛Ó˙ż¨KL…¤SpomśÝîuĂ9c“늧˙SÍernˇă‚Žů<6EMĹGR´ľ+Há(éuiüt'$ ôĂŔxŹŠ'-jăK”c'…Ď‹/•“Hä˙ĹĹ٨xďAFqZEč‹këFrřœž#2Éâg,Ż­ž„šqm5Mt!_;lo$žJ›’oŽĎbŽ`Ôâá7V:vd+Mr@(!@¨¨ŁŚ7ľ&6Ô]u)ŹE   @ 5\4ţR"” E@R) HV×K œmmÉČîc$vł;Šć{ü.EŻMśý3ňž{p–—ÝuFGŽXç†JTŇśŕÚŤýěrŽ§Śy3ůĺ’Nx$›Š“şßuú—ĺ/IJ_ľÁ KMŢ÷Á¤@B€!@iÁŹJzZMŐôgäwJ‰FĽ5‹vĂwÉ î¨ Ż“ <\‰‡™‹tău{:üĎ)VĚdąż^\rŒV­**T×ĐÄĽsˇőˇ$’ŠVÉ÷^§­7+ßzošĄ8JăaEioU{!řĽ*ŽţŚuÁ œ–lŻ­šŽĽ`sqŒq6ߍVĘşnsJŢURÝ7ő3-:RVßv7ťŻwš4Úşár%CyŚ—c˛FrZ"ă’§+%TÉ=I%Tş÷0˘čéď_C‰Ön\…nŢߙ§˘ŚŐ)qîcuđʎ’Ä´A㓔äÝÁ-юoĽpô˝öŘłŢTŻe[…d†“QiŞmthÜŇRmU7ľr3%LčăWŢčËVˆŽgl|- ŐÍňr”Ą%(śšáŚAŇMĆ5t˙3‘HPtßŔˆtčÎ` @MŚštѧ–rmĘNMťmť0ëŞ2çgůMÉ[’uˇ'QŢYbńÂ+Űo—űŁPÍŚüˇ(ÜZi?ݞp;DŚÔŐťržo“é˜äĄŠ5$îNů4ąăň'’Y4Í:Ž:˝]÷čQǐńĎJ›[6Ň}-Ů]*ĽíĎ&“”ĄĄIŐڍňřž‡J×;ݙŚtjJöčdA€mđ`€R:çx…†3T˝NRťąČëă–ŽygŃľ-÷ßĄČ  ß @*˘1ynÔŰOjŽ>Ľ[E2‡şnžÝi€XK(A (BAA `  %€P)€7—O‘ÂkLŠ6žU˙“ԞKRwˇĽˇÁŚş˝¸ö‘ŤMw%•7żć&ż"&Ó´uqLç(é3¸ŽŘňKɖ;ôśŸ¸ŞI™ŔÓR7*ľžČړpQrô§i_~_䋀 `¨Ô ç$–ň|.ŹÍ‹IîëÜIJFý żv(ŮĘsnNžÄro–dÎę€F-qŠËŇOK•lĺ”žFň~+ˇ%ÔáŽmEÂޙr˝ÎŠMҔš];"ŕŞŃ[´ŇâřnÓqIťKd]ťŚş"ˆ›{-Óc&X¨¨Ĺ+]{ˆĹyšu$żňÜóžIŁŚlď2‚p„tŞôŽ}ŮČŐKj˝Ž@ŁŹ˛JQQrn+„ŢČ'éŞŕćj mKŐo“Rr¸ęéĆűw3ráľÔôG”e)ÉĽŽ“|ďÚž˙`8E6Ÿ ÜäŚŰŚ„ĽFIEˇ{I˙Ł›j¸(=śŰ“,ŢşMR§ěbŔRm)lŻ•É‡ł7VfDѐëđ˝ŽýŽGo(ŠT’ßmßN bM­ŒŸ†8<^LxçćA?LťŽçŚ€€M¨ľK~č €¤u:Ťu؅şńRxÜ%É:ŚÖëęaJŠ5ő9ô ŤSŤëÔÉÓHO_œœŚ×Ľűű˜NţJ3-‘ƒs|MŚšm5ŐD´űÖ8ęŰIŇşäÄŠ˝˘Q~Œ•Ž1I5-žŸj8ɧÄkwÔ € &ÔRü[4XĆ.nj2\FŸ¨ËÝ읨ňdŤ:śżľ:÷%‘>Žčśi‚ČnšV×< #m¤›t¸öě d˛]”˘Ř–™&’ľÝY, [ZjˇžlČA.mĽˇS7÷+vŔ­Żjnš3cŠôY¸9ËE¨ŢĘ\Ń9{´ŒTŠťęš˜˛ZWhXÁ,–›Ź"Wú‚čK3`o´ZwŤş3`ŮěČ݂ "tjŃžBQÓ$ŰŘíćJŠJÝsËg'ź_˛9ń]§=2qęš0ćߊB•Ež„Ľ.ŹČW&ůdz7ĆԓüKĽ>O9ÓŠiˇ}rQŃs_ĄŰ.ŽIj„őEIhwÉĆ2zIsÍLŁ NTŰÚú”ouiĹj|śyóÂ8łäÇŠĆ2iIpýÎşbąJMŐ*Iugîí“D,UÉ&ŇWËčňBV̅\ŰÜ$œ[OŘ÷ĂĆË.ř aĹĽˇ+Pő9+Ž>ÇÎ[´brs›“ĺť.Ž­ĘÝŻŁFLÇ$˘ů´ůO¨÷@PT­7hV×ô(/b?ÂĂĽ׹0ŠÓćˆP597+e˛iěţýŒÝżrŐr{:!ĽđGČń¸,‘yTœ/Ô˘éљ4äÚT›Ův @… Ѐ:ă\’…ˇţ9ShƒŃâ<|PˍĆo„úöŽç˜č§ŠSĺpěN VŔs”[glĂPiľ•ţ(%˛UÍűçœvŘF7đ§ŋżNIN‹ŒŁj-í÷ęeż2Xő6ŁJ7đo#Ǣ*é´ÜełýîrO—WĹqJ>d2dIᄒŃ{´_°ůĎ'†U†{Ĺ>cěýĎ7~#4şR›Ľ.>ż‘ÉÉáÉ[6ľ-.š[~§''$­ń°ôz˛x/ ĂŚüKyԚœ#UÝI`zڃRí+­ťšm'IÚWşęWĺŢÉĽkžDCđîq’RšhŠŢŻ‰rF*RJM=“•×ÎÇŚsǍ)áze(ԒÝ.üœgY&ç“#s–íóůß \ĐNjb›ó\/%OŽUqŘň>L5D‚  ]ŁKÜć[-9ęNJĽ)Am´vŮ RTéÚŮŽ#` ŐˇˇP(Op!ŻŒ•§­5` IÇD\ž×$řOŰéFSĽKŞßcY?O—)=˝V¸~ŔgKUj“á°–őkäoĂč=ŔMuV˝™/n7˝ř%@Uąd[*flVÁ CqŠ”]7ŽŇQKŸŢÁęhĎęTÚ`Sű="”gË]Ę ‘J R@şV<•f Ýť!P@*m4ÓŚˆő)<5%§MóCÄăŞ*[ÚÚţ~ç(',{nî–éw:MéƤ”iWŸÝ'’1SŽˆśí/cĚnîVś-î•őŘ !VíŃú!ËR⍥Čě”4ËV­]+cœ˙UUľ 4uŽçLrX˛)Ę0Ȓ˝2şgíÉŻ‚N~­ˇú䀀PBˇjş śgFă(ĽŚ›|śr5mŚŞŔÜęjRţIUœĘŁ9ŠI&ŇÝşŕ˛[-ď`0@€ ľIňِXdJímůœÁÜ^ÔtRKUęžN+“˘VQn㌡5Š3’ôđöů}ŽšąŕŽ,>^I9ÉzÓ[Eœ#{ŐéNęů´% ĆXäłÝ)_+÷ÉÉŠ$é>-ˇŘłRÇ:’jiŰÜĂmŞˇ] moŔUjŃ PôšuQżšFú/šéŽU;I=šő+FĽšoÂĺxâí&öOŤ9pČAd´şŰčČ5ÔÉÖ2j[ośč̢šO`2 Ă•Öô­ü€Ŕ+D ŠŃ´×C˜tR[w) ) žB.Ôť­ńtGŰ` *„´ĘötŸ*ËK$”bŽO„•ś‘ĐŐEOLĽI:şßěedŠť‹{m˝ Ć7ËISvú‘­J×cRń1ň!aPš˝SťŐô9)'ɤ•[dF–—*şˆzirŤ—ܨžýŘlAÜ€ @)@ź.¨¨ÉĽ°EQ@ĆG˝n•œY5BdTÚಓ“ÜČŚK&M1Ž§MײĘömÝŽäÁ–XrŠÂN/ukłT˙&VÔvŐkŘŁŠŒšNђ˝Č@/R:㕴'îŽË™Ë&8I§QZoî˙ŮĘ5ŠjşëGw/čăp˝¤ö{ŤŘ8:¸ůŽRş|×s€㠋“i$ŇŽŹiÖŇUmÖě ľB1ruŰě€.QšÇ˓Œ–ë”™#=)ém7śÝŒśŰmťo–E'K°qj)ľJ\{™‹\=˝É/Ä÷˛Œ€­ˆ€-íDT›áYRW'X­RQ]NK“׆X|œŇÉ)G&” ˘ś}ě˘äƖOézÔRßŢŻ…Ĺƒ§ˆÇ‡ÂÂŖY2J-äڔzQćJQÇ­l›ÓhĚfă E6ľs]Dň@ݐ˘†Č*V…1rŮ&ţĘ@׼˘ăēů\˜jŠ9Ӊ Ľ# Úî—C´kS7“4˛KSQN’ôŞčr#5M5öîYĆZ ÜţŽŽ`SŚ@[+”_?“8‚ŃĐ{t$2Ů-ˆP!H@+Msň@IˇI[ (€‹E˘"ľÔ"0P*Ŕ˘ČŘ( †e.ˆ 9[Ž†0  D)2qvt t™tjMÁ;JÚçnŹĹŃÓIc’œ$ă%Őr=8ç,Řąŕ“ŒcęZV×ݙËs•âŒ Š*níő9E¸şčAšĹÂN-Ś×gh̡ŠŮmśČôřŸ /ĺË$Ą/2:˝RŻgďţĎ<Ľý-4šťęQĚ@´Ŕ‡Śńbró¤Üâ˝1ŽëW˝ôř8%\” Ťj­‚MđŻŕÉĽZ]”fOؗľ@ [ uiRi%\žĺ¨×ÓśôŰ4 á9-Ľj?쓌ĺ7ťş­÷3m¤ş.706¸bČT›M¤öÝűv1$h­Z(ä Ń €)Ť“dÇMú’Ľ{őÁA Ę €\ď°¤ e!šcptÚşOmŔĘ5vOđ:´ˇ(ŤA-ŽŠ™QHDnŒ7dŁRŸţ6`*Ą:!o`4"úMŚšt× tŒ–8źy¨˝Ö™pößßn…† çż&/$’šF+„IJ1rÓmIoeđţ'/†Ÿ™‚nîż@<ďfCS–§m$ß4d€TŹ†âś{ňçĄN˝-Őű–㌍~öN”Ř ˇa{@]‹éŽ]rt“oŘ=2Ý-š2¨´´Ÿł&ÄR(1AJےI+§ÔÓÚšŚëuš˜¨éĺëž+j;äňޘŕs•Ő)-îˇüě˘xšäytewĺĹB;U%ĆĆkŔąU%žĘ­˜œœ¤Ű١m%KědVŽ€@:I&×;ôŤ{ti5{>H!Šr„§JQM&ŇşžfľIÇK“ҡŤŘâž>Ś\MX˜;<2–'—Ңo%wńÉĎK ČŮ1ůTŠú˘Ľm~† ˛ÉĘc”ăTßNƲË^YÉAAIś˘ş-ş  ¤()#[šGxşé÷Ppö"vʋTŹ˘6Ő×RĹŤvś}‘ #Ś\3Ă-cŚUuf n‚ł-•ł›v7TnȐMíĄnŻˇcr‹[|Ô[Ţ+űś(Ă2uœ$á5R‹ŚŒľé۔ ÂN7MŤTf]lB ƒj XuĹ;_‹˛Fkbˆ öŤŻ ĽtžŔN_šŹËKĐăŚQÚ[ő$ŠZ_s˜MqNČš4h5F¤šKÜÉ@)ŚçÁĽ-ĽÖ-SF`VˆŃŽL˛‚VB˘¤Ai˘i`@Všm>›)P @HP¨­Ó•×ętÖԜńú)VĎčţáTám¤â’HćĘ#Ü@°íĽěő^Îö–G(Â/MAR¤“çŻs €Ýň-€TšŢżÉ°iŞ“N›ö6é'ŃU;úIŞŮÝ^ćUŢŔWÇT ě™V—ęiŚŠwîNMĹ_‡{˘=’Nëš#nîŔÔ|:ž™#8§ ô>eîŽjˇźśîÍK t˙ {Ľ];ˆ<ŕۃ\n`€ †˘ű°8UnŸ!fá’x˛,˜Ű„— (  :!@ŇĺZ)ä4Œ–Ę)Ž "şŢ›7`2'M+tů9•ś÷nČe@ {U}@€4ŸsŹgž4äÝ˝×cSњqmÇ kzŠôglouʕ_šÎOr‰t@4›Ş.Žíě` [6Ľ[ŽœFŰI4ˇ÷0NäMlĚĹ)I&ÔSuoĄgJŇâö¸ž†ZŚ ˘W] Ú\oô2ś@Ň}Ç&JQjŠMM•4č‚ě(˘V×d 6Fś -€­ q’Jš78¸8ť[¤Ő;8q-iÂŇ{´ß_bŒż}ĆÜń_™]ž[ł IˇKv*žŕB€´@­Wá_$.í%}x Ň{;` ‹TŸŰ’Ż‚ Öý@MŐ^žʝ(Ş+záw7WŐýśFľJĺ[îé;Ů&Č5ŽOE“ŠAęMžy§´űž˜Š-›ÓŤŠęgÇEĂĸź‹#QŠ´îś[}8&0¤)€ Ân ŐnšÝYoj9›NŃpR …€TR€`r Ü m\ndŻp‰Vk7—$a›nŠş0Ź€ojŘžŸ ?ćcŠÇŤ~§OsĘ^őgÁ‰ä”đÇ$p)éˇęÓŰs‡‘‘şŒ¸ü;ňHÍÄŞq§qśýŔGIoĽĽuoe}ŹË„—N°ÉEŠ);ţŢÉTąíłtż {7ţ€áOm™_ˆšÍžRRÓ˛Ś’tšü< î×ul ÓB‚ @Z @ Ťƒ%° *e%l -– ˝z’§Z{ô2P'ąmuC‚6˜•^Ćx4÷äËŘ ¨Ůĺ{ €(HGYi“N;'Ńł=KŞăíhŤgË_ŚBMĹşuľlľłßp U[ő­Č /SÝďĹ°2 ;ě@(čCWłŮvࢇPŞÜ TéěV”]&Ľk”f‹ľ%ş|°‹“Š:[î]Ň\ś‘šëôîtPKňj^•ĂëdVŞK ÎéFęťü}$¤ĺ'&íˇlł››ˇôFHU%ä¨č§zşżc‘¨óE …€R… WIÚî4ę [YĽş÷#Ü,ƒűŠ@aňCoƒ@ ăÉ,Ya’/Őš˝ř0ߙ/Uśőnď{3ŠŐt Ű{YwHÉl‚:wśÝŔľÜ9qíÁl€[˛@Ţűld [@ŃAť ŠRRš$Ňľ}H÷2[e ű‚ @JúH ŠX¤R*Hőx•áח<”őE9Š$´ËŞ<–tĂźœ[I5×آʼ+zďéG3Ľ8ş{i?bŒƒiEş“ÚšŁ-Q B˘+v¸ LźősČ--%ëĐÉY(B@+vÇ@Öď~ ".Ŕ0†Éú—Ż°QśŇśűw-ľ]:Ł4i:W~Ä<šÉ)%{6Ňů<ӖŠ_C´|V\PÉ rĽ’)KmÚíěyČŁӒárȡgN6(€ €Ź„QNKLco›ëąśvi§MS]nsy´ŻŤîd­öÜŁ.ܡœ\dԕ4é˘PD|:>dŃQ ˇ| §EKq"Œ€Q@78Jqukł˛E(Íl4š˘5]S6Ě4ÓiňA+fšŘ‘äŃG0VB &śß؀ J2;)kVŰľąwF”űšŁEć•ţB“KrÎ*3iII.đ“rő;|‡éëľłŞ˝Â°U]H ž,Š_Éśś¤­ş>Iśĺ–yg“#œäĺ'ËaíKRjşUIîŹ*ö˝éňíV˙cŚ,r˒8áNRt•ěŮÓ áá|Jy1Ç"ŽŇŒ–×˙dWlř Üç)ÍĘN›ŢŒeş^݂N[/wD˝×o`ޝ´¤Ú_ \ŞžŰrEÖö ďWąréÖô6׺ŁçV’iíĐÁ¤(‚ˇ}í˝˛cü,3H€´(( @Őr‚ŽHKôÎK†Š™+noSvŰ%°Q|_ Čk~ń´ÉKmˇŚ­[ş!@]rŹćjLÉ4*VA %f’§e,Œž 3,hȀ (FŇH‰Q˘ŕUŁ:M‡{{•!òÝń@3#,čG$W0V˜˘ M&b#FŁĽ”]j­—>ÄŐ`@HQľ=÷kN×kŕ €i§w}€ ĆN.Ó:ĆiƖí­íBtě´vkKiÖݝ&äíňÁ¤TŁ ĹÉ)ǚO“JޔŇ÷5šUoiô؂EÓ§Ă÷7ž0ŽY,rŐŮŽ¨ćůT @ŠŞŐńփJÝpź=ˆWwĄPŰąi_+‚Đ Öš÷5W˛śŢÉQ›ő^ĺŐV¤Űkg|?ňžâŻÍŤnŇş|ôú™Ű} Űm*ö3ÔéŚN-ĹZ‹ˇ]Ą)^ԒŐomˆŹÖ×kŕŇ[]­žƒg-— †ýˆíBJ—mŔç*Ôëƒ PBÓáe9ĹÓ:šÄDWşŚBÚ(€SčŚBě˛*’wô'&“qwÓö ĽÂ{{˛ÉĚVô˘švłăX˛8ĆqÉş× Š™CŤÚř „-nˆ+teśČăÁƒQ. €XéżRmSáő*2ĚJÓÜÓ0MP@b­¤tŻbB=YŁX!@* ( ”Gs@ Ŕ) MEĆÝ5şžAćÓ))7mĹ]Şîs2 Hş"Üc rużä n’ˇK„ @w¸Ö˧Éފ éR´Ý'Ü4ă'ĘٛD­ˆQĹ=Ÿ°L­SiôMśÓJˇ!•QEä/-q\šš‚—˘NQĽťTîˇüĚőş,˘âÚŰnˇČÝ%“NýĚŐ:“:ÔtŚäˇŮÓŚżÁPYQ{˙ěŐWËTԓÓOžŢâW$ĺ'oŁnŸŘésĆÖťMWÇ`8Ę6ůKmípÉŽľĎďŘíMÜć¤őGSm~g8ş[쪭>=öŚ/Ď1€7ľv0Té—^„ŰŠ¤­ZÝšD@5LSŤ ¨…nßú şiś—4A[RŒR‚M-Úor&—Ků%YZ¤ŸFŢŻz#moNŤcĚ=™5P@7ą•É˛ŕ¤ob‘•‘’žHe@oÖ5‘Ũ>ƒNrxÔô§ipĘËd†¸§n7VfM97JöD6Ą¸JŮt3˘I j ¨"¤‘lUmd(¤  Z§VžHP 4AtŰĽH’Ž+Ž(ŚŚśŒ•ÓUťę‚¸´Ó§É ärœœ¤ížYƒ  ŐˇŃđœj*VŠűîd kuäŒ{şćŒ–< ;;âČTëzNťÚîŠnŢÉ [QĹwŰâˇUÖÉŁ-ÔTS{ŻRčEWżÄé`Š…ŽŰ„›{njxçŠn#(IršÜŸŚ›{p˙$7 Ő>/ěăń'ˇNƤą¨;ÉŞWś˜óőéö9ˇN“ö´Fî€ęĽTm÷oĄ-6˘śŠvˇă˝ŠF1¤˝|.L§ęJnUÔ­áŕźdcᣓŤš”ĽĽŻý^Ǒă^ĘJsƒőd’ôGzľß÷ąäY^7xé>’­×Á‰ÎS“”äĺ'ËnŰ ď,yôŠľ%'Š˝ţOG‹ţ/?ĄKĂxhF(ÁŻň|ŕňäyr9É$Ýl•#@v‹¸%Ř30v¨Ń´$ܝśŰîČUÚşŘӒnöv%J+Vďľ~ěŽ5ťÝž‹“¤›od—sĽV&Ţ?mMťžF8Éލę›ö3-Óß~Şö"°Ő=ö!źˇć;műžLţů*!‰riÉ{˛j €GHťEÁLśi˜“.Œ€ € QÔÄ6‘łX[X!Q é=€@ rQqˇOz%qqtŐ0 ( @0A8ÜÜqqŰSęú"l šö&HVŠAIăNľQĽŚÝÖēśú'Ń\ˇ I§}롂(j‰7Ž­Úظ7[]Ż€WZž›Ž—Řœş4—´Ÿů4U–QÄńĆM)ţ?z๮l3RF.Óž‰đd[÷EK~…M(žžärrw-ţy *ŚîŸDtɟ.iŠĺÉ)ˋ“ł9t'XܜöIN4ÓoاÝěo6IäËy´’ű/`ôĽÓÓnű™ÓI6×P4’­ßUÁ–ÝS—ááMîśßŤdrĽIS­ŔÖ,ŻXäÇ7ŧú2gÉ)Śç59ÎZ¤úŮ? ŮoVŸcy˛,ž.SźŠoÓ§Ľ-ěƒĚ‚ ă捴rNnŃŹˇҊoň,U§ÇNHÓ§eMtî{˙†áóóbŽIă„!m7RioÇUÉâĆڜ\)KU§fłyŘłËĚr†[z— w&ŤŮâ!á§ăó8IO <‘Ńqř[łçʕVÉďîœ]§˝Q\6„“Ť§4łNR“s’“’ťť<ů\\ý ¨önͺ޿S”š+m5g3˘ŕ¸(oĐŇĐBW{t … @€P¤*PTQ`B‚ÂVš ď÷QÇ,ŽP‚šs_ßŕ—…~.üNiG?V—w˝=žŒńĺÇ,9gŽiŠEÓLĘ°€!řxG3śÚ"”RÚŻšp:1ĐŇ+´¸ÚęČÝô[*ŰbŻeÉrŞOZůę&ŁÝ´žPjř\ô#âţ€ţÔD­ň—ÉRčťu-˙múSuśŕKW˛Hąm>ƒzNž•ľ¤ŠěÚ˝ŸŔ m*[|u5崞ęÖÚ[ÜʓIŃčÇâ|Ÿ›ĹžD’–Śœzß×b<4Š\Óq\ŤŤ19š˝éWcY2)BJŞŰ÷ş9 @7 éړOżC(ęZŰĄ˜ÍÖÍńO~A¤U]Dśé/‚*o‹çn šŇÓOWF™žJÖőľüXEJ2zâšá>Ľiˇ7)[N›ťśgśä|rœÝqĎ[ˇ]„ÝĽŚ”kĽňa/sś “Âő­ńŧ(˝ÓěšdVVŒi<ŞRn7§TúYć:gË,ů§–uŞnÝps ŚŕŐV÷ĐÁcłE-ĽDmš÷­×”bĽŃđdH¤@¤ŕR ›R1ađw­ˆ^V܅Ď+mÂŁw'vɒZŚÝˇÓrĹďťi{̀uRîr>Œ|:ĚňÇ#áĆÜĽ9u]‹Gő77ĆM/UťśJś–űšÎńK%ŕN1Ű'uő*90—7ÚʒrŚŇ÷e§ŚéÓu}ď’jpƞ(ĹĹUŚý_™Ĺ:Ś’řÜl•+śš{M˝ŰęŐ٨Źju–ÜxN5g)*¨­Îđ–ËúД˘ÓT>9˙' -/ńj…s­MG]&›Ţ—K0jӋŚ×uё+} 2Ë{nŻß¨ î’ćŔÖ8)ÉE˝.\|ôĺĽ^ç6÷زťwɂ P5GIUěsĆâĽsMŞ{'[ô;yRŽďţ 1{‹BW˛*ýś Ţě–ŕ5N‚^ŞtUc˝1ÓŃ.ŔrVű°í>(ÜňĘmÝ+ĺF)/˛9\śkš’‚ €  @!źpy&˘Š7ÝĐŒ™‰Ĺ8A⠂čdiŽ€P(@QĐ °QłZU9ƒ˘J¸ ćRé}&ü iBÖĺÓ\PƒéĽvVű"ÁĚ”{C$!ŃE.hŐ.…ƒˆ;PŞ[8ƒrK{&—{ ƒZ`@H ˇt´W$ęÜvۓ4×(A@KVś ´( €˘€@  € “nƒ‹@@P € @Zd(!@ °TžŔF¨†ô§Ă*Šëȃ6Ň2ö@j5{›Ir’s§ŮŠ}ŽŽÚؚ[˙L°sU…|ˆ9¤ˇ0â×BAZĄňô\liuĆâ q‹ä]o rߢ3nŞŔ€Ňő ŇË%@(`@ŠR!@@lTŹ iO¸p}§Ř(Ř´>„ŇűhRm†šäP@) @( B†âŘ€*VKěuÁiý7ÔŁ ÝIGš Č.–Fš¨i>@4ŒčEҊq*th%:ěgC6Ňű }‚EbŸb¸Ş4 „“ۆ4:5Ľv*ؐsŇű g@"ąŚš5iqšE.ṇ̌{‘AőVl9¸žĚ$ůŁ $TIWqOŘĐ*3ŁÜ̕ă}Y"šńĐÜeˇaŁ}™4{€Ž÷}KĄ*™B1ŁÜ83`°sŇű :Er)ŇŹšWa0t҂ŠBi7ÁjžčÚIpQ uĽŘšWa0oB=؃éĽUƒ Y´ť"8Ś ‹cKětI.ƒ 5ťCMß&ŔˆÎĄw4 B8´tƒž—Ů‘Ş:…Vö-ľÎć…"ÄM›ŕˏŤ~ ’ŸFô¤gJ|3u/fE|~dVRwţͤú” FëŁeeĎŰîgS: OĄ ĹÇ°zkcZWaĽvXĄĽö:PsŚşę)>DÓJě4Ą:ۂčMâU\,ŇT† Ą +Ść¨Qb0ăžäk˛gPH9\žČWK:=)÷LŇUĐ °  @gOKŘĐ/˝…ŤˇÜŘaÂř&‡uhčO’AÍGz4Ň싥 "+ _J5Şú–rő J‘†•]*ů & ĚW[4¤ 3Ąt0ÓGPH9śäޕش„W:tZvlŽn5Ȯ۝ŠÄRmÚ.„jb1(öDqg@ çĽü ëÉэúUŮ0ţ‡J]ƒŠb+*6‹Ł~M%H#5Ńýöďő:AË :8§ĐhB+˜§Ř饄ÁÔRě  iۓtŞ‚T"9¤îŠâ—-› Xƒš°ăOkfĐ,ŠöeŇű+{‰ΤťęŇ/š°"1ŁbéěÍÁ†­ďȤš6 :ž ĄŮ°X1ŁcU§‹(eŰč*Őőěh0ęşŘPľÉ° ƆM/ąĐtű3IşŞűš‚$ú˛×fjWł.­ľěh"p7­Ů@¸ĽŔô­čŃSčÖ¨ŞWĐi]…‡ť&¤¸ÜľÜ´ťÍśŢČigJ]‚IpHŹé4• ‰UŔŽĺeÇč‰%ś×HŘrtŇťB$VVě­QĽ”A…WɧĐ,Ftß$ŚžÖl0ísDĺ쎂‰ΟbéfŔˆçĽöűŠä(ę)1:[[҆šęÄŇű /ąŇˇ° ‹Žű#`DrŁjë„j‘4öYľŮ OĄt{-pŤăa]™}]…7ŮŇűŠkŤ4 ” &gB4Ɩ¸cԟŔƒĘ.˜łDqO ƒ.ňGoJEŞ$´žŔęW4˝Ëťfév"1ĽőcCîP­ÄV4žÄ§Řęöę]7Áş]…RŘA Í;ŁĽ{˛h}ÄjAŇݗKďeJş~TMűPą_"ŸvĂrě´ĄŔ Á@€(†€A(…hP…hQDĄ@@Z@hh€@ZAhĽ†ˆAhP…h´AhP"”dd …@Z R(e†ˆ(  (  -!h˘P˘€ ˘€%S Z˘”JPĄEJPKEdAhQ@P@  Z €…QHŀ(!@„)˘€P˘‚ˆ…(Q@ˆh(Q@…(!@ @@…(Q@ €Q@@(Q@…R(…hPŠQh€@Q@BŠ(-@€ˆh€@Q@@ZAhP˘…>Ľ% ”(  E BŠ‚Š”PX@ ( E(… F!€(,YD€(€P@n€ąbŔ @Al @Q@@Z Z)ADĄEJ(ĘČ( € R(؀ @PĹ bĹQ@P Pd…Bě(P !hP€(˘Ĺ€),YEą`REhP˘…ąb…, €d P -Ł Đ(Q  Bˆ )J% (P˘€% (P˘€%€(P˘€2 ‚Đ  - Đ  )Ń (B€ (P˘€% (P˘€ Ü  ¸Ü  ¸Ü  ¸(€!@˙ŮPDL-2.018/Lib/Transform/Cartography/Makefile.PL0000644060175006010010000000070212562522365017321 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; # "Globe/Globe.pm" puts Globe.pm in the correct subdir! WriteMakefile( 'NAME' => 'PDL::Transform::Cartography', VERSION_FROM => '../../../Basic/Core/Version.pm', PM => { (map {($_ => '$(INST_LIBDIR)/'.$_)} <*.pm>), (map {($_ => '$(INST_LIBDIR)/Cartography/'.$_)} <*.fits *.jpg>)}, (eval ($ExtUtils::MakeMaker::VERSION) >= 6.57_02 ? ('NO_MYMETA' => 1) : ()), ); PDL-2.018/Lib/Transform/Makefile.PL0000644060175006010010000000046612562522365015045 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["transform.pd", qw(Transform PDL::Transform)]); my %hash = pdlpp_stdargs_int(@pack); $hash{DIR} = ['Cartography', 'Proj4']; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile( %hash ); PDL-2.018/Lib/Transform/Proj4/0000755060175006010010000000000013110402046014042 5ustar chmNonePDL-2.018/Lib/Transform/Proj4/Makefile.PL0000644060175006010010000000353012562522365016036 0ustar chmNoneuse strict; use warnings; use ExtUtils::MakeMaker; my $package_name = "PDL::Transform::Proj4"; my $lib_name = "Proj4"; my $config_flag = 'WITH_PROJ'; my $config_libs = 'PROJ_LIBS'; my $config_incs = 'PROJ_INC'; my $forcebuild=0; if (defined $PDL::Config{$config_flag} && $PDL::Config{$config_flag}==0) { write_dummy_make("Will skip build of $package_name on this system"); $PDL::Config{$config_flag}=0; return; } require Alien::Proj4; # runtime not compile-time so return above will work my @inc = Alien::Proj4->default_inc; @inc = @{$PDL::Config{$config_incs}} if $PDL::Config{$config_incs} and @{$PDL::Config{$config_incs}}; push @inc, File::Spec->catdir((File::Spec->updir) x 2, qw(GIS Proj include)); Alien::Proj4->import($PDL::Config{$config_libs}, \@inc); if (defined $PDL::Config{$config_flag} && $PDL::Config{$config_flag}==1) { print " Will forcibly try and build $package_name on this system\n"; $forcebuild=1; } if (!$forcebuild && !Alien::Proj4->installed) { write_dummy_make( <libflags; my $incflags = Alien::Proj4->incflags; print "Building $package_name. Turn off $config_flag if there are any problems\n"; $PDL::Config{$config_flag}=1; my $ppfile = "Proj4.pd"; my $package = [$ppfile, 'Proj4', $package_name]; my %hash = pdlpp_stdargs($package); $hash{VERSION_FROM} = $ppfile; #$hash{TYPEMAPS} = [&PDL_TYPEMAP()]; $hash{LIBS} = [ $libflags ]; $hash{INC} = PDL_INCLUDE() . " $incflags"; $hash{realclean} = { FILES => '' } unless $hash{realclean}; $hash{realclean}{FILES} .= ' _Inline'; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int( $package ); }; WriteMakefile(%hash); PDL-2.018/Lib/Transform/Proj4/Proj4.pd0000644060175006010010000003333413101430577015405 0ustar chmNone# PDL::PP Definition file for the PDL::Transform::Proj4 module # # Judd Taylor, USF IMaRS # 4 Apr 2006 use strict; use File::Spec; use lib File::Spec->catdir((File::Spec->updir) x 3, 'inc'); use vars qw( $VERSION ); $VERSION = "1.32"; pp_add_isa( 'PDL::Transform' ); # This array holds the list of functions we want to export (everything here is explicit!) my @export_funcs = (); pp_addbegin( <<'ENDBEGIN' ); use PDL; use PDL::NiceSlice; use PDL::Transform; use PDL::GIS::Proj; ENDBEGIN # # Put in the general projection: # pp_addpm( { At => 'Top' }, <<'ENDPM' ); # # PDL::Transform::Proj4 # # Judd Taylor, USF IMaRS # 4 Apr 2006 # =head1 NAME PDL::Transform::Proj4 - PDL::Transform interface to the Proj4 projection library =head1 SYNOPSIS # Using the generalized proj interface: # Make an orthographic map of Earth use PDL::Transform::Cartography; use PDL::Transform::Proj4; $a = earth_coast(); $a = graticule(10,2)->glue(1,$a); $t = t_proj( proj_params => "+proj=ortho +ellps=WGS84 +lon_0=-90 +lat_0=40" ); $w = pgwin(xs); $w->lines($t->apply($a)->clean_lines()); # Using the aliased functions: # Make an orthographic map of Earth use PDL::Transform::Cartography; use PDL::Transform::Proj4; $a = earth_coast(); $a = graticule(10,2)->glue(1,$a); $t = t_proj_ortho( ellps => 'WGS84', lon_0 => -90, lat_0 => 40 ) $w = pgwin(xs); $w->lines($t->apply($a)->clean_lines()); =head1 DESCRIPTION Works like PDL::Transform::Cartography, but using the proj library in the background. Please see the proj library docs at L for more information on proj, and how to use the library. =head1 GENERALIZED INTERFACE The main object here is the PDL::Transform::Proj4 object, aliased to the t_proj() function. This object accepts all of the standard options described below, but mainly is there to be called with just the B option defined. When options are used, they must be used with a '+' before them when placed in the proj_params string, but that is not required otherwise. See the SYNOPSIS above. =head2 ALIASED INTERFACE Other than t_proj(), all of the other transforms below have been autogenerated, and may not work properly. The main problem is determining the parameters a projection requires from the proj library itself. Due to the difficulties in doing this, there may be times when the proj docs specify a parameter for a projection that won't work using the anon-hash type specification. In that case, just throw that parameter in the proj_params string, and everything should work fine. =head1 PARAMETERS AVAILABLE IN ALL PROJECTIONS =head2 General Parameters =head3 proj_params This is a string containing the proj "plus style" parameters. This would be similar to what you would put on the command line for the 'proj' tool. Like "+proj=ortho +ellps=WGS84 +lon_0=-90 +lat_0=40". This parameter overrides the others below when it contains parameters that are also specified explicitly. =head3 proj The proj projection code to use (like ortho...) =head3 x_0 Cartesian X offset for the output of the transformation =head3 y_0 Cartesian Y offset for the output of the transformation =head3 lat_0 Central latitude for the projection. NOTE: This may mean other things depending on the projection selected, read the proj docs! =head3 lon_0 Central longitude for the projection. NOTE: This may mean other things depending on the projection selected, read the proj docs! =head3 units Cartesian units used for the output of the projection. NOTE: Like most of the options here, this is likely useless in the current implementation of this library. =head3 init Specify a file:unit for proj to use for its runtime defaults. See the proj docs. =head3 no_defs Don't load any defaults. See the proj docs. =head3 over Normally, the transformation limits the output to between -180 and 180 degrees (or the cartesian equivalent), but with this option that behavior is turned off. =head3 geoc Input values are geocentric coordinates. =head2 Earth Figure Parameters =head3 ellps Ellipsoid datum to use. Ex: WGS72, WGS74. See the proj docs and command line tool for list of possibilities ('proj -le'). =head3 R Radius of the Earth. =head3 R_A Radius of a sphere with equivalent surface area of specified ellipse. =head3 R_V Radius of a sphere with equivalent volume of specified ellipse. =head3 R_a Arithmetic mean of the major and minor axis, Ra = (a + b)/2. =head3 R_g Geometric mean of the major and minor axis, Rg = (ab)1/2. =head3 R_h Harmonic mean of the major and minor axis, Rh = 2ab/(a + b). =head3 R_lat_a=phi Arithmetic mean of the principle radii at latitude phi. =head3 R_lat_g=phi Geometric mean of the principle radii at latitude phi. =head3 b Semiminor axis or polar radius =head3 f Flattening =head3 rf Reciprocal flattening, +rf=1/f =head3 e Eccentricity +e=e =head3 es Eccentricity squared +es=e2 =cut sub new { my $proto = shift; my $sub = "PDL::Transform::Proj4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $class = ref($proto) || $proto; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Proj4"; # Grab our options: # Used in the general sense: $self->{params}->{proj_params} = PDL::Transform::_opt( $o, ['proj_params','params'] ); # Projection options available to all projections: $self->{general_params} = [ qw( proj x_0 y_0 lat_0 lon_0 units init ) ]; foreach my $param ( @{ $self->{general_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } # Options that have no value (like "+over"): $self->{bool_params} = [ qw( no_defs over geoc ) ]; foreach my $param ( @{ $self->{bool_params} } ) { $self->{params}->{$param} = ( PDL::Transform::_opt( $o, [ $param ] ) ) ? 'ON' : undef; } # Options for the Earth figure: (ellipsoid, etc): $self->{earth_params} = [ qw( ellps R R_A R_V R_a R_g R_h R_lat_a R_lat_g b f rf e es ) ]; foreach my $param ( @{ $self->{earth_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } # First process the old params that may already be in the string: # These override the specific params set above: if( defined( $self->{params}->{proj_params} ) ) { $self->{orig_proj_params} = $self->{params}->{proj_params}; my @params = split( /\s+/, $self->{orig_proj_params} ); foreach my $param ( @params ) { if( $param =~ /^\+(\S+)=(\S+)/ ) { my ($name, $val) = ($1, $2); $self->{params}->{$name} = $val; #print STDERR "$sub: $name => $val\n"; } elsif( $param =~ /^\+(\S+)/ ) { # Boolean option $self->{params}->{$1} = 'ON'; } } } # Update the proj_string to current options: # $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); ############################## # The meat -- just copy and paste from Transform.pm :) # (and do some proj stuff here as well) # Forward transformation: $self->{func} = sub { my $in = shift; my $opt = shift; my $sub = "PDL::Transform::Proj4->{func}()"; my $out = $in->new_or_inplace(); # Always set the badflag to 1 here, to handle possible bad projection values: $out->badflag(1); PDL::GIS::Proj::fwd_trans_inplace( $out->((0)), $out->((1)), $opt->{proj_params}, 1 ); return $out; }; # Inverse transformation: $self->{inv} = sub { my $in = shift; my $opt = shift; my $sub = "PDL::Transform::Proj4->{inv}()"; my $out = $in->new_or_inplace(); # Always set the badflag to 1 here, to handle possible bad projection values: $out->badflag(1); PDL::GIS::Proj::inv_trans_inplace( $out->((0)), $out->((1)), $opt->{proj_params}, 1 ); return $out; }; return $self; } # End of new()... sub update_proj_string { my $self = shift; my $sub = "PDL::Transform::Proj4::update_proj_string()"; # (Re)Generate the proj_params string from the options passed: # delete( $self->{params}->{proj_params} ); my $proj_string = ""; foreach my $param ( keys %{ $self->{params} } ) { next unless defined( $self->{params}->{$param} ); $proj_string .= ( $self->{params}->{$param} eq 'ON' ) ? "+$param " : " +$param=" . $self->{params}->{$param} . " "; #print STDERR "$sub: Adding \'$proj_string\'...\n"; } #print STDERR "$sub: Final proj_params: \'$proj_string\'\n"; $self->{params}->{proj_params} = $proj_string; } # End of update_proj_string()... sub proj_params { my $self = shift; $self->update_proj_string(); return $self->{params}->{proj_params}; } # End of proj_params()... sub t_proj { PDL::Transform::Proj4->new( @_ ); } # End of t_proj()... 1; ENDPM # # Add the docs for t_proj: # pp_addpm( { At => 'Middle' }, <<'ENDPM' ); =head1 FUNCTIONS =head2 t_proj This is the main entry point for the generalized interface. See above on its usage. =cut ENDPM push( @export_funcs, 't_proj' ); # Add in the auto-generated projection classes: require Alien::Proj4; require PDL::Config; my @inc = Alien::Proj4->default_inc; @inc = @{$PDL::Config{PROJ_INC}} if $PDL::Config{PROJ_INC} and @{$PDL::Config{PROJ_INC}}; my $supplied = File::Spec->catdir((File::Spec->updir) x 2, qw(GIS Proj include)); push @inc, File::Spec->rel2abs($supplied); # because Inline builds elsewhere Alien::Proj4->import($PDL::Config{PROJ_LIBS}, \@inc); my $projections = Alien::Proj4->load_projection_information(); foreach my $name ( sort keys %$projections ) { #print STDERR "Generating code for projection $name...\n"; my $projection = $projections->{$name}; # Start out with a blank template: my $template = <<'ENDTEMPLATE'; # Autogenerated code for the Proj4 projection code: # INSERT_NAME_HERE # package PDL::Transform::Proj4::INSERT_NAME_HERE; use PDL::Transform::Proj4; @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::INSERT_NAME_HERE::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "INSERT_FULL_NAME_HERE"; $self->{proj_code} = "INSERT_NAME_HERE"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( INSERT_PARAM_LIST_HERE ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::INSERT_NAME_HERE::new()... 1; ENDTEMPLATE # Fill in the projection name: $template =~ s/INSERT_NAME_HERE/$name/sg; # Fill in the full name of the projection: $template =~ s/INSERT_FULL_NAME_HERE/$projection->{NAME}/sg; # Fill in the parameter list: my $param_list = join(' ', @{ $projection->{PARAMS}->{PROJ} } ); $template =~ s/INSERT_PARAM_LIST_HERE/$param_list/sg; # Add the code to the module: pp_addpm( {At => 'Bot'}, $template ); # Generate the alias sub: my $alias_name = "t_proj_$name"; push( @export_funcs, $alias_name ); my $doc_param_list = ""; if( scalar( @{ $projection->{PARAMS}->{PROJ} } ) ) { $doc_param_list .= "\nProjection Parameters\n\n=for options\n\n=over 4\n\n"; foreach my $param ( sort @{ $projection->{PARAMS}->{PROJ} } ) { next if(!$param); $doc_param_list .= "=item $param\n\n"; } $doc_param_list .= "=back\n\n"; } my $alias_template = <<'ENDTEMPLATE'; =head2 INSERT_ALIAS_NAME_HERE Autogenerated transformation function for Proj4 projection code INSERT_NAME_HERE. The full name for this projection is INSERT_FULL_NAME_HERE. INSERT_PARAM_LIST_HERE =cut sub INSERT_ALIAS_NAME_HERE { PDL::Transform::Proj4::INSERT_NAME_HERE->new( @_ ); } ENDTEMPLATE $alias_template =~ s/INSERT_ALIAS_NAME_HERE/$alias_name/sg; $alias_template =~ s/INSERT_NAME_HERE/$name/sg; $alias_template =~ s/INSERT_FULL_NAME_HERE/$projection->{NAME}/sg; $alias_template =~ s/INSERT_PARAM_LIST_HERE/$doc_param_list/sg; pp_addpm( {At => 'Middle'}, $alias_template ); } # for each projection... pp_add_exported('', join(' ', @export_funcs ) ); # Empty pp_def(), so it will actually generate the code below in the output file! # pp_def( '_proj4_dummy', Pars => 'i(); [o] o();', Doc => undef, Code => ';' ); # Add the end docs: # pp_addpm( {At => 'Bot'}, <<'ENDDOC'); =head1 AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut ENDDOC pp_done(); PDL-2.018/Lib/Transform/Proj4/README0000644060175006010010000000256312562522365014751 0ustar chmNoneNAME PDL::Transform::Proj DESCRIPTION This is a port of the Proj library to PDL. COPYRIGHT NOTICE Copyright 2003 Judd Taylor, USF Institute for Marine Remote Sensing (judd@marine.usf.edu). This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. I'm making it GPL now, so I should probably update the above notice! PREREQUISITES Proj4 C library (tested with 4.4.5) Perl (tested with 5.8.0) PDL (tested with 2.3.4 with BadVals) BUILD INSTRUCTIONS 1. Install the Proj4 library if you haven't already. 2. Edit the Makefile.PL to point the $proj4_include_path and $proj4_lib_path variables to your installation of the Proj4 library. 3. Make the makefiles with the command: shell> perl Makefile.PL 4. Build the software with the command: shell> make 5. Install the software with the command: shell> make install 6. Test the software (option) using the included script test_proj4.pl. NOTE: There are no regression tests yet, but if something is wrong with the install, it will probably break the test script. USAGE See the POD in the lib itself, and check out the test script. CHANGES 1.0: Inital version PDL-2.018/Lib/Transform/Proj4/TODO0000644060175006010010000000006712562522365014556 0ustar chmNone# # TODO for version 1.32 of PDL::Transform::Proj: # PDL-2.018/Lib/Transform/transform.pd0000644060175006010010000040445313036512175015432 0ustar chmNonepp_addhdr("#include \n") unless $^O =~ /MSWin32/i; pp_addpm({At=>'Top'},<<'+======EOD======'); =head1 NAME PDL::Transform - Coordinate transforms, image warping, and N-D functions =head1 SYNOPSIS use PDL::Transform; my $t = new PDL::Transform::() $out = $t->apply($in) # Apply transform to some N-vectors (Transform method) $out = $in->apply($t) # Apply transform to some N-vectors (PDL method) $im1 = $t->map($im); # Transform image coordinates (Transform method) $im1 = $im->map($t); # Transform image coordinates (PDL method) $t2 = $t->compose($t1); # compose two transforms $t2 = $t x $t1; # compose two transforms (by analogy to matrix mult.) $t3 = $t2->inverse(); # invert a transform $t3 = !$t2; # invert a transform (by analogy to logical "not") =head1 DESCRIPTION PDL::Transform is a convenient way to represent coordinate transformations and resample images. It embodies functions mapping R^N -> R^M, both with and without inverses. Provision exists for parametrizing functions, and for composing them. You can use this part of the Transform object to keep track of arbitrary functions mapping R^N -> R^M with or without inverses. The simplest way to use a Transform object is to transform vector data between coordinate systems. The L method accepts a PDL whose 0th dimension is coordinate index (all other dimensions are threaded over) and transforms the vectors into the new coordinate system. Transform also includes image resampling, via the L method. You define a coordinate transform using a Transform object, then use it to remap an image PDL. The output is a remapped, resampled image. You can define and compose several transformations, then apply them all at once to an image. The image is interpolated only once, when all the composed transformations are applied. In keeping with standard practice, but somewhat counterintuitively, the L engine uses the inverse transform to map coordinates FROM the destination dataspace (or image plane) TO the source dataspace; hence PDL::Transform keeps track of both the forward and inverse transform. For terseness and convenience, most of the constructors are exported into the current package with the name C<< t_ >>, so the following (for example) are synonyms: $t = new PDL::Transform::Radial(); # Long way $t = t_radial(); # Short way Several math operators are overloaded, so that you can compose and invert functions with expression syntax instead of method syntax (see below). =head1 EXAMPLE Coordinate transformations and mappings are a little counterintuitive at first. Here are some examples of transforms in action: use PDL::Transform; $a = rfits('m51.fits'); # Substitute path if necessary! $ts = t_linear(Scale=>3); # Scaling transform $w = pgwin(xs); $w->imag($a); ## Grow m51 by a factor of 3; origin is at lower left. $b = $ts->map($a,{pix=>1}); # pix option uses direct pixel coord system $w->imag($b); ## Shrink m51 by a factor of 3; origin still at lower left. $c = $ts->unmap($a, {pix=>1}); $w->imag($c); ## Grow m51 by a factor of 3; origin is at scientific origin. $d = $ts->map($a,$a->hdr); # FITS hdr template prevents autoscaling $w->imag($d); ## Shrink m51 by a factor of 3; origin is still at sci. origin. $e = $ts->unmap($a,$a->hdr); $w->imag($e); ## A no-op: shrink m51 by a factor of 3, then autoscale back to size $f = $ts->map($a); # No template causes autoscaling of output =head1 OPERATOR OVERLOADS =over 3 =item '!' The bang is a unary inversion operator. It binds exactly as tightly as the normal bang operator. =item 'x' By analogy to matrix multiplication, 'x' is the compose operator, so these two expressions are equivalent: $f->inverse()->compose($g)->compose($f) # long way !$f x $g x $f # short way Both of those expressions are equivalent to the mathematical expression f^-1 o g o f, or f^-1(g(f(x))). =item '**' By analogy to numeric powers, you can apply an operator a positive integer number of times with the ** operator: $f->compose($f)->compose($f) # long way $f**3 # short way =back =head1 INTERNALS Transforms are perl hashes. Here's a list of the meaning of each key: =over 3 =item func Ref to a subroutine that evaluates the transformed coordinates. It's called with the input coordinate, and the "params" hash. This springboarding is done via explicit ref rather than by subclassing, for convenience both in coding new transforms (just add the appropriate sub to the module) and in adding custom transforms at run-time. Note that, if possible, new Cs should support L operation to save memory when the data are flagged inplace. But C should always return its result even when flagged to compute in-place. C should treat the 0th dimension of its input as a dimensional index (running 0..N-1 for R^N operation) and thread over all other input dimensions. =item inv Ref to an inverse method that reverses the transformation. It must accept the same "params" hash that the forward method accepts. This key can be left undefined in cases where there is no inverse. =item idim, odim Number of useful dimensions for indexing on the input and output sides (ie the order of the 0th dimension of the coordinates to be fed in or that come out). If this is set to 0, then as many are allocated as needed. =item name A shorthand name for the transformation (convenient for debugging). You should plan on using UNIVERAL::isa to identify classes of transformation, e.g. all linear transformations should be subclasses of PDL::Transform::Linear. That makes it easier to add smarts to, e.g., the compose() method. =item itype An array containing the name of the quantity that is expected from the input piddle for the transform, for each dimension. This field is advisory, and can be left blank if there's no obvious quantity associated with the transform. This is analogous to the CTYPEn field used in FITS headers. =item oname Same as itype, but reporting what quantity is delivered for each dimension. =item iunit The units expected on input, if a specific unit (e.g. degrees) is expected. This field is advisory, and can be left blank if there's no obvious unit associated with the transform. =item ounit Same as iunit, but reporting what quantity is delivered for each dimension. =item params Hash ref containing relevant parameters or anything else the func needs to work right. =item is_inverse Bit indicating whether the transform has been inverted. That is useful for some stringifications (see the PDL::Transform::Linear stringifier), and may be useful for other things. =back Transforms should be inplace-aware where possible, to prevent excessive memory usage. If you define a new type of transform, consider generating a new stringify method for it. Just define the sub "stringify" in the subclass package. It should call SUPER::stringify to generate the first line (though the PDL::Transform::Composition bends this rule by tweaking the top-level line), then output (indented) additional lines as necessary to fully describe the transformation. =head1 NOTES Transforms have a mechanism for labeling the units and type of each coordinate, but it is just advisory. A routine to identify and, if necessary, modify units by scaling would be a good idea. Currently, it just assumes that the coordinates are correct for (e.g.) FITS scientific-to-pixel transformations. Composition works OK but should probably be done in a more sophisticated way so that, for example, linear transformations are combined at the matrix level instead of just strung together pixel-to-pixel. =head1 MODULE INTERFACE There are both operators and constructors. The constructors are all exported, all begin with "t_", and all return objects that are subclasses of PDL::Transform. The L, L, L, and L methods are also exported to the C package: they are both Transform methods and PDL methods. =cut +======EOD====== pp_addpm({At=>'Bot'},<<'+======EOD======'); =head1 AUTHOR Copyright 2002, 2003 Craig DeForest. There is no warranty. You are allowed to redistribute this software under certain conditions. For details, see the file COPYING in the PDL distribution. If this file is separated from the PDL distribution, the copyright notice should be included in the file. =cut package PDL::Transform; use Carp; use overload '""' => \&_strval; use overload 'x' => \&_compose_op; use overload '**' => \&_pow_op; use overload '!' => \&t_inverse; use PDL; use PDL::MatrixOps; our $PI = 3.1415926535897932384626; our $DEG2RAD = $PI / 180; our $RAD2DEG = 180/$PI; our $E = exp(1); #### little helper kludge parses a list of synonyms sub _opt { my($hash) = shift; my($synonyms) = shift; my($alt) = shift; # default is undef -- ok. local($_); foreach $_(@$synonyms){ return (UNIVERSAL::isa($alt,'PDL')) ? PDL->pdl($hash->{$_}) : $hash->{$_} if defined($hash->{$_}) ; } return $alt; } ###################################################################### # # Stringification hack. _strval just does a method search on stringify # for the object itself. This gets around the fact that stringification # overload is a subroutine call, not a method search. # sub _strval { my($me) = shift; $me->stringify(); } ###################################################################### # # PDL::Transform overall stringifier. Subclassed stringifiers should # call this routine first then append auxiliary information. # sub stringify { my($me) = shift; my($mestr) = (ref $me); $mestr =~ s/PDL::Transform:://; my $out = $mestr . " (" . $me->{name} . "): "; $out .= "fwd ". ((defined ($me->{func})) ? ( (ref($me->{func}) eq 'CODE') ? "ok" : "non-CODE(!!)" ): "missing")."; "; $out .= "inv ". ((defined ($me->{inv})) ? ( (ref($me->{inv}) eq 'CODE') ? "ok" : "non-CODE(!!)" ):"missing").".\n"; } +======EOD====== pp_add_exported('apply'); pp_addpm(<<'+======EOD_apply======'); =head2 apply =for sig Signature: (data(); PDL::Transform t) =for usage $out = $data->apply($t); $out = $t->apply($data); =for ref Apply a transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is a PDL to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar but transformed PDL. For convenience, this is both a PDL method and a Transform method. =cut use Carp; *PDL::apply = \&apply; sub apply { my($me) = shift; my($from) = shift; if(UNIVERSAL::isa($me,'PDL')){ my($a) = $from; $from = $me; $me = $a; } if(UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($from,'PDL')){ croak "Applying a PDL::Transform with no func! Oops.\n" unless(defined($me->{func}) and ref($me->{func}) eq 'CODE'); my $result = &{$me->{func}}($from,$me->{params}); $result->is_inplace(0); # clear inplace flag, just in case. return $result; } else { croak "apply requires both a PDL and a PDL::Transform.\n"; } } +======EOD_apply====== pp_add_exported('invert'); pp_addpm(<<'+======EOD_invert======'); =head2 invert =for sig Signature: (data(); PDL::Transform t) =for usage $out = $t->invert($data); $out = $data->invert($t); =for ref Apply an inverse transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is a piddle to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar piddle. For convenience this is both a PDL method and a PDL::Transform method. =cut *PDL::invert = \&invert; sub invert { my($me) = shift; my($data) = shift; if(UNIVERSAL::isa($me,'PDL')){ my($a) = $data; $data = $me; $me = $a; } if(UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($data,'PDL')){ croak "Inverting a PDL::Transform with no inverse! Oops.\n" unless(defined($me->{inv}) and ref($me->{inv}) eq 'CODE'); my $result = &{$me->{inv}}($data, $me->{params}); $result->is_inplace(0); # make sure inplace flag is clear. return $result; } else { croak("invert requires a PDL and a PDL::Transform (did you want 'inverse' instead?)\n"); } } +======EOD_invert====== pp_addhdr(<<'+==EOD_map_auxiliary=='); /* * Singular-value decomposition code is borrowed from * MatrixOps -- cut-and-pasted here because of linker trouble. * It's used by the auxiliary matrix manipulation code, below. * */ void pdl_xform_svd(PDL_Double *W, PDL_Double *Z, int nRow, int nCol) { int i, j, k, EstColRank, RotCount, SweepCount, slimit; PDL_Double eps, e2, tol, vt, p, h2, x0, y0, q, r, c0, s0, c2, d1, d2; eps = 1e-6; slimit = nCol/4; if (slimit < 6.0) slimit = 6; SweepCount = 0; e2 = 10.0*nRow*eps*eps; tol = eps*.1; EstColRank = nCol; for (i=0; i= r) { if (q<=e2*Z[0] || fabs(p)<=tol*q) RotCount--; else { p /= q; r = 1 - r/q; vt = sqrt(4*p*p+r*r); c0 = sqrt(fabs(.5*(1+r/vt))); s0 = p/(vt*c0); for (i=0; i=3 && Z[(EstColRank-1)]<=Z[0]*tol+tol*tol) EstColRank--; } } /* * PDL_xform_aux: * This handles the matrix manipulation part of the Jacobian filtered * mapping code. It's separate from the main code because it's * independent of the data type of the original arrays. * *Given a pre-allocated workspace and * an integer set of coordinates, generate the discrete Jacobian * from the map, pad the singular values, and return the inverse * Jacobian, the largest singular value of the Jacobian itself, and * the determinant of the original Jacobian. Boundary values use the * asymmetric discrete Jacobian; others use the symmetric discrete Jacobian. * * The map and workspace must be of type PDL_D. If the dimensionality is * d, then the workspace must have at least 3*n^2+n elements. The * inverse of the padded Jacobian is returned in the first n^2 elements. * The determinant of the original Jacobian gets stuffed into the n^2 * element of the workspace. The largest padded singular value is returned. * */ PDL_Double PDL_xform_aux ( pdl *map, PDL_Indx *coords, PDL_Double *tmp, PDL_Double sv_min) { short ndims; PDL_Long i, j, k; PDL_Long offset; PDL_Double det; PDL_Double *jptr; PDL_Double *svptr; PDL_Double *aptr,*bptr; PDL_Double max_sv = 0.0; ndims = map->ndims-1; /****** Accumulate the Jacobian */ /* Accumulate the offset into the map array */ for( i=offset=0; idimincs[i+1]; jptr = tmp + ndims*ndims; for( i=0; i= map->dims[i+1]-1); char symmetric = !(bot || top); PDL_Double *ohi,*olo; PDL_Long diff = map->dimincs[i+1]; ohi = ((PDL_Double *)map->data) + ( offset + ( top ? 0 : diff )); olo = ((PDL_Double *)map->data) + ( offset - ( bot ? 0 : diff )); for( j=0; jdimincs[0]; olo += map->dimincs[0]; if(symmetric) jel /= 2; *(jptr++) = jel; } } /****** Singular-value decompose the Jacobian * The svd routine produces the squares of the singular values, * and requires normalization for one of the rotation matrices. */ jptr = tmp + ndims*ndims; svptr = tmp + 3*ndims*ndims; pdl_xform_svd(jptr,svptr,ndims,ndims); aptr = svptr; for (i=0;i max_sv ) max_sv = *aptr; aptr++; } /****** Generate the inverse matrix */ /* Multiply B-transpose times 1/S times A-transpose. */ /* since S is diagonal we just divide by the appropriate element. */ /* */ aptr = tmp + ndims*ndims; bptr = aptr + ndims*ndims; jptr= tmp; for(i=0;i'k0()', # Dummy to set type (should match the type of "in"). OtherPars=>'SV *in; SV *out; SV *map; SV *boundary; SV *method; SV *big; SV *blur; SV *sv_min; SV *flux; SV *bv', Code => <<'+==EOD_map_c_code==', /* * Pixel interpolation & averaging code * * Calls a common coordinate-transformation block (see following hdr) * that isn't dependent on the type of the input variable. * * The inputs are SVs to avoid hassling with threadloops; threading * is handled internally. To simplify the threading business, any * thread dimensions should all be collapsed to a single one by the * perl front-end. * */ short ndims; /* Number of dimensions we're working in */ PDL_Double *tmp; /* Workspace for prefrobnication */ PDL_Indx *ovec; /* output pixel loop vector */ PDL_Indx *ivec; /* input pixel loop vector */ PDL_Indx *ibvec; /* input pixel base offset vector */ PDL_Double *dvec; /* Residual vector for linearization */ PDL_Double *tvec; /* Temporary floating-point vector */ PDL_Double *acc; /* Threaded accumulator */ PDL_Double *wgt; /* Threaded weight accumulator */ PDL_Double *wgt2; /* Threaded weight accumulator for badval finding */ char *bounds; /* Boundary condition packed string */ PDL_Indx *index_stash; /* Stash to store the opening index of dim sample scans */ char method; /* Method identifier (gets one of 'h','g') */ PDL_Long big; /* Max size of input footprint for each pix */ PDL_Double blur; /* Scaling of filter */ PDL_Double sv_min; /* minimum singular value */ char flux; /* Flag to indicate flux conservation */ PDL_Double *map_ptr; PDL_Long i, j; $GENERIC() badval = SvNV($COMP(bv)); #define HANNING_LOOKUP_SIZE 2500 static PDL_Double hanning_lookup[HANNING_LOOKUP_SIZE + 2]; static int needs_hanning_calc = 1; PDL_Double zeta; PDL_Double hanning_offset; #define GAUSSIAN_LOOKUP_SIZE 4000 #define GAUSSIAN_MAXVAL 6.25 /* 2.5 HWHMs (square it) */ static PDL_Double gaussian_lookup[GAUSSIAN_LOOKUP_SIZE + 2]; static int needs_gaussian_calc = 1; pdl *in = PDL->SvPDLV($COMP(in)); pdl *out = PDL->SvPDLV($COMP(out)); pdl *map = PDL->SvPDLV($COMP(map)); PDL->make_physical(in); PDL->make_physical(out); PDL->make_physical(map); ndims = map->ndims -1; /* * Allocate all our dynamic workspaces at once * */ ovec = (PDL_Indx *)(PDL->smalloc( (STRLEN) ( + sizeof(PDL_Indx) * 3 * ndims // ovec, ivec, ibvec + sizeof(PDL_Double) * (3*ndims) // dvec, tvec + sizeof(PDL_Double) * in->dims[ndims] // acc + sizeof(PDL_Double) * in->dims[ndims] // wgt + sizeof(PDL_Double) * in->dims[ndims] // wgt2 + sizeof(PDL_Double) * 3 * ndims*ndims + ndims // tmp (for PDL_xform_aux) + sizeof(char) * ndims // bounds + sizeof(PDL_Indx) * ndims // index_stash ) ) ); ivec = &(ovec[ndims]); ibvec = &(ivec[ndims]); dvec = (PDL_Double *)(&(ibvec[ndims])); tvec = &(dvec[ndims]); acc = &(tvec[ndims]); wgt = &(acc[in->dims[ndims]]); // weighting for accumulation wgt2 = &(wgt[in->dims[ndims]]); // weighting for acc, if no bad values were found tmp = &(wgt2[in->dims[ndims]]); bounds = (char *)(&(tmp [3*ndims*ndims+ndims])); index_stash = (PDL_Indx *) &(bounds[ndims]); /*** * Fill in the boundary condition array */ { char *bstr; STRLEN blen; bstr = SvPV($COMP(boundary),blen); if(blen == 0) { /* If no boundary is specified then every dim gets truncated */ int i; for (i=0;i0"); blur = fabs((PDL_Double) (SvNV($COMP(blur)))); if(blur < 0) barf("%s","map: 'blur' parameter must be >= 0"); sv_min = fabs((PDL_Double) (SvNV($COMP(sv_min)))); if(sv_min < 0) barf("%s","map: 'sv_min' parameter must be >= 0"); flux = (SvNV($COMP(flux)) != 0); { char *mstr; STRLEN mlen; mstr = SvPV($COMP(method),mlen); if(mlen==0) method = 'h'; else switch(*mstr) { case 'H': // H - rigorous hanning window method='H'; break; case 'h': // h - lookup-table hanning window method = 'h'; if( needs_hanning_calc ) { int i; for(i=0;i= 1) ? 0 : 0.5 * (1.0 - blur); break; case 'g': case 'j': // Gaussian and/or Jacobian, using lookup table method = 'g'; zeta = GAUSSIAN_LOOKUP_SIZE / GAUSSIAN_MAXVAL; if( needs_gaussian_calc ) { int i; for(i=0;idata); /* Main pixel loop (iterates over pixels in the output plane) */ do { PDL_Indx psize; // Size of the region to accumulate over for this pixel PDL_Indx i_off; // Offset into the data array of the source PDL PDL_Indx j; // Generic loop index char t_vio; // counter used for truncation boundary violations char carry; // flag used for multidimensional loop iteration /* Prefrobnicate the transformation matrix */ psize = (PDL_Long)(blur * PDL_xform_aux(map, ovec, tmp, sv_min) + 0.5)+1; /* assignment */ #ifdef DEBUG_MAP { int k; PDL_Indx foo = 0; printf("ovec: ["); for(k=0;kdimincs[k+1]; printf(" %2d ",(int)(ovec[k])); } printf("]; psize is %d; big is %d; blur is %8.2f; ret is %8g; map is [",psize,big, blur, ret); for(k=0;kdata))[foo + k*map->dimincs[0]])); } printf("]\n"); } #endif /* Don't bother accumulating output if psize is too large */ if(psize <= big) { /* Use the prefrobnicated matrix to generate a local linearization. * dvec gets the delta; ibvec gets the base. */ { PDL_Double *mp = map_ptr; for (i=0;idimincs[0]; } } /* Initialize input delta vector */ for(i=0;idims[ndims]; i++) *(ac++) = 0.0; } { PDL_Double *wg = wgt; for(i=0;i < in->dims[ndims]; i++) *(wg++) = 0.0; } { PDL_Double *wg = wgt2; for(i=0;i < in->dims[ndims]; i++) *(wg++) = 0.0; } /* * Calculate the original offset into the data array, to enable * delta calculations in the pixel loop * * i runs over dims; j holds the working integer index in the * current dim. * * This code matches the incrementation code at the bottom of the accumulation loop */ t_vio = 0; /* truncation-boundary violation count - don't bother if it is nonzero */ i_off = 0; for(i=0;i= in->dims[i]) { switch(bounds[i]) { case 0: /* no breakage allowed */ barf("%s","index out-of-bounds in map"); break; case 1: /* truncation */ t_vio++; /* fall through */ case 2: /* extension -- crop */ if(j<0) j=0; else //if(j>=in->dims[i]) j = in->dims[i] - 1; break; case 3: /* periodic -- mod it */ j %= in->dims[i]; if(j<0) j += in->dims[i]; break; case 4: /* mirror -- reflect off the edges */ j += in->dims[i]; j %= (in->dims[i]*2); if(j<0) j += in->dims[i]*2; j -= in->dims[i]; if(j<0) { j *= -1; j -= 1; } break; default: barf("%s", "Unknown boundary condition in map -- bug alert!"); break; } } i_off += in->dimincs[i] * j; } /* Initialize index stashes for later reference as we scan the footprint */ /* It's a pain in the ass to deal with boundaries, and doubly so at the */ /* end of a dimensional scan. So we stash the index location at the */ /* start of each dimensional scan here. When we finish incrementing */ /* through a particular dim, we pull its value back out of the stash. */ for(i=0;i 0) { if(beta >= blur) { alpha = 0; i = ndims; } else { beta *= zeta; lodex = beta; beta -= lodex; if(lodex > HANNING_LOOKUP_SIZE) lodex = HANNING_LOOKUP_SIZE; hidex = lodex+1; alpha *= hanning_lookup[hidex]*beta + hanning_lookup[lodex]*(1-beta); } /* end of interpolation branch */ } /* end of beta > 0 branch */ } /* end of dimension loop */ break; case 'H': /* This is the Hanning window rolloff with explicit calculation, preserved */ /* in case someone actually wants the slower longer method. */ alpha = 1; cp = tmp; for(i=0; i 1 ) { alpha = 0; i = ndims; } else alpha *= (0.5 + 0.5 * cos( dd * 3.1415926536 )); } break; case 'g': /* This is the Gaussian rolloff. It does lookup into a precalculated exponential. */ { PDL_Double sum = 0; cp = tmp; for(i=0; i GAUSSIAN_MAXVAL) { i = ndims; /* exit early if we're too far out */ alpha = 0; } } if( sum > GAUSSIAN_MAXVAL ) { alpha = 0; } else { int lodex,hidex; PDL_Double beta = fabs(zeta * sum); lodex = beta; beta -= lodex; hidex = lodex+1; alpha = gaussian_lookup[hidex]*beta + gaussian_lookup[lodex]*(1 - beta); } } break; case 'G': /* This is the Gaussian rolloff with explicit calculation, preserved */ /* in case someone actually wants the slower longer method. */ { PDL_Double sum = 0; cp = tmp; for(i=0; i 4) /* 2 pixels -- four half-widths */ i = ndims; /* exit early if this pixel is too far outside the footprint of the ideal point */ } if(sum > GAUSSIAN_MAXVAL) alpha = 0; else alpha = exp(-sum * 1.386294); /* Gaussian, rt(2)-pix HWHM */ } break; default: { char buf[80]; sprintf(buf,"This can't happen: method='%c'",method); barf("%s", buf); } } { /* convenience block -- accumulate the current point into the weighted sum. */ /* This is more than simple assignment because we have our own explicit poor */ /* man's threadloop here, so we accumulate each threaded element separately. */ $GENERIC() *dat = (($GENERIC() *)(in->data)) + i_off; PDL_Indx max = out->dims[ndims]; for( i=0; i < max; i++ ) { if( (badval==0) || (*dat != badval) ) { acc[i] += *dat * alpha; dat += in->dimincs[ndims]; wgt[i] += alpha; } wgt2[i] += alpha; // Accumulate what weight we would have with no bad values } } } /* end of t_vio check (i.e. of input accumulation) */ /* Advance input accumulation loop. */ /* We both increment the total vector and also advance the index. */ carry = 1; for(i=0; i 0 && j <= in->dims[i]-1 ) { /* Normal case -- just advance the input vector */ i_off += in->dimincs[i]; } else { /* Busted a boundary - either before or after. */ switch(bounds[i]){ case 0: /* no breakage allowed -- treat as truncation for interpolation */ case 1: /* truncation -- if we crossed the boundary mark ourselves out-of-bounds */ if( j == 0 ) t_vio--; else if( j == in->dims[i] ) t_vio++; break; case 2: /* extension -- do nothing (so the same input point is re-used) */ break; case 3: /* periodic -- advance and mod into the allowed range */ if((j % in->dims[i]) == 0) { i_off -= in->dimincs[i] * (in->dims[i]-1); } else { i_off += in->dimincs[i]; } break; case 4: /* mirror -- advance or retreat depending on phase */ j += in->dims[i]; j %= (in->dims[i]*2); j -= in->dims[i]; if( j!=0 && j!= -in->dims[i] ) { if(j<0) i_off -= in->dimincs[i]; else i_off += in->dimincs[i]; } break; } } /* Now check for carry */ if(ivec[i] <= psize) { /* Normal case -- copy the current offset to the faster-running dim stashes */ int k; for(k=0;k= in->dims[i] ) t_vio--; ivec[i] = -psize; j = ivec[i] + ibvec[i]; if( j < 0 || j >= in->dims[i] ) t_vio++; carry = 1; } else { ivec[i] = -psize; } } } /* End of counter-advance loop */ } while(carry==0); /* end of total data accumulation loop (termination condition has carry on last dim) */ { PDL_Double *ac = acc; PDL_Double *wg = wgt; PDL_Double *wg2 = wgt2; $GENERIC() *dat = out->data; /* Calculate output vector offset */ for(i=0;idimincs[i] * ovec[i]; if(!flux) { /* Flux flag is NOT set -- normal case. Copy the weighted accumulated data. */ for(i=0; i < out->dims[ndims]; i++) { if(*wg && (*wg2 / *wg) < 1.5 ) { *dat = *(ac++) / *(wg++); wg2++; } else { *dat = badval; ac++; wg++; wg2++; } dat += out->dimincs[ndims]; } } else { /* Flux flag is set - scale by the (unpadded) determinant of the Jacobian */ PDL_Double det = tmp[ndims*ndims]; for(i=0; i < out->dims[ndims]; i++) { if(*wg && (*wg2 / *wg) < 1.5 ) { *dat = *(ac++) / *(wg++) * det; wg2++; } else { *dat = badval; ac++; wg++; wg2++; } dat += out->dimincs[ndims]; } /* end of for loop */ } /* end of flux flag set conditional */ } /* end of convenience block */ /* End of code for normal pixels */ } else { /* The pixel was ludicrously huge -- just set this pixel to nan */ $GENERIC() *dat = out->data; for(i=0;idimincs[i] * ovec[i]; for(i=0;idims[ndims];i++) { *dat = badval; /* Should handle bad values too -- not yet */ dat += out->dimincs[ndims]; } } /* Increment the pixel counter */ { for(i=0; (idimincs[i+1]) && /* Funky pre-test increment */ (++(ovec[i]) >= out->dims[i]); /* Actual carry test */ i++) { ovec[i] = 0; map_ptr -= out->dims[i] * map->dimincs[i+1]; } } } while(i<<'+==EOD_map_doc==', =head2 match =for usage $b = $a->match($c); # Match $c's header and size $b = $a->match([100,200]); # Rescale to 100x200 pixels $b = $a->match([100,200],{rect=>1}); # Rescale and remove rotation/skew. =for ref Resample a scientific image to the same coordinate system as another. The example above is syntactic sugar for $b = $a->map(t_identity, $c, ...); it resamples the input PDL with the identity transformation in scientific coordinates, and matches the pixel coordinate system to $c's FITS header. There is one difference between match and map: match makes the C option to C default to 0, not 1. This only affects matching where autoscaling is required (i.e. the array ref example above). By default, that example simply scales $a to the new size and maintains any rotation or skew in its scientiic-to-pixel coordinate transform. =head2 map =for usage $b = $a->map($xform,[

: MATLAB: >> a = 12 a = 12 >> b = 23; % Suppress output. >> PDL Shell (perldl or pdl2): pdl> $a = 12 # No output. pdl> print $a # Print object. 12 pdl> p $a # "p" is a shorthand for "print" in the shell. 12 pdl> =back =head2 Creating Piddles =over 5 =item Variables in PDL Variables always start with the '$' sign. MATLAB: value = 42 PerlDL: $value = 42 =item Basic syntax Use the "pdl" constructor to create a new I. MATLAB: v = [1,2,3,4] PerlDL: $v = pdl [1,2,3,4] MATLAB: A = [ 1,2,3 ; 3,4,5 ] PerlDL: $A = pdl [ [1,2,3] , [3,4,5] ] =item Simple matrices MATLAB PDL ------ ------ Matrix of ones ones(5) ones 5,5 Matrix of zeros zeros(5) zeros 5,5 Random matrix rand(5) random 5,5 Linear vector 1:5 sequence 5 Notice that in PDL the parenthesis in a function call are often optional. It is important to keep an eye out for possible ambiguities. For example: pdl> p zeros 2, 2 + 2 Should this be interpreted as C or as C? Both are valid statements: pdl> p zeros(2,2) + 2 [ [2 2] [2 2] ] pdl> p zeros 2, (2+2) [ [0 0] [0 0] [0 0] [0 0] ] Rather than trying to memorize Perl's order of precedence, it is best to use parentheses to make your code unambiguous. =item Linearly spaced sequences MATLAB: >> linspace(2,10,5) ans = 2 4 6 8 10 PerlDL: pdl> p zeroes(5)->xlinvals(2,10) [2 4 6 8 10] B: Start with a 1-dimensional piddle of 5 elements and give it equally spaced values from 2 to 10. MATLAB has a single function call for this. On the other hand, PDL's method is more flexible: pdl> p zeros(5,5)->xlinvals(2,10) [ [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] ] pdl> p zeros(5,5)->ylinvals(2,10) [ [ 2 2 2 2 2] [ 4 4 4 4 4] [ 6 6 6 6 6] [ 8 8 8 8 8] [10 10 10 10 10] ] pdl> p zeros(3,3,3)->zlinvals(2,6) [ [ [2 2 2] [2 2 2] [2 2 2] ] [ [4 4 4] [4 4 4] [4 4 4] ] [ [6 6 6] [6 6 6] [6 6 6] ] ] =item Slicing and indices Extracting a subset from a collection of data is known as I. PDL and MATLAB have a similar syntax for slicing, but there are two important differences: 1) PDL indices start at 0, as in C and Java. MATLAB starts indices at 1. 2) In MATLAB you think "rows and columns". In PDL, think "x and y". MATLAB PerlDL ------ ------ >> A pdl> p $A A = [ 1 2 3 [1 2 3] 4 5 6 [4 5 6] 7 8 9 [7 8 9] ] ------------------------------------------------------- (row = 2, col = 1) (x = 0, y = 1) >> A(2,1) pdl> p $A(0,1) ans = [ 4 [4] ] ------------------------------------------------------- (row = 2 to 3, col = 1 to 2) (x = 0 to 1, y = 1 to 2) >> A(2:3,1:2) pdl> p $A(0:1,1:2) ans = [ 4 5 [4 5] 7 8 [7 8] ] =over 5 =item B When you write a stand-alone PDL program you have to include the L module. See the previous section "B" for more information. use PDL; # Import main PDL module. use PDL::NiceSlice; # Nice syntax for slicing. use PDL::AutoLoader; # MATLAB-like autoloader. $A = random 4,4; print $A(0,1); =back =back =head2 Matrix Operations =over 10 =item Matrix multiplication MATLAB: A * B PerlDL: $A x $B =item Element-wise multiplication MATLAB: A .* B PerlDL: $A * $B =item Transpose MATLAB: A' PerlDL: $A->transpose =back =head2 Functions that aggregate data Some functions (like C, C and C) aggregate data for an N-dimensional data set. This is a place where MATLAB and PDL take a different approach: =over 10 =item In MATLAB, these functions all work along one dimension. >> A = [ 1,5,4 ; 4,2,1 ] A = 1 5 4 4 2 1 >> max(A) ans = 4 5 4 >> max(A') ans = 5 4 If you want the maximum for the entire data set, you can use the special C notation which basically turns the entire data set into a single 1-dimensional vector. >> max(A(:)) ans = 5 >> A = ones(2,2,2,2) >> max(A(:)) ans = 1 =item PDL offers two functions for each feature. sum vs sumover avg vs average max vs maximum min vs minimum The B works over a dimension, while the B works over the entire piddle. pdl> p $A = pdl [ [1,5,4] , [4,2,1] ] [ [1 5 4] [4 2 1] ] pdl> p $A->maximum [5 4] pdl> p $A->transpose->maximum [4 5 4] pdl> p $A->max 5 pdl> p ones(2,2,2)->max 1 pdl> p ones(2,2,2,2)->max 1 =back =over 5 =item B Notice that PDL aggregates horizontally while MATLAB aggregates vertically. In other words: MATLAB PerlDL max(A) == $A->transpose->maximum max(A') == $A->maximum B: In MATLAB you think "rows and columns". In PDL, think "x and y". =back =head2 Higher dimensional data sets A related issue is how MATLAB and PDL understand data sets of higher dimension. MATLAB was designed for 1D vectors and 2D matrices. Higher dimensional objects ("N-D arrays") were added on top. In contrast, PDL was designed for N-dimensional piddles from the start. This leads to a few surprises in MATLAB that don't occur in PDL: =over 5 =item MATLAB sees a vector as a 2D matrix. MATLAB PerlDL ------ ------ >> vector = [1,2,3,4]; pdl> $vector = pdl [1,2,3,4] >> size(vector) pdl> p $vector->dims ans = 1 4 4 MATLAB sees C<[1,2,3,4]> as a 2D matrix (1x4 matrix). PDL sees it as a 1D vector: A single dimension of size 4. =item But MATLAB ignores the last dimension of a 4x1x1 matrix. MATLAB PerlDL ------ ------ >> A = ones(4,1,1); pdl> $A = ones 4,1,1 >> size(A) pdl> p $A->dims ans = 4 1 4 1 1 =item And MATLAB treats a 4x1x1 matrix differently from a 1x1x4 matrix. MATLAB PerlDL ------ ------ >> A = ones(1,1,4); pdl> $A = ones 1,1,4 >> size(A) pdl> p $A->dims ans = 1 1 4 1 1 4 =item MATLAB has no direct syntax for N-D arrays. pdl> $A = pdl [ [[1,2,3],[4,5,6]], [[2,3,4],[5,6,7]] ] pdl> p $A->dims 3 2 2 =item Feature support. In MATLAB, several features such as sparse matrix support are not available for N-D arrays. In PDL, just about any feature supported by 1D and 2D piddles, is equally supported by N-dimensional piddles. There is usually no distinction. =back =head2 Loop Structures Perl has many loop structures, but we will only show the one that is most familiar to MATLAB users: MATLAB PerlDL ------ ------ for i = 1:10 for $i (1..10) { disp(i) print $i endfor } =over 5 =item B Never use for-loops for numerical work. Perl's for-loops are faster than MATLAB's, but they both pale against a "vectorized" operation. PDL has many tools that facilitate writing vectorized programs. These are beyond the scope of this guide. To learn more, see: L, L, and L. Likewise, never use C<1..10> for numerical work, even outside a for-loop. C<1..10> is a Perl array. Perl arrays are designed for flexibility, not speed. Use I instead. To learn more, see the next section. =back =head2 Piddles vs Perl Arrays It is important to note the difference between a I and a Perl array. Perl has a general-purpose array object that can hold any type of element: @perl_array = 1..10; @perl_array = ( 12, "Hello" ); @perl_array = ( 1, 2, 3, \@another_perl_array, sequence(5) ); Perl arrays allow you to create powerful data structures (see B below), B. For that, use I: $pdl = pdl [ 1, 2, 3, 4 ]; $pdl = sequence 10_000_000; $pdl = ones 600, 600; For example: $points = pdl 1..10_000_000 # 4.7 seconds $points = sequence 10_000_000 # milliseconds B: You can use underscores in numbers (C<10_000_000> reads better than C<10000000>). =head2 Conditionals Perl has many conditionals, but we will only show the one that is most familiar to MATLAB users: MATLAB PerlDL ------ ------ if value > MAX if ($value > $MAX) { disp("Too large") print "Too large\n"; elseif value < MIN } elsif ($value < $MIN) { disp("Too small") print "Too small\n"; else } else { disp("Perfect!") print "Perfect!\n"; end } =over 5 =item B Here is a "gotcha": MATLAB: elseif PerlDL: elsif If your conditional gives a syntax error, check that you wrote your C's correctly. =back =head2 TIMTOWDI (There Is More Than One Way To Do It) One of the most interesting differences between PDL and other tools is the expressiveness of the Perl language. TIMTOWDI, or "There Is More Than One Way To Do It", is Perl's motto. Perl was written by a linguist, and one of its defining properties is that statements can be formulated in different ways to give the language a more natural feel. For example, you are unlikely to say to a friend: "While I am not finished, I will keep working." Human language is more flexible than that. Instead, you are more likely to say: "I will keep working until I am finished." Owing to its linguistic roots, Perl is the only programming language with this sort of flexibility. For example, Perl has traditional while-loops and if-statements: while ( ! finished() ) { keep_working(); } if ( ! wife_angry() ) { kiss_wife(); } But it also offers the alternative B and B statements: until ( finished() ) { keep_working(); } unless ( wife_angry() ) { kiss_wife(); } And Perl allows you to write loops and conditionals in "postfix" form: keep_working() until finished(); kiss_wife() unless wife_angry(); In this way, Perl often allows you to write more natural, easy to understand code than is possible in more restrictive programming languages. =head2 Functions PDL's syntax for declaring functions differs significantly from MATLAB's. MATLAB PerlDL ------ ------ function retval = foo(x,y) sub foo { retval = x.**2 + x.*y my ($x, $y) = @_; endfunction return $x**2 + $x*$y; } Don't be intimidated by all the new syntax. Here is a quick run through a function declaration in PDL: 1) "B" stands for "subroutine". 2) "B" declares variables to be local to the function. 3) "B<@_>" is a special Perl array that holds all the function parameters. This might seem like a strange way to do functions, but it allows you to make functions that take a variable number of parameters. For example, the following function takes any number of parameters and adds them together: sub mysum { my ($i, $total) = (0, 0); for $i (@_) { $total += $i; } return $total; } 4) You can assign values to several variables at once using the syntax: ($a, $b, $c) = (1, 2, 3); So, in the previous examples: # This declares two local variables and initializes them to 0. my ($i, $total) = (0, 0); # This takes the first two elements of @_ and puts them in $x and $y. my ($x, $y) = @_; 5) The "B" statement gives the return value of the function, if any. =head1 ADDITIONAL FEATURES =head2 ASCII File IO To read data files containing whitespace separated columns of numbers (as would be read using the MATLAB I command) one uses the PDL I in L. For a general review of the IO functionality available in PDL, see the documentation for L, e.g., C in the I shell or C< pdldoc PDL::IO > from the shell command line. =head2 Data structures To create complex data structures, MATLAB uses "I" and "I". Perl's arrays and hashes offer similar functionality but are more powerful and flexible. This section is only a quick overview of what Perl has to offer. To learn more about this, please go to L or run the command C. =over 5 =item Arrays Perl arrays are similar to MATLAB's cell arrays, but more flexible. For example, in MATLAB, a cell array is still fundamentally a matrix. It is made of rows, and rows must have the same length. MATLAB ------ array = {1, 12, 'hello'; rand(3, 2), ones(3), 'junk'} => OK array = {1, 12, 'hello'; rand(3, 2), ones(3) } => ERROR A Perl array is a general purpose, sequential data structure. It can contain any data type. PerlDL ------ @array = ( [1, 12, 'hello'] , [ random(3,2), ones(3,3), 'junk' ] ) => OK @array = ( [1, 12, 'hello'] , [ random(3,2), ones(3,3) ] ) => OK @array = ( 5 , {'name' => 'Mike'} , [1, 12, 'hello'] ) => OK Notice that Perl array's start with the "@" prefix instead of the "$" used by piddles. I or run the command C.> =item Hashes Perl hashes are similar to MATLAB's structure arrays: MATLAB ------ >> drink = struct('type', 'coke', 'size', 'large', 'myarray', {1,2,3}) >> drink.type = 'sprite' >> drink.price = 12 % Add new field to structure array. PerlDL ------ pdl> %drink = ( type => 'coke' , size => 'large', mypiddle => ones(3,3,3) ) pdl> $drink{type} = 'sprite' pdl> $drink{price} = 12 # Add new field to hash. Notice that Perl hashes start with the "%" prefix instead of the "@" for arrays and "$" used by piddles. I or run the command C.> =back =head2 Performance PDL has powerful performance features, some of which are not normally available in numerical computation tools. The following pages will guide you through these features: =over 5 =item L B: Beginner This beginner tutorial covers the standard "vectorization" feature that you already know from MATLAB. Use this page to learn how to avoid for-loops to make your program more efficient. =item L B: Intermediate PDL's "vectorization" feature goes beyond what most numerical software can do. In this tutorial you'll learn how to "thread" over higher dimensions, allowing you to vectorize your program further than is possible in MATLAB. =item Benchmarks B: Intermediate Perl comes with an easy to use benchmarks module to help you find how long it takes to execute different parts of your code. It is a great tool to help you focus your optimization efforts. You can read about it online (L) or through the command C. =item L B: Advanced PDL's Pre-Processor is one of PDL's most powerful features. You write a function definition in special markup and the pre-processor generates real C code which can be compiled. With PDL:PP you get the full speed of native C code without having to deal with the full complexity of the C language. =back =head2 Plotting PDL has full-featured plotting abilities. Unlike MATLAB, PDL relies more on third-party libraries (pgplot and PLplot) for its 2D plotting features. Its 3D plotting and graphics uses OpenGL for performance and portability. PDL has three main plotting modules: =over 5 =item L B: Plotting 2D functions and data sets. This is an interface to the venerable PGPLOT library. PGPLOT has been widely used in the academic and scientific communities for many years. In part because of its age, PGPLOT has some limitations compared to newer packages such as PLplot (e.g. no RGB graphics). But it has many features that still make it popular in the scientific community. =item L B: Plotting 2D functions as well as 2D and 3D data sets. This is an interface to the PLplot plotting library. PLplot is a modern, open source library for making scientific plots. It supports plots of both 2D and 3D data sets. PLplot is best supported for unix/linux/macosx platforms. It has an active developers community and support for win32 platforms is improving. =item L B: Plotting 3D functions. The native PDL 3D graphics library using OpenGL as a backend for 3D plots and data visualization. With OpenGL, it is easy to manipulate the resulting 3D objects with the mouse in real time. =back =head2 Writing GUIs Through Perl, PDL has access to all the major toolkits for creating a cross platform graphical user interface. One popular option is wxPerl (L). These are the Perl bindings for wxWidgets, a powerful GUI toolkit for writing cross-platform applications. wxWidgets is designed to make your application look and feel like a native application in every platform. For example, the Perl IDE B is written with wxPerl. =head2 Simulink Simulink is a graphical dynamical system modeler and simulator. It can be purchased separately as an add-on to MATLAB. PDL and Perl do not have a direct equivalent to MATLAB's Simulink. If this feature is important to you, then take a look at B: L Scilab is another numerical analysis software. Like PDL, it is free and open source. It doesn't have PDL's unique features, but it is very similar to MATLAB. Scilab comes with B (previously Scicos), a graphical system modeler and simulator similar to Simulink. =head1 COPYRIGHT Copyright 2010 Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ =over 5 =item B I'd like to thank David Mertens, Chris Marshall and Sigrid Carrera for their immense help reviewing earlier drafts of this guide. Without their hours of work, this document would not be remotely as useful to MATLAB users as it is today. =back PDL-2.018/Basic/Pod/Modules.pod0000644060175006010010000001766013036512174014267 0ustar chmNone=head1 NAME PDL::Modules - A guide to PDL's module reference. =head1 DESCRIPTION This page serves as a table of contents for PDL's module documentation. This page does not list every single PDL module. It only shows the ones intended for PDL users, while omitting those which are deemed "for internal use only". If you wish to see a comprehensive list of all documentation, please see the L page. =head1 LOOKING FOR A FUNCTION? If you want to search for a function name, you should use the PDL shell along with the "help" or "apropos" command (to do a fuzzy search). For example: pdl> apropos xval xlinvals X axis values between endpoints (see xvals). xlogvals X axis values logarithmicly spaced... xvals Fills a piddle with X index values... yvals Fills a piddle with Y index values. See the CAVEAT for xvals. zvals Fills a piddle with Z index values. See the CAVEAT for xvals. To learn more about the PDL shell, see L or L. =head1 FOUNDATION =over 5 =item L or L Learn about the PDL shell. =back =head2 Functions =over 5 =item L Core module (e.g. creating piddles). =item L Simplified interface to the more general PDL::Primitive. =item L Basic operators (e.g. arithmetic, comparisons, etc.). =item L Functions that accumulate along a dimension (e.g. sum, max). =back =head2 Other Features =over 5 =item L MATLAB-style function autoloader. =item L Indexing and slices. How to access a subset of a piddle. =item L Nicer syntax for slices. =back =head1 MISCELLANEOUS =over 5 =item L Fundamental operations on piddles. =item L Complex numbers. =item L Bad value support. =item L A 'reduce' function for PDL. =item L Minimum PDL module OO loader. =item L Minimum PDL module function loader. =item L Extended Mathematical Operators. =item L Interpolation-related functions. =back =head1 GRAPHICS =over 5 =item L PGPLOT library. =item L PLplot library. =back =head2 3D Graphics =over 5 =item L 3D graphics core module. =item L Helper routines for 3D graphics. =item L 3D surface contours. =back =head2 Helper Modules =over 5 =item L Look-up tables. =item L Display images on IIS devices. =item L Derive data limits for display purposes. =back =head1 IMAGE PROCESSING =over 5 =item L Compression utilities. =item L 2-dimmensional image processing. =item L N-dimmensional image processing. =item L RGB image data handling. =back =head1 NUMERICAL METHODS =over 5 =item L Fast Fourier Transform (native implementation). =item L PDL interface to the FFTW library. =item L Linear predictive filtering. =item L Linear filtering. =item L Simplex optimization routines. =item L PDL interface to the Minuit library. =item L PDL interface to the Slatec library. =back =head1 COORDINATE TRANSFORMATIONS =over 5 =item L Coordinate transforms, image warping, and N-D functions. =item L Cartographic projections. =item L PDL interface to the Proj4 projection library. =back =head1 IO FUNCTIONS =over 5 =item L Overview of IO functions. =item L Data dumper. =item L Fast storage format (outdated). =item L Flexible storage format. =item L Misc IO routines. =item L Support for Perl's 'Storable' module. =back =head2 Image Formats =over 5 =item L PDL support for FITS images. =item L PDL support for PNM images. =item L PDL interface to the GD image library. =item L PDL interface to the HDH4 image library. =item L PDL interface to the NetPBM image library. =item L PDL interface to the Starlink image library. Available as a separate CPAN download. =back =head1 2D MATRICES =over 5 =item L Convenience class for 2D matrix work. =item L Additional matrix operators. =back =head1 GNU SCIENTIFIC LIBRARY =over 5 =item L Numerical differentiation. =item L Numerical integration. =item L Interpolation. =item L Multidimensional root-finding. =item L RNG and randist. =back =head2 Special Functions =over 5 =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =back =head1 FITTING FUNCTIONS =over 5 =item L Fit gaussian curves. =item L Fit polynomials. =item L Fit linear combinations of functions. =item L Fit functions using the Levenberg-Marquardt algorithm. =back =head1 ADVANCED =over 5 =item L PDL debugger. =item L Manage many piddles through a disk cache. =item L Call external functions. =item L If you want to sub-class from PDL (note: incomplete). =back =head1 COPYRIGHT Copyright 2010 Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.018/Basic/Pod/Objects.pod0000644060175006010010000000732412562522363014250 0ustar chmNone=head1 NAME PDL::Objects -- Object-Orientation, what is it and how to exploit it =head1 DESCRIPTION This still needs to be written properly. [Also, is there a good reason we don't recommend storing extra object data in the header hash?] =head2 Inheritance There are basically two reasons for subclassing piddles. The first is simply that you want to be able to use your own routines like $piddle->something() but don't want to mess up the PDL namespace (a worthy goal, indeed!). The other is that you wish to provide special handling of some functions or more information about the data the piddle contains. In the first case, you can do with package BAR; @ISA=qw/PDL/; sub foo {my($this) = @_; fiddle;} package main; $a = PDL::pdl(BAR,5); $a->foo(); However, because a PDL object is an opaque reference to a C struct, it is not possible to extend the PDL class by e.g. extra data via subclassing. To circumvent this problem PerlDL has built-in support to extent the PDL class via the I relation for blessed hashes. You can get the I behave like I simply in that you assign the C object to the attribute named PDL and redefine the method initialize(). package FOO; @FOO::ISA = qw(PDL); sub initialize { my $class = shift; my $self = { creation_time => time(), # necessary extension :-) PDL => null, # used to store PDL object }; bless $self, $class; } All PDL constructors will call initialize() to make sure that your extensions are added by I PDL constructors automatically. The C attribute is used by perlDL to store the PDL object and all PDL methods use this attribute automatically if they are called with a blessed hash reference instead of a PDL object (a blessed scalar). Do remember that if you subclass a class that is subclassed from a piddle, you need to call SUPER::initialize. NEED STUFF ABOUT CODE REFs!! =head2 Examples You can find some simple examples of PDL subclassing in the PDL distribution test-case files. Look in C, C, etc. =head2 Output Auto-Creation and Subclassed Objects For PDL Functions where the output is created and returned, PDL will either call the subclassed object's C or C method to create the output object. (See L for a discussion on Output Auto-Creation.) This behavior is summarized as follows: =over 1 =item * For I functions, defined as having a signature of func( a(), [o]b() ) PDL will call $a->copy to create the output object. In the spirit of the Perl philosophy of making I, This behavior enables PDL-subclassed objects to be written without having to overload the many simple PDL functions in this category. The file t/subclass4.t in the PDL Distribution tests for this behavior. See that file for an example. =item * For other functions, PDL will call $class->initialize to create the output object. Where $class is the class name of the first argument supplied to the function. For these more complex cases, it is difficult to second-guess the subclassed object's designer to know if a C or a C is appropriate. So for these cases, $class->initialize is called by default. If this is not appropriate for you, overload the function in your subclass and do whatever is appropriate is the overloaded function's code. =back =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu) and Christian Soeller (c.soeller@auckland.ac.nz) 2000. Commercial reproduction of this documentation in a different format is forbidden. =cut PDL-2.018/Basic/Pod/ParallelCPU.pod0000644060175006010010000001551512562522363014764 0ustar chmNone=head1 NAME PDL::ParallelCPU - Parallel Processor MultiThreading Support in PDL (Experimental) =head1 DESCRIPTION PDL has support (currently experimental) for splitting up numerical processing between multiple parallel processor threads (or pthreads) using the I and I functions. This can improve processing performance (by greater than 2-4X in most cases) by taking advantage of multi-core and/or multi-processor machines. =head1 SYNOPSIS use PDL; # Set target of 4 parallel pthreads to create, with a lower limit of # 5Meg elements for splitting processing into parallel pthreads. set_autopthread_targ(4); set_autopthread_size(5); $a = zeroes(5000,5000); # Create 25Meg element array $b = $a + 5; # Processing will be split up into multiple pthreads # Get the actual number of pthreads for the last # processing operation. $actualPthreads = get_autopthread_actual(); =head1 Terminology The use of the term I can be confusing with PDL, because it can refer to I, as defined in the L docs, or to I. To reduce confusion with the existing PDL threading terminology, this document uses B to refer to I, which is the use of multiple processor threads to split up numerical processing into parallel operations. =head1 Functions that control PDL PThreads This is a brief listing and description of the PDL pthreading functions, see the L docs for detailed information. =over 5 =item set_autopthread_targ Set the target number of processor-threads (pthreads) for multi-threaded processing. Setting auto_pthread_targ to 0 means that no pthreading will occur. See L for details. =item set_autopthread_size Set the minimum size (in Meg-elements or 2**20 elements) of the largest PDL involved in a function where auto-pthreading will be performed. For small PDLs, it probably isn't worth starting multiple pthreads, so this function is used to define a minimum threshold where auto-pthreading won't be attempted. See L for details. =item get_autopthread_actual Get the actual number of pthreads executed for the last pdl processing function. See L for details. =back =head1 Global Control of PDL PThreading using Environment Variables PDL PThreading can be globally turned on, without modifying existing code by setting environment variables B and B before running a PDL script. These environment variables are checked when PDL starts up and calls to I and I functions made with the environment variable's values. For example, if the environment var B is set to 3, and B is set to 10, then any pdl script will run as if the following lines were at the top of the file: set_autopthread_targ(3); set_autopthread_size(10); =head1 How It Works The auto-pthreading process works by analyzing threaded array dimensions in PDL operations and splitting up processing based on the thread dimension sizes and desired number of pthreads (i.e. the pthread target or pthread_targ). The offsets and increments that PDL uses to step thru the data in memory are modified for each pthread so each one sees a different set of data when performing processing. B $a = sequence(20,4,3); # Small 3-D Array, size 20,4,3 # Setup auto-pthreading: set_autopthread_targ(2); # Target of 2 pthreads set_autopthread_size(0); # Zero so that the small PDLs in this example will be pthreaded # This will be split up into 2 pthreads $c = maximum($a); For the above example, the I function has a signature of C<(a(n); [o]c())>, which means that the first dimension of $a (size 20) is a I dimension of the I function. The other dimensions of $a (size 4,3) are I dimensions (i.e. will be threaded-over in the I function. The auto-pthreading algorithm examines the threaded dims of size (4,3) and picks the 4 dimension, since it is evenly divisible by the autopthread_targ of 2. The processing of the maximum function is then split into two pthreads on the size-4 dimension, with dim indexes 0,2 processed by one pthread and dim indexes 1,3 processed by the other pthread. =head1 Limitations =head2 Must have POSIX Threads Enabled Auto-PThreading only works if your PDL installation was compiled with POSIX threads enabled. This is normally the case if you are running on linux, or other unix variants. =head2 Non-Threadsafe Code Not all the libraries that PDL intefaces to are thread-safe, i.e. they aren't written to operate in a multi-threaded environment without crashing or causing side-effects. Some examples in the PDL core is the I function and the I functions. To operate properly with these types of functions, the PPCode flag B has been introduced to indicate a function as I being pthread-safe. See L docs for details. =head2 Size of PDL Dimensions and PThread Target Due to the way a PDL is split-up for operation using multiple pthreads, the size of a dimension must be evenly divisible by the pthread target. For example, if a PDL has threaded dimension sizes of (4,3,3) and the I has been set to 2, then the first threaded dimension (size 4) will be picked to be split up into two pthreads of size 2 and 2. However, if the threaded dimension sizes are (3,3,3) and the I is still 2, then pthreading won't occur, because no threaded dimensions are divisible by 2. The algorithm that picks the actual number of pthreads has some smarts (but could probably be improved) to adjust down from the I to get a number of pthreads that can evenly divide one of the threaded dimensions. For example, if a PDL has threaded dimension sizes of (9,2,2) and the I is 4, the algorithm will see that no dimension is divisible by 4, then adjust down the target to 3, resulting in splitting up the first threaded dimension (size 9) into 3 pthreads. =head2 Speed improvement might be less than you expect. If you have a 8 core machine and call I with 8 to generate 8 parallel pthreads, you probably won't get a 8X improvement in speed, due to memory bandwidth issues. Even though you have 8 separate CPUs crunching away on data, you will have (for most common machine architectures) common RAM that now becomes your bottleneck. For simple calculations (e.g simple additions) you can run into a performance limit at about 4 pthreads. For more complex calculations the limit will be higher. =head1 COPYRIGHT Copyright 2011 John Cerney. You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.018/Basic/Pod/Philosophy.pod0000644060175006010010000001630012562522363015007 0ustar chmNone=head1 NAME PDL::Philosophy -- Why did we write PDL? =head1 DESCRIPTION Some history from the creator of PDL, leading into the philosophy and motivation behind this data language. This is an attempt to summarize some of the common spirit between pdl developers in order to answer the question "Why PDL"? =head2 The Start of PDL B<"Why is it that we entertain the belief that for every purpose odd numbers are the most effectual?"> - I The PDL project began in February 1996, when I decided to experiment with writing my own `Data Language'. I am an astronomer. My day job involves a lot of analysis of digital data accumulated on many nights observing on telescopes around the world. Such data might for example be images containing millions of pixels and thousands of images of distant stars and galaxies. Or more abstrusely, many hundreds of digital spectra revealing the secrets of the composition and properties of these distant objects. Obviously many astronomers have dealt with these problems before, and a large amount of software has been constructed to facilitate their analysis. However, like many of my colleagues, I was constantly frustrated by the lack of generality and flexibility of these programs and the difficulty of doing anything out of the ordinary quickly and easily. What I wanted had a name: "Data Language", i.e. a language which allowed the manipulation of large amounts of data with simple arithmetic expressions. In fact some commercial software worked like this, and I was impressed with the capabilities but not with the price tag. And I thought I could do better. As a fairly computer literate astronomer (read "nerd" or "geek" according to your local argot) I was very familiar with "Perl", a computer language which now seems to fill the shelves of many bookstores around the world. I was impressed by its power and flexibility, and especially its ease of use. I had even explored the depths of its internals and written an interface to allow graphics, the ease with which I could then create charts and graphs, for my papers, was refreshing. Version 5 of Perl had just been released, and I was fascinated by the new features available. Especially the support of arbitrary data structures (or "objects" in modern parlance) and the ability to "overload" operators - i.e. make mathematical symbols like C<+-*/> do whatever you felt like. It seemed to me it ought to be possible to write an extension to Perl where I could play with my data in a general way: for example using the maths operators manipulate whole images at once. Well one slow night at an observatory I just thought I would try a little experiment. In a bored moment I fired up a text editor and started to create a file called `PDL.xs' - a Perl extension module to manipulate data vectors. A few hours later I actually had something half decent working, where I could add two images in the Perl language, B This was something I could not let rest, and it probably cost me one or two scientific papers worth of productivity. A few weeks later the Perl Data Language version 1.0 was born. It was a pretty bare infant: very little was there apart from the basic arithmetic operators. But encouraged I made it available on the Internet to see what people thought. Well people were fairly critical - among the most vocal were Tuomas Lukka and Christian Soeller. Unfortunately for them they were both Perl enthusiasts too and soon found themselves improving my code to implement all the features they thought PDL ought to have and I had heinously neglected. PDL is a prime example of that modern phenomenon of authoring large free software packages via the Internet. Large numbers of people, most of whom have never met, have made contributions ranging for core functionality to large modules to the smallest of bug patches. PDL version 2.0 is now here (though it should perhaps have been called version 10 to reflect the amount of growth in size and functionality) and the phenomenon continues. I firmly believe that PDL is a great tool for tackling general problems of data analysis. It is powerful, fast, easy to add too and freely available to anyone. I wish I had had it when I was a graduate student! I hope you too will find it of immense value, I hope it will save you from heaps of time and frustration in solving complex problems. Of course it can't do everything, but it provides the framework, the hammers and the nails for building solutions without having to reinvent wheels or levers. --- Karl Glazebook, the creator of PDL =head2 Major ideas The first tenet of our philosophy is the "free software" idea: software being free has several advantages (less bugs because more people see the code, you can have the source and port it to your own working environment with you, ... and of course, that you don't need to pay anything). The second idea is a pet peeve of many: many languages like Matlab are pretty well suited for their specific tasks but for a different application, you need to change to an entirely different tool and regear yourself mentally. Not to speak about doing an application that does two things at once... Because we use Perl, we have the power and ease of Perl syntax, regular expressions, hash tables, etc. at our fingertips at all times. By extending an existing language, we start from a much healthier base than languages like Matlab which have grown into existence from a very small functionality at first and expanded little by little, making things look badly planned. We stand by the Perl sayings: "simple things should be simple but complicated things should be possible" and "There is more than one way to do it" (TIMTOWTDI). The third idea is interoperability: we want to be able to use PDL to drive as many tools as possible, we can connect to OpenGL or Mesa for graphics or whatever. There isn't anything out there that's really satisfactory as a tool and can do everything we want easily. And be portable. The fourth idea is related to C and is Tuomas's personal favorite: code should only specify as little as possible redundant info. If you find yourself writing very similar-looking code much of the time, all that code could probably be generated by a simple Perl script. The PDL C preprocessor takes this to an extreme. =head2 Minor goals and purposes We want speed. Optimally, it should ultimately (e.g. with the Perl compiler) be possible to compile C subs to C and obtain the top vectorized speeds on supercomputers. Also, we want to be able to calculate things at near top speed from inside Perl, by using dataflow to avoid memory allocation and deallocation (the overhead should ultimately be only a little over one indirect function call plus couple of ifs per function in the pipe). =head2 Go on, try it! Well, that's the philosophy behind PDL - speed, conciseness, free, expandable, and integrated with the wide base of modules and libraries that Perl provides. Feel free to download it, install it, run through some of the tutorials and introductions and have a play with it. Enjoy! =head1 AUTHOR Added Karl Glazebrook (2001) contributions by Matthew Kenworthy Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu). Redistribution in the same form is allowed but reprinting requires a permission from the author. PDL-2.018/Basic/Pod/PP.pod0000644060175006010010000025724313107360371013200 0ustar chmNonepackage PDL::PP; __END__ =head1 NAME PDL::PP - Generate PDL routines from concise descriptions =head1 SYNOPSIS e.g. pp_def( 'sumover', Pars => 'a(n); [o]b();', Code => q{ double tmp=0; loop(n) %{ tmp += $a(); %} $b() = tmp; }, ); pp_done(); =head1 FUNCTIONS Here is a quick reference list of the functions provided by PDL::PP. =head2 pp_add_boot =for ref Add code to the BOOT section of generated XS file =head2 pp_add_exported =for ref Add functions to the list of exported functions =head2 pp_add_isa =for ref Add entries to the @ISA list =head2 pp_addbegin =for ref Sets code to be added at the top of the generate .pm file =head2 pp_addhdr =for ref Add code and includes to C section of the generated XS file =head2 pp_addpm =for ref Add code to the generated .pm file =head2 pp_addxs =for ref Add extra XS code to the generated XS file =head2 pp_beginwrap =for ref Add BEGIN-block wrapping to code for the generated .pm file =head2 pp_bless =for ref Sets the package to which the XS code is added (default is PDL) =head2 pp_boundscheck =for ref Control state of PDL bounds checking activity =head2 pp_core_importList =for ref Specify what is imported from PDL::Core =head2 pp_def =for ref Define a new PDL function =head2 pp_deprecate_module =for ref Add runtime and POD warnings about a module being deprecated =head2 pp_done =for ref Mark the end of PDL::PP definitions in the file =head2 pp_export_nothing =for ref Clear out the export list for your generated module =head2 pp_line_numbers =for ref Add line number information to simplify debugging of PDL::PP code =head2 pp_setversion =for ref Set the version for .pm and .xs files =head1 OVERVIEW Why do we need PP? Several reasons: firstly, we want to be able to generate subroutine code for each of the PDL datatypes (PDL_Byte, PDL_Short, etc). AUTOMATICALLY. Secondly, when referring to slices of PDL arrays in Perl (e.g. C<< $a->slice('0:10:2,:') >> or other things such as transposes) it is nice to be able to do this transparently and to be able to do this 'in-place' - i.e, not to have to make a memory copy of the section. PP handles all the necessary element and offset arithmetic for you. There are also the notions of threading (repeated calling of the same routine for multiple slices, see L) and dataflow (see L) which use of PP allows. In much of what follows we will assume familiarity of the reader with the concepts of implicit and explicit threading and index manipulations within PDL. If you have not yet heard of these concepts or are not very comfortable with them it is time to check L. As you may appreciate from its name PDL::PP is a Pre-Processor, i.e. it expands code via substitutions to make real C-code. Technically, the output is XS code (see I) but that is very close to C. So how do you use PP? Well for the most part you just write ordinary C code except for special PP constructs which take the form: $something(something else) or: PPfunction %{ %} The most important PP construct is the form C<$array()>. Consider the very simple PP function to sum the elements of a 1D vector (in fact this is very similar to the actual code used by 'sumover'): pp_def('sumit', Pars => 'a(n); [o]b();', Code => q{ double tmp; tmp = 0; loop(n) %{ tmp += $a(); %} $b() = tmp; } ); What's going on? The C<< Pars => >> line is very important for PP - it specifies all the arguments and their dimensionality. We call this the I of the PP function (compare also the explanations in L). In this case the routine takes a 1-D function as input and returns a 0-D scalar as output. The C<$a()> PP construct is used to access elements of the array a(n) for you - PP fills in all the required C code. You will notice that we are using the C single-quote operator. This is not an accident. You generally want to use single quotes to denote your PP Code sections. PDL::PP uses C<$var()> for its parsing and if you don't use single quotes, Perl will try to interpolate C<$var()>. Also, using the single quote C operator with curly braces makes it look like you are creating a code block, which is What You Mean. (Perl is smart enough to look for nested curly braces and not close the quote until it finds the matching curly brace, so it's safe to have nested blocks.) Under other circumstances, such as when you're stitching together a Code block using string concatenations, it's often easiest to use real single quotes as Code => 'something'.$interpolatable.'somethingelse;' In the simple case here where all elements are accessed the PP construct C is used to loop over all elements in dimension C. Note this feature of PP: ALL DIMENSIONS ARE SPECIFIED BY NAME. This is made clearer if we avoid the PP loop() construct and write the loop explicitly using conventional C: pp_def('sumit', Pars => 'a(n); [o]b();', Code => q{ PDL_Indx i,n_size; double tmp; n_size = $SIZE(n); tmp = 0; for(i=0; ii); } $b() = tmp; }, ); which does the same as before, but is more long-winded. You can see to get element C of a() we say C<< $a(n=>i) >> - we are specifying the dimension by name C. In 2D we might say: Pars=>'a(m,n);', ... tmp += $a(m=>i,n=>j); ... The syntax C<< m=>i >> borrows from Perl hashes, which are in fact used in the implementation of PP. One could also say C<< $a(n=>j,m=>i) >> as order is not important. You can also see in the above example the use of another PP construct - C<$SIZE(n)> to get the length of the dimension C. It should, however, be noted that you shouldn't write an explicit C-loop when you could have used the PP C construct since PDL::PP checks automatically the loop limits for you, usage of C makes the code more concise, etc. But there are certainly situations where you need explicit control of the loop and now you know how to do it ;). To revisit 'Why PP?' - the above code for sumit() will be generated for each data-type. It will operate on slices of arrays 'in-place'. It will thread automatically - e.g. if a 2D array is given it will be called repeatedly for each 1D row (again check L for the details of threading). And then b() will be a 1D array of sums of each row. We could call it with $a->xchg(0,1) to sum the columns instead. And Dataflow tracing etc. will be available. You can see PP saves the programmer from writing a lot of needlessly repetitive C-code -- in our opinion this is one of the best features of PDL making writing new C subroutines for PDL an amazingly concise exercise. A second reason is the ability to make PP expand your concise code definitions into different C code based on the needs of the computer architecture in question. Imagine for example you are lucky to have a supercomputer at your hands; in that case you want PDL::PP certainly to generate code that takes advantage of the vectorising/parallel computing features of your machine (this a project for the future). In any case, the bottom line is that your unchanged code should still expand to working XS code even if the internals of PDL changed. Also, because you are generating the code in an actual Perl script, there are many fun things that you can do. Let's say that you need to write both sumit (as above) and multit. With a little bit of creativity, we can do for({Name => 'sumit', Init => '0', Op => '+='}, {Name => 'multit', Init => '1', Op => '*='}) { pp_def($_->{Name}, Pars => 'a(n); [o]b();', Code => ' double tmp; tmp = '.$_->{Init}.'; loop(n) %{ tmp '.$_->{Op}.' $a(); %} $b() = tmp; '); } which defines both the functions easily. Now, if you later need to change the signature or dimensionality or whatever, you only need to change one place in your code. Yeah, sure, your editor does have 'cut and paste' and 'search and replace' but it's still less bothersome and definitely more difficult to forget just one place and have strange bugs creep in. Also, adding 'orit' (bitwise or) later is a one-liner. And remember, you really have Perl's full abilities with you - you can very easily read any input file and make routines from the information in that file. For simple cases like the above, the author (Tjl) currently favors the hash syntax like the above - it's not too much more characters than the corresponding array syntax but much easier to understand and change. We should mention here also the ability to get the pointer to the beginning of the data in memory - a prerequisite for interfacing PDL to some libraries. This is handled with the C<$P(var)> directive, see below. When starting work on a new pp_def'ined function, if you make a mistake, you will usually find a pile of compiler errors indicating line numbers in the generated XS file. If you know how to read XS files (or if you want to learn the hard way), you could open the generated XS file and search for the line number with the error. However, a recent addition to PDL::PP helps report the correct line number of your errors: C. Working with the original summit example, if you had a mis-spelling of tmp in your code, you could change the (erroneous) code to something like this and the compiler would give you much more useful information: pp_def('sumit', Pars => 'a(n); [o]b();', Code => pp_line_numbers(__LINE__, q{ double tmp; tmp = 0; loop(n) %{ tmp += $a(); %} $b() = rmp; }) ); For the above situation, my compiler tells me: ... test.pd:15: error: 'rmp' undeclared (first use in this function) ... In my example script (called test.pd), line 15 is exactly the line at which I made my typo: C instead of C. So, after this quick overview of the general flavour of programming PDL routines using PDL::PP let's summarise in which circumstances you should actually use this preprocessor/precompiler. You should use PDL::PP if you want to =over 3 =item * interface PDL to some external library =item * write some algorithm that would be slow if coded in Perl (this is not as often as you think; take a look at threading and dataflow first). =item * be a PDL developer (and even then it's not obligatory) =back =head1 WARNING Because of its architecture, PDL::PP can be both flexible and easy to use on the one hand, yet exuberantly complicated at the same time. Currently, part of the problem is that error messages are not very informative and if something goes wrong, you'd better know what you are doing and be able to hack your way through the internals (or be able to figure out by trial and error what is wrong with your args to C). Although work is being done to produce better warnings, do not be afraid to send your questions to the mailing list if you run into trouble. =head1 DESCRIPTION Now that you have some idea how to use C to define new PDL functions it is time to explain the general syntax of C. C takes as arguments first the name of the function you are defining and then a hash list that can contain various keys. Based on these keys PP generates XS code and a .pm file. The function C (see example in the SYNOPSIS) is used to tell PDL::PP that there are no more definitions in this file and it is time to generate the .xs and .pm file. As a consequence, there may be several pp_def() calls inside a file (by convention files with PP code have the extension .pd or .pp) but generally only one pp_done(). There are two main different types of usage of pp_def(), the 'data operation' and 'slice operation' prototypes. The 'data operation' is used to take some data, mangle it and output some other data; this includes for example the '+' operation, matrix inverse, sumover etc and all the examples we have talked about in this document so far. Implicit and explicit threading and the creation of the result are taken care of automatically in those operations. You can even do dataflow with C, C, etc (don't be dismayed if you don't understand the concept of dataflow in PDL very well yet; it is still very much experimental). The 'slice operation' is a different kind of operation: in a slice operation, you are not changing any data, you are defining correspondences between different elements of two piddles (examples include the index manipulation/slicing function definitions in the file F that is part of the PDL distribution; but beware, this is not introductory level stuff). If PDL was compiled with support for bad values (i.e. C 1>), then additional keys are required for C, as explained below. If you are just interested in communicating with some external library (for example some linear algebra/matrix library), you'll usually want the 'data operation' so we are going to discuss that first. =head1 Data operation =head2 A simple example In the data operation, you must know what dimensions of data you need. First, an example with scalars: pp_def('add', Pars => 'a(); b(); [o]c();', Code => '$c() = $a() + $b();' ); That looks a little strange but let's dissect it. The first line is easy: we're defining a routine with the name 'add'. The second line simply declares our parameters and the parentheses mean that they are scalars. We call the string that defines our parameters and their dimensionality the I of that function. For its relevance with regard to threading and index manipulations check the L man page. The third line is the actual operation. You need to use the dollar signs and parentheses to refer to your parameters (this will probably change at some point in the future, once a good syntax is found). These lines are all that is necessary to actually define the function for PDL (well, actually it isn't; you additionally need to write a Makefile.PL (see below) and build the module (something like 'perl Makefile.PL; make'); but let's ignore that for the moment). So now you can do use MyModule; $a = pdl 2,3,4; $b = pdl 5; $c = add($a,$b); # or add($a,$b,($c=null)); # Alternative form, useful if $c has been # preset to something big, not useful here. and have threading work correctly (the result is $c == [7 8 9]). =head2 The Pars section: the signature of a PP function Seeing the above example code you will most probably ask: what is this strange C<$c=null> syntax in the second call to our new C function? If you take another look at the definition of C you will notice that the third argument C is flagged with the qualifier C<[o]> which tells PDL::PP that this is an output argument. So the above call to add means 'create a new $c from scratch with correct dimensions' - C is a special token for 'empty piddle' (you might ask why we haven't used the value C to flag this instead of the PDL specific C; we are currently thinking about it ;). [This should be explained in some other section of the manual as well!!] The reason for having this syntax as an alternative is that if you have really huge piddles, you can do $c = PDL->null; for(some long loop) { # munge a,b add($a,$b,$c); # munge c, put something back to a,b } and avoid allocating and deallocating $c each time. It is allocated once at the first add() and thereafter the memory stays until $c is destroyed. If you just say $c = add($a,$b); the code generated by PP will automatically fill in C<$c=null> and return the result. If you want to learn more about the reasons why PDL::PP supports this style where output arguments are given as last arguments check the L man page. C<[o]> is not the only qualifier a pdl argument can have in the signature. Another important qualifier is the C<[t]> option which flags a pdl as temporary. What does that mean? You tell PDL::PP that this pdl is only used for temporary results in the course of the calculation and you are not interested in its value after the computation has been completed. But why should PDL::PP want to know about this in the first place? The reason is closely related to the concepts of pdl auto creation (you heard about that above) and implicit threading. If you use implicit threading the dimensionality of automatically created pdls is actually larger than that specified in the signature. With C<[o]> flagged pdls will be created so that they have the additional dimensions as required by the number of implicit thread dimensions. When creating a temporary pdl, however, it will always only be made big enough so that it can hold the result for one iteration in a thread loop, i.e. as large as required by the signature. So less memory is wasted when you flag a pdl as temporary. Secondly, you can use output auto creation with temporary pdls even when you are using explicit threading which is forbidden for normal output pdls flagged with C<[o]> (see L). Here is an example where we use the [t] qualifier. We define the function C that calls a C routine C which needs a temporary array of the same size and type as the array C (sorry about the forward reference for C<$P>; it's a pointer access, see below) : pp_def('callf', Pars => 'a(n); [t] tmp(n); [o] b()', Code => 'PDL_Indx ns = $SIZE(n); f($P(a),$P(b),$P(tmp),ns); ' ); =head2 Argument dimensions and the signature Now we have just talked about dimensions of pdls and the signature. How are they related? Let's say that we want to add a scalar + the index number to a vector: pp_def('add2', Pars => 'a(n); b(); [o]c(n);', Code => 'loop(n) %{ $c() = $a() + $b() + n; %}' ); There are several points to notice here: first, the C argument now contains the I arguments to show that we have a single dimensions in I and I. It is important to note that dimensions are actual entities that are accessed by name so this declares I and I to have the B first dimensions. In most PP definitions the size of named dimensions will be set from the respective dimensions of non-output pdls (those with no C<[o]> flag) but sometimes you might want to set the size of a named dimension explicitly through an integer parameter. See below in the description of the C section how that works. =head2 Constant argument dimensions in the signature Suppose you want an output piddle to be created automatically and you know that on every call its dimension will have the same size (say 9) regardless of the dimensions of the input piddles. In this case you use the following syntax in the Pars section to specify the size of the dimension: ' [o] y(n=9); ' As expected, extra dimensions required by threading will be created if necessary. If you need to assign a named dimension according to a more complicated formula (than a constant) you must use the C key described below. =head2 Type conversions and the signature The signature also determines the type conversions that will be performed when a PP function is invoked. So what happens when we invoke one of our previously defined functions with pdls of different type, e.g. add2($a,$b,($ret=null)); where $a is of type C and $b of type C? With the signature as shown in the definition of C above the datatype of the operation (as determined at runtime) is that of the pdl with the 'highest' type (sequence is byte < short < ushort < long < float < double). In the add2 example the datatype of the operation is float ($a has that datatype). All pdl arguments are then type converted to that datatype (they are not converted inplace but a copy with the right type is created if a pdl argument doesn't have the type of the operation). Null pdls don't contribute a type in the determination of the type of the operation. However, they will be created with the datatype of the operation; here, for example, $ret will be of type float. You should be aware of these rules when calling PP functions with pdls of different types to take the additional storage and runtime requirements into account. These type conversions are correct for most functions you normally define with C. However, there are certain cases where slightly modified type conversion behaviour is desired. For these cases additional qualifiers in the signature can be used to specify the desired properties with regard to type conversion. These qualifiers can be combined with those we have encountered already (the I C<[o]> and C<[t]>). Let's go through the list of qualifiers that change type conversion behaviour. The most important is the C qualifier which comes in handy when a pdl argument represents indices into another pdl. Let's take a look at an example from C: pp_def('maximum_ind', Pars => 'a(n); indx [o] b()', Code => '$GENERIC() cur; PDL_Indx curind; loop(n) %{ if (!n || $a() > cur) {cur = $a(); curind = n;} %} $b() = curind;', ); The function C finds the index of the largest element of a vector. If you look at the signature you notice that the output argument C has been declared with the additional C qualifier. This has the following consequences for type conversions: regardless of the type of the input pdl C the output pdl C will be of type C which makes sense since C will represent an index into C. Note that 'curind' is declared as type C and not C. While most datatype declarations in the 'Pars' section use the same name as the underlying C type, C is a type which is sufficient to handle PDL indexing operations. For 32-bit installs, it can be a 32-bit integer type. For 64-bit installs, it will be a 64-bit integer type. Furthermore, if you call the function with an existing output pdl C its type will not influence the datatype of the operation (see above). Hence, even if C is of a smaller type than C it will not be converted to match the type of C but stays untouched, which saves memory and CPU cycles and is the right thing to do when C represents indices. Also note that you can use the 'indx' qualifier together with other qualifiers (the C<[o]> and C<[t]> qualifiers). Order is significant -- type qualifiers precede creation qualifiers (C<[o]> and C<[t]>). The above example also demonstrates typical usage of the C<$GENERIC()> macro. It expands to the current type in a so called generic loop. What is a generic loop? As you already heard a PP function has a runtime datatype as determined by the type of the pdl arguments it has been invoked with. The PP generated XS code for this function therefore contains a switch like C that selects a case based on the runtime datatype of the function (it's called a type ``loop'' because there is a loop in PP code that generates the cases). In any case your code is inserted once for each PDL type into this switch statement. The C<$GENERIC()> macro just expands to the respective type in each copy of your parsed code in this C statement, e.g., in the C section C will expand to C and so on for the other case statements. I guess you realise that this is a useful macro to hold values of pdls in some code. There are a couple of other qualifiers with similar effects as C. For your convenience there are the C and C qualifiers with analogous consequences on type conversions as C. Let's assume you have a I large array for which you want to compute row and column sums with an equivalent of the C function. However, with the normal definition of C you might run into problems when your data is, e.g. of type short. A call like sumover($large_pdl,($sums = null)); will result in C<$sums> be of type short and is therefore prone to overflow errors if C<$large_pdl> is a very large array. On the other hand calling @dims = $large_pdl->dims; shift @dims; sumover($large_pdl,($sums = zeroes(double,@dims))); is not a good alternative either. Now we don't have overflow problems with C<$sums> but at the expense of a type conversion of C<$large_pdl> to double, something bad if this is really a large pdl. That's where C comes in handy: pp_def('sumoverd', Pars => 'a(n); double [o] b()', Code => 'double tmp=0; loop(n) %{ tmp += a(); %} $b() = tmp;', ); This gets us around the type conversion and overflow problems. Again, analogous to the C qualifier C results in C always being of type double regardless of the type of C without leading to a type conversion of C as a side effect. Finally, there are the C qualifiers where type is one of C or C. What shall that mean. Let's illustrate the C qualifier with the actual definition of sumover: pp_def('sumover', Pars => 'a(n); int+ [o] b()', Code => '$GENERIC(b) tmp=0; loop(n) %{ tmp += a(); %} $b() = tmp;', ); As we had already seen for the C, C and C qualifiers, a pdl marked with a C qualifier does not influence the datatype of the pdl operation. Its meaning is "make this pdl at least of type C or higher, as required by the type of the operation". In the sumover example this means that when you call the function with an C of type PDL_Short the output pdl will be of type PDL_Long (just as would have been the case with the C qualifier). This again tries to avoid overflow problems when using small datatypes (e.g. byte images). However, when the datatype of the operation is higher than the type specified in the C qualifier C will be created with the datatype of the operation, e.g. when C is of type double then C will be double as well. We hope you agree that this is sensible behaviour for C. It should be obvious how the C qualifier works by analogy. It may become necessary to be able to specify a set of alternative types for the parameters. However, this will probably not be implemented until someone comes up with a reasonable use for it. Note that we now had to specify the C<$GENERIC> macro with the name of the pdl to derive the type from that argument. Why is that? If you carefully followed our explanations you will have realised that in some cases C will have a different type than the type of the operation. Calling the '$GENERIC' macro with C as argument makes sure that the type will always the same as that of C in that part of the generic loop. This is about all there is to say about the C section in a C call. You should remember that this section defines the I of a PP defined function, you can use several options to qualify certain arguments as output and temporary args and all dimensions that you can later refer to in the C section are defined by name. It is important that you understand the meaning of the signature since in the latest PDL versions you can use it to define threaded functions from within Perl, i.e. what we call I. Please check L for details. =head2 The Code section The C section contains the actual XS code that will be in the innermost part of a thread loop (if you don't know what a thread loop is then you still haven't read L; do it now ;) after any PP macros (like C<$GENERIC>) and PP functions have been expanded (like the C function we are going to explain next). Let's quickly reiterate the C example: pp_def('sumover', Pars => 'a(n); int+ [o] b()', Code => '$GENERIC(b) tmp=0; loop(n) %{ tmp += a(); %} $b() = tmp;', ); The C construct in the C section also refers to the dimension name so you don't need to specify any limits: the loop is correctly sized and everything is done for you, again. Next, there is the surprising fact that C<$a()> and C<$b()> do B contain the index. This is not necessary because we're looping over I and both variables know which dimensions they have so they automatically know they're being looped over. This feature comes in very handy in many places and makes for much shorter code. Of course, there are times when you want to circumvent this; here is a function which make a matrix symmetric and serves as an example of how to code explicit looping: pp_def('symm', Pars => 'a(n,n); [o]c(n,n);', Code => 'loop(n) %{ int n2; for(n2=n; n2<$SIZE(n); n2++) { $c(n0 => n, n1 => n2) = $c(n0 => n2, n1 => n) = $a(n0 => n, n1 => n2); } %} ' ); Let's dissect what is happening. Firstly, what is this function supposed to do? From its signature you see that it takes a 2D matrix with equal numbers of columns and rows and outputs a matrix of the same size. From a given input matrix $a it computes a symmetric output matrix $c (symmetric in the matrix sense that A^T = A where ^T means matrix transpose, or in PDL parlance $c == $c->xchg(0,1)). It does this by using only the values on and below the diagonal of $a. In the output matrix $c all values on and below the diagonal are the same as those in $a while those above the diagonal are a mirror image of those below the diagonal (above and below are here interpreted in the way that PDL prints 2D pdls). If this explanation still sounds a bit strange just go ahead, make a little file into which you write this definition, build the new PDL extension (see section on Makefiles for PP code) and try it out with a couple of examples. Having explained what the function is supposed to do there are a couple of points worth noting from the syntactical point of view. First, we get the size of the dimension named C again by using the C<$SIZE> macro. Second, there are suddenly these funny C and C index names in the code though the signature defines only the dimension C. Why this? The reason becomes clear when you note that both the first and second dimension of $a and $b are named C in the signature of C. This tells PDL::PP that the first and second dimension of these arguments should have the same size. Otherwise the generated function will raise a runtime error. However, now in an access to C<$a> and C<$c> PDL::PP cannot figure out which index C refers to any more just from the name of the index. Therefore, the indices with equal dimension names get numbered from left to right starting at 0, e.g. in the above example C refers to the first dimension of C<$a> and C<$c>, C to the second and so on. In all examples so far, we have only used the C and C members of the hash that was passed to C. There are certainly other keys that are recognised by PDL::PP and we will hear about some of them in the course of this document. Find a (non-exhaustive) list of keys in Appendix A. A list of macros and PPfunctions (we have only encountered some of those in the examples above yet) that are expanded in values of the hash argument to C is summarised in Appendix B. At this point, it might be appropriate to mention that PDL::PP is not a completely static, well designed set of routines (as Tuomas puts it: "stop thinking of PP as a set of routines carved in stone") but rather a collection of things that the PDL::PP author (Tuomas J. Lukka) considered he would have to write often into his PDL extension routines. PP tries to be expandable so that in the future, as new needs arise, new common code can be abstracted back into it. If you want to learn more on why you might want to change PDL::PP and how to do it check the section on PDL::PP internals. =head2 Handling bad values If you do not have bad-value support compiled into PDL you can ignore this section and the related keys: C, C, ... (try printing out the value of C<$PDL::Bad::Status> - if it equals 0 then move straight on). There are several keys and macros used when writing code to handle bad values. The first one is the C key: =over 4 =item HandleBad => 0 This flags a pp-routine as I handling bad values. If this routine is sent piddles with their C set, then a warning message is printed to STDOUT and the piddles are processed as if the value used to represent bad values is a valid number. The C value is not propagated to the output piddles. An example of when this is used is for FFT routines, which generally do not have a way of ignoring part of the data. =item HandleBad => 1 This causes PDL::PP to write extra code that ensures the BadCode section is used, and that the C<$ISBAD()> macro (and its brethren) work. =item HandleBad is not given If any of the input piddles have their C set, then the output piddles will have their C set, but any supplied BadCode is ignored. =back The value of C is used to define the contents of the C key, if it is not given. To handle bad values, code must be written somewhat differently; for instance, $c() = $a() + $b(); becomes something like if ( $a() != BADVAL && $b() != BADVAL ) { $c() = $a() + $b(); } else { $c() = BADVAL; } However, we only want the second version if bad values are present in the input piddles (and that bad-value support is wanted!) - otherwise we actually want the original code. This is where the C key comes in; you use it to specify the code to execute if bad values may be present, and PP uses both it and the C section to create something like: if ( bad_values_are_present ) { fancy_threadloop_stuff { BadCode } } else { fancy_threadloop_stuff { Code } } This approach means that there is virtually no overhead when bad values are not present (i.e. the L routine returns 0). The C preprocessor symbol C is defined when the bad code is compiled, so that you can reduce the amount of code you write. The BadCode section can use the same macros and looping constructs as the Code section. However, it wouldn't be much use without the following additional macros: =over 4 =item $ISBAD(var) To check whether a piddle's value is bad, use the C<$ISBAD> macro: if ( $ISBAD(a()) ) { printf("a() is bad\n"); } You can also access given elements of a piddle: if ( $ISBAD(a(n=>l)) ) { printf("element %d of a() is bad\n", l); } =item $ISGOOD(var) This is the opposite of the C<$ISBAD> macro. =item $SETBAD(var) For when you want to set an element of a piddle bad. =item $ISBADVAR(c_var,pdl) If you have cached the value of a piddle C<$a()> into a c-variable (C say), then to check whether it is bad, use C<$ISBADVAR(foo,a)>. =item $ISGOODVAR(c_var,pdl) As above, but this time checking that the cached value isn't bad. =item $SETBADVAR(c_var,pdl) To copy the bad value for a piddle into a c variable, use C<$SETBADVAR(foo,a)>. =back I mention C<$PPISBAD()> etc macros. Using these macros, the above code could be specified as: Code => '$c() = $a() + $b();', BadCode => ' if ( $ISBAD(a()) || $ISBAD(b()) ) { $SETBAD(c()); } else { $c() = $a() + $b(); }', Since this is Perl, TMTOWTDI, so you could also write: BadCode => ' if ( $ISGOOD(a()) && $ISGOOD(b()) ) { $c() = $a() + $b(); } else { $SETBAD(c()); }', You can reduce code repition using the C C macro, using the same code for both of the C and C sections: #ifdef PDL_BAD_CODE if ( $ISGOOD(a()) && $ISGOOD(b()) ) { #endif PDL_BAD_CODE $c() = $a() + $b(); #ifdef PDL_BAD_CODE } else { $SETBAD(c()); } #endif PDL_BAD_CODE If you want access to the value of the badflag for a given piddle, you can use the PDL STATE macros: =over 4 =item $ISPDLSTATEBAD(pdl) =item $ISPDLSTATEGOOD(pdl) =item $SETPDLSTATEBAD(pdl) =item $SETPDLSTATEGOOD(pdl) =back I mention the C and C options to C, as well as the C key. =head2 Interfacing your own/library functions using PP Now, consider the following: you have your own C function (that may in fact be part of some library you want to interface to PDL) which takes as arguments two pointers to vectors of double: void myfunc(int n,double *v1,double *v2); The correct way of defining the PDL function is pp_def('myfunc', Pars => 'a(n); [o]b(n);', GenericTypes => ['D'], Code => 'myfunc($SIZE(n),$P(a),$P(b));' ); The C<$P(>IC<)> syntax returns a pointer to the first element and the other elements are guaranteed to lie after that. Notice that here it is possible to make many mistakes. First, C<$SIZE(n)> must be used instead of C. Second, you shouldn't put any loops in this code. Third, here we encounter a new hash key recognised by PDL::PP : the C declaration tells PDL::PP to ONLY GENERATE THE TYPELOOP FOP THE LIST OF TYPES SPECIFIED. In this case C. This has two advantages. Firstly the size of the compiled code is reduced vastly, secondly if non-double arguments are passed to C PDL will automatically convert them to double before passing to the external C routine and convert them back afterwards. One can also use C to qualify the types of individual arguments. Thus one could also write this as: pp_def('myfunc', Pars => 'double a(n); double [o]b(n);', Code => 'myfunc($SIZE(n),$P(a),$P(b));' ); The type specification in C exempts the argument from variation in the typeloop - rather it is automatically converted too and from the type specified. This is obviously useful in a more general example, e.g.: void myfunc(int n,float *v1,long *v2); pp_def('myfunc', Pars => 'float a(n); long [o]b(n);', GenericTypes => ['F'], Code => 'myfunc($SIZE(n),$P(a),$P(b));' ); Note we still use C to reduce the size of the type loop, obviously PP could in principle spot this and do it automatically though the code has yet to attain that level of sophistication! Finally note when types are converted automatically one MUST use the C<[o]> qualifier for output variables or you hard one changes will get optimised away by PP! If you interface a large library you can automate the interfacing even further. Perl can help you again(!) in doing this. In many libraries you have certain calling conventions. This can be exploited. In short, you can write a little parser (which is really not difficult in Perl) that then generates the calls to C from parsed descriptions of the functions in that library. For an example, please check the I interface in the C tree of the PDL distribution. If you want to check (during debugging) which calls to PP functions your Perl code generated a little helper package comes in handy which replaces the PP functions by identically named ones that dump their arguments to stdout. Just say perl -MPDL::PP::Dump myfile.pd to see the calls to C and friends. Try it with F and F. If you're interested (or want to enhance it), the source is in Basic/Gen/PP/Dump.pm =head2 Other macros and functions in the Code section Macros: So far we have encountered the C<$SIZE>, C<$GENERIC> and C<$P> macros. Now we are going to quickly explain the other macros that are expanded in the C section of PDL::PP along with examples of their usage. =over 3 =item C<$T> The C<$T> macro is used for type switches. This is very useful when you have to use different external (e.g. library) functions depending on the input type of arguments. The general syntax is $Ttypeletters(type_alternatives) where C is a permutation of a subset of the letters C which stand for Byte, Short, Ushort, etc. and C are the expansions when the type of the PP operation is equal to that indicated by the respective letter. Let's illustrate this incomprehensible description by an example. Assuming you have two C functions with prototypes void float_func(float *in, float *out); void double_func(double *in, double *out); which do basically the same thing but one accepts float and the other double pointers. You could interface them to PDL by defining a generic function C (which will call the correct function depending on the type of the transformation): pp_def('foofunc', Pars => ' a(n); [o] b();', Code => ' $TFD(float_func,double_func) ($P(a),$P(b));' GenericTypes => [qw(F D)], ); Please note that you can't say Code => ' $TFD(float,double)_func ($P(a),$P(b));' since the C<$T> macro expands with trailing spaces, analogously to C preprocessor macros. The slightly longer form illustrated above is correct. If you really want brevity, you can of course do '$TBSULFD('.(join ',',map {"long_identifier_name_$_"} qw/byt short unseigned lounge flotte dubble/).');' =item C<$PP> The C<$PP> macro is used for a so called I. The I refers to some internal optimisations of PDL (for those who are familiar with the PDL core we are talking about the vaffine optimisations). This macro is mainly for internal use and you shouldn't need to use it in any of your normal code. =item C<$COMP> (and the C section) The C<$COMP> macro is used to access non-pdl values in the code section. Its name is derived from the implementation of transformations in PDL. The variables you can refer to using C<$COMP> are members of the ``compiled'' structure that represents the PDL transformation in question but does not yet contain any information about dimensions (for further details check L). However, you can treat C<$COMP> just as a black box without knowing anything about the implementation of transformations in PDL. So when would you use this macro? Its main usage is to access values of arguments that are declared in the C section of a C definition. But then you haven't heard about the C key yet?! Let's have another example that illustrates typical usage of both new features: pp_def('pnmout', Pars => 'a(m)', OtherPars => "char* fd", GenericTypes => [qw(B U S L)], Code => 'PerlIO *fp; IO *io; io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO)); if (!io || !(fp = IoIFP(io))) croak("Can\'t figure out FP"); if (PerlIO_write(fp,$P(a),len) != len) croak("Error writing pnm file"); '); This function is used to write data from a pdl to a file. The file descriptor is passed as a string into this function. This parameter does not go into the C section since it cannot be usefully treated like a pdl but rather into the aptly named C section. Parameters in the C section follow those in the C section when invoking the function, i.e. open FILE,">out.dat" or die "couldn't open out.dat"; pnmout($pdl,'FILE'); When you want to access this parameter inside the code section you have to tell PP by using the C<$COMP> macro, i.e. you write C<$COMP(fd)> as in the example. Otherwise PP wouldn't know that the C you are referring to is the same as that specified in the C section. Another use for the C section is to set a named dimension in the signature. Let's have an example how that is done: pp_def('setdim', Pars => '[o] a(n)', OtherPars => 'int ns => n', Code => 'loop(n) %{ $a() = n; %}', ); This says that the named dimension C will be initialised from the value of the I C which is of integer type (I guess you have realised that we use the C named_dim> syntax). Now you can call this function in the usual way: setdim(($a=null),5); print $a; [ 0 1 2 3 4 ] Admittedly this function is not very useful but it demonstrates how it works. If you call the function with an existing pdl and you don't need to explicitly specify the size of C since PDL::PP can figure it out from the dimensions of the non-null pdl. In that case you just give the dimension parameter as C<-1>: $a = hist($b); setdim($a,-1); That should do it. =back The only PP function that we have used in the examples so far is C. Additionally, there are currently two other functions which are recognised in the C section: =over 2 =item threadloop As we heard above the signature of a PP defined function defines the dimensions of all the pdl arguments involved in a I operation. However, you often call the functions that you defined with PP with pdls that have more dimensions than those specified in the signature. In this case the primitive operation is performed on all subslices of appropriate dimensionality in what is called a I (see also overview above and L). Assuming you have some notion of this concept you will probably appreciate that the operation specified in the code section should be optimised since this is the tightest loop inside a thread loop. However, if you revisit the example where we define the C function, you will quickly realise that looking up the C file descriptor in the inner thread loop is not very efficient when writing a pdl with many rows. A better approach would be to look up the C descriptor once outside the thread loop and use its value then inside the tightest thread loop. This is exactly where the C function comes in handy. Here is an improved definition of C which uses this function: pp_def('pnmout', Pars => 'a(m)', OtherPars => "char* fd", GenericTypes => [qw(B U S L)], Code => 'PerlIO *fp; IO *io; int len; io = GvIO(gv_fetchpv($COMP(fd),FALSE,SVt_PVIO)); if (!io || !(fp = IoIFP(io))) croak("Can\'t figure out FP"); len = $SIZE(m) * sizeof($GENERIC()); threadloop %{ if (PerlIO_write(fp,$P(a),len) != len) croak("Error writing pnm file"); %} '); This works as follows. Normally the C code you write inside the C section is placed inside a thread loop (i.e. PP generates the appropriate wrapping XS code around it). However, when you explicitly use the C function, PDL::PP recognises this and doesn't wrap your code with an additional thread loop. This has the effect that code you write outside the thread loop is only executed once per transformation and just the code with in the surrounding C<%{ ... %}> pair is placed within the tightest thread loop. This also comes in handy when you want to perform a decision (or any other code, especially CPU intensive code) only once per thread, i.e. pp_addhdr(' #define RAW 0 #define ASCII 1 '); pp_def('do_raworascii', Pars => 'a(); b(); [o]c()', OtherPars => 'int mode', Code => ' switch ($COMP(mode)) { case RAW: threadloop %{ /* do raw stuff */ %} break; case ASCII: threadloop %{ /* do ASCII stuff */ %} break; default: croak("unknown mode"); }' ); =item types The types function works similar to the C<$T> macro. However, with the C function the code in the following block (delimited by C<%{> and C<%}> as usual) is executed for all those cases in which the datatype of the operation is I the types represented by the letters in the argument to C, e.g. Code => '... types(BSUL) %{ /* do integer type operation */ %} types(FD) %{ /* do floating point operation */ %} ...' =back =head2 The RedoDimsCode Section The C key is an optional key that is used to compute dimensions of piddles at runtime in case the standard rules for computing dimensions from the signature are not sufficient. The contents of the C entry is interpreted in the same way that the Code section is interpreted-- I, PP macros are expanded and the result is interpreted as C code. The purpose of the code is to set the size of some dimensions that appear in the signature. Storage allocation and threadloops and so forth will be set up as if the computed dimension had appeared in the signature. In your code, you first compute the desired size of a named dimension in the signature according to your needs and then assign that value to it via the $SIZE() macro. As an example, consider the following situation. You are interfacing an external library routine that requires an temporary array for workspace to be passed as an argument. Two input data arrays that are passed are C and C. The output data array is C. The routine requires a workspace array with a length of n+m*m, and you'd like the storage created automatically just like it would be for any piddle flagged with [t] or [o]. What you'd like is to say something like pp_def( "myexternalfunc", Pars => " p(m); x(n); [o] y; [t] work(n+m*m); ", ... but that won't work, because PP can't interpret expressions with arithmetic in the signature. Instead you write pp_def( "myexternalfunc", Pars => ' p(m); x(n); [o] y(); [t] work(wn); ', RedoDimsCode => ' PDL_Indx im = $PDL(p)->dims[0]; PDL_Indx in = $PDL(x)->dims[0]; PDL_Indx min = in + im * im; PDL_Indx inw = $PDL(work)->dims[0]; $SIZE(wn) = inw >= min ? inw : min; ', Code => ' externalfunc( $P(p), $P(x), $SIZE(m), $SIZE(n), $P(work) ); ' ); This code works as follows: The macro $PDL(p) expands to a pointer to the pdl struct for the piddle p. You don't want a pointer to the data ( ie $P ) in this case, because you want to access the methods for the piddle on the C level. You get the first dimension of each of the piddles and store them in integers. Then you compute the minimum length the work array can be. If the user sent a piddle C with sufficient storage, then leave it alone. If the user sent, say a null pdl, or no pdl at all, then the size of wn will be zero and you reset it to the minimum value. Before the code in the Code section is executed PP will create the proper storage for C if it does not exist. Note that you only took the first dimension of C