Update
Many thanks to everybody for their help and comments.
The code is down to 336 lines and an 800x1600 table outputs not quite as fast as a page here.
So you can compare to the original file:
#!/usr/bin/perl
# $Id: popnew $
# $Date: 12.31.10 $
# $HeadURL: adamant.net $
# $Revision: 2011 $
# $Source: /popnew.pl $
######################################################################
+############
use strict;
#use warnings;
use CGI qw(:standard);
use CGI::Carp qw(fatalsToBrowser);
use CGI::Fast;
use lib '/home/XXXXXX/public_html/cgi-bin/lib',
'D://websites/savant/cgi-bin/lib';
use Readonly;
use Math::Random::MT::Auto qw(rand);
use List::Util qw(shuffle);
our $VERSION = 3.24;
my (
$chntot, $coper, $countgen, $errchk, $ercount, $incrs,
$incrsdel, $total2, $tot2error, $x, $xb, $y,
$yb, @aoa, @aob, @aod,
);
Readonly my $PCNT => 100;
Readonly my $C3 => 3;
Readonly my $C4 => 4;
Readonly my $C5 => 5;
Readonly my $NEG => -1;
my $q = CGI->new( \*STDIN );
my $copyerr = $q->param('copyerr');
my $model = $q->param('model');
my $initial = $q->param('initial');
my $LST = $q->param('LST');
my @mpy = (); # year
my @mpe = (); # population estimate
foreach ( 0 .. $LST ) {
$mpe[$_] = $q->param( 'mpe' . $_ ) || 0;
$mpy[$_] = $q->param( 'mpy' . $_ ) || 1;
}
$mpy[0] = 0;
# CALCS
my @grand = (0);
my @popbyyer = ( $mpe[0] );
for my $y ( 1 .. $LST ) {
my $y_diff = ( $mpy[$y] - $mpy[ $y - 1 ] ) || 1;
my $e_diff = ( $mpe[$y] - $mpe[ $y - 1 ] );
$popbyyer[$y] = $e_diff / $y_diff;
$grand[$y] = $grand[ $y - 1 ] + ( ( $e_diff < 0 ) ? abs($e_diff) :
+ 0 );
}
my $gener = ( sort { $a <=> $b } @mpy )[$NEG];
my $total = ( sort { $a <=> $b } @mpe )[$NEG] + $grand[$NEG] - 1;
#build data table;
my @dr0 = ();
my @dr1 = ();
my @dr2 = ();
my @dr3 = ();
my @dr4 = ();
my @dr5 = ();
$dr0[0] = 0;
$dr3[0] = 0;
$dr5[0] = 0;
foreach my $tablem ( 1 .. $LST - 1 ) {
$dr0[$tablem] = $mpy[$tablem] + 1;
$dr3[$tablem] = $mpy[$tablem];
$dr5[$tablem] = $grand[$tablem];
}
foreach my $tablen ( 0 .. $LST - 1 ) {
$dr1[$tablen] = $mpy[ $tablen + 1 ];
$dr2[$tablen] = $mpe[$tablen];
$dr4[$tablen] = $popbyyer[ $tablen + 1 ];
}
popfileb();
#check that 'd' cell ammount matches;
my $errorcheck = $ercount - $grand[$NEG];
if ( $errorcheck != 0 ) {
$errchk =
qq{<p>Error check: Oops, you propably want to reload this page - off b
+y $errorcheck.</p>\n};
}
else {
$errchk = q{};
}
popfilea();
table1();
table2();
#prepopulate copy error array;
sub popfilea {
foreach my $ya ( 0 .. $gener ) {
foreach my $xa ( 0 .. $total ) {
my $copycop = int rand( 1 + 2 * $copyerr ) - $copyerr;
my $copycopa = $copycop / $PCNT;
$aoa[$xa][$ya] = $copycopa;
}
}
return;
}
#increase - decrease array;
sub popfileb {
my $countgen0 = 0;
foreach my $dlp ( 0 .. $LST - 1 ) {
foreach my $yb ( $dr0[$dlp] .. $dr1[$dlp] ) {
$countgen = $countgen0++ - $dr3[$dlp];
my $change = $countgen * $dr4[$dlp];
$incrs = int( $dr2[$dlp] + $change );
$incrsdel = int( $dr5[$dlp] + abs $change );
$chntot = $incrsdel + $incrs;
foreach my $xb ( 0 .. $total ) {
#set first row;
if ( $yb == 0 ) {
if ( $xb < $dr2[$dlp] ) {
$aod[$xb][0] = 'a';
}
else {
$aod[$xb][0] = 'n';
}
}
#set increasing rows;
elsif ( $dr4[$dlp] >= 0 ) {
if ( $xb < $dr5[$dlp] + $incrs ) {
if ( $aod[$xb][ $yb - 1 ] eq 'd' ) {
$aod[$xb][$yb] = 'd';
}
else {
$aod[$xb][$yb] = 'a';
}
}
else {
$aod[$xb][$yb] = 'n';
}
}
#set decreasing rows;
else {
if ( $xb <= $chntot ) {
if ( $aod[$xb][ $yb - 1 ] eq 'd' ) {
$aod[$xb][$yb] = 'd';
}
elsif ( $aod[$xb][ $yb - 1 ] eq 'a' ) {
$aod[$xb][$yb] = 'a';
}
else {
$aod[$xb][$yb] = 'n';
}
}
else {
$aod[$xb][$yb] = 'n';
}
}
}
#set random decreased cell;
if ( $dr4[$dlp] < 0 ) {
#pre-populate deletion array;
my @delarray = ( 0 .. $chntot );
my @dlarray = shuffle @delarray;
my $cndiea = 0;
foreach my $del ( 0 .. $chntot ) {
if ( defined $aod[$del][$yb] && $aod[$del][$yb] eq
+ 'd' ) {
$cndiea++;
}
}
my $cnr = $cndiea;
for my $xd ( 0 .. $chntot ) {
my $xda = $dlarray[$xd];
if ( defined $aod[$xda][$yb] && $aod[$xda][$yb] eq
+ 'a' && $cnr < $incrsdel ) {
$aod[$xda][$yb] = 'd';
$cnr++;
}
}
}
}
}
my $error = 0;
foreach my $mycheck ( 0 .. $total ) {
if ( $aod[$mycheck][ $mpy[$NEG] ] eq 'd' ) {
$error++;
}
$ercount = $error;
}
my $toterror = 0;
foreach my $mycheck2 ( 0 .. $total ) {
if ( $aod[$mycheck2][ $mpy[$NEG] ] eq 'n' ) {
$toterror++;
}
$tot2error = $toterror;
}
return;
}
#model 1;
sub popnum1 {
( $x, $y ) = @_;
if ( $y == 0 ) {
$aob[$x][0] = sprintf '%.2f', $initial + $aoa[$x][0];
}
else {
if ( $aod[$x][ $y - 1 ] ne 'a' ) {
$aob[$x][$y] = sprintf '%.2f', $initial + $aoa[$x][0];
}
else {
$aob[$x][$y] = sprintf '%.2f', $aoa[$x][$y] + $aob[$x][ $y
+ - 1 ];
}
}
return $aob[$x][$y];
}
#model 2;
sub popnum2 {
( $x, $y ) = @_;
my @delarray = ( 0 .. $total );
my @dlarray = shuffle @delarray;
if ( $y == 0 ) {
$aob[$x][0] = sprintf '%.2f', $initial + $aoa[$x][0];
}
elsif ( $aod[$x][ $y - 1 ] eq 'n' ) {
my $cnr = 0;
for my $xd ( 0 .. $total ) {
my $xda = $dlarray[$xd];
if ( $cnr < 2 && $aob[$xda][ $y - 1 ] ne q{} ) {
$aob[$x][$y] = sprintf '%.2f',
$aoa[$x][$y] + $aob[$xda][ $y - 1 ];
$cnr++;
}
}
}
else {
$aob[$x][$y] = sprintf '%.2f', $aoa[$x][$y] + $aob[$x][ $y - 1
+ ];
}
return $aob[$x][$y];
}
sub table1 {
#table width;
$total2 = $total - $tot2error;
my $th = $total2 + 2;
print "Content-type: text/html\n\n" or croak 'cannot print line1';
#html header;
my $head = <<'HEAD';
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns='http://www.w3.org/1999/xhtml' xml:lang='en' lang='en'>
<head><meta http-equiv='Content-Type' content='text/html; charset=iso-
+8859-1' />
<meta http-equiv='Content-Style-Type' content='text/css' />
<style type='text/css'>
td {padding: .5em; min-width:2.5em; }
</style>
HEAD
print $head or croak 'cannot print head';
#html title, confirm data;
print qq{<title>Model $model</title>\n} or croak 'cannot print tit
+le';
print
qq{</head>\n<body>\n<h1>Model $model</h1>\n<p>Initial# $initial<br />C
+opy Error +- $copyerr%</p>\n<p>}
or croak 'cannot print end head';
#tabletop header row;
print qq{<table border='1'><tr><th colspan='$th'>Population</th></
+tr><tr>}
or croak 'cannot print tabletop';
#build first table row;
foreach my $tble ( 0 .. $total2 + 1 ) {
print qq{<td><b>$tble</b></td>} or croak 'cannot print td2';
}
print q{</tr>} or croak 'cannot print tr';
foreach my $chk ( 0 .. $LST ) {
print qq {Year $mpy[$chk] - $mpe[$chk]<br />}
or croak 'cannot print check';
}
print qq{</p>\n$errchk}
or croak 'cannot print title2';
return;
}
sub table2 {
foreach my $drp ( 0 .. $LST - 1 ) {
foreach my $y ( $dr0[$drp] .. $dr1[$drp] ) {
print qq{<tr><td><b>$y</b></td>} or croak 'cannot print td
+';
for my $x ( 0 .. $total2 ) {
if ( $aod[$x][$y] eq 'd' ) {
print q{<td style='background-color:#cccccc'> 
+;</td>}
or croak 'cannot print td';
}
elsif ( $aod[$x][$y] eq 'a' ) {
if ( $model == 1 ) {
$coper = popnum1( $x, $y );
}
else {
$coper = popnum2( $x, $y );
}
print qq{<td>$coper</td>} or croak 'cannot print t
+d';
}
else {
print q{<td> </td>} or croak 'cannot print td
+';
}
}
print q{</tr>} or croak 'cannot print tr';
}
}
print qq{</table><p>Program Ver: $VERSION</p></body></html>}
or croak 'cannot print foot';
return;
}
exit;
Next step - using CGI.pm to create the form and adding a 'print to file' and 'split file' option. (800 wide is about 3 times what Excel can handle for data crunching.) Any recommendations for a good book on CGI.pm?
Again, many thanks for the help.