#!/free/bin/perl
#
$sysdate = &gmttagdate;

##########
# pick up RCS keywords
my $rcs_author = '$Author: nhall $';
my $rcs_date_time = '$Date: 2005/07/01 17:38:03 $';
my $rcs_file = '$RCSfile: testmeds.pl,v $';
my $rcs_version = '$Revision: 2.17 $';
my $rcs_locker = '$Locker:  $';
# Convert to conventions used in NFH's PERL programs under SCCS:
my $modulename = $rcs_file;
$modulename =~ s/^\$RCSfile\: //;
$modulename =~ s/\,v \$$//;
$rcs_version =~ /\$Revision\: (\d+\.\d+)/;
my $deltaver = $1;
$rcs_date_time =~ /\$Date: (\d\d\d\d)\/(\d\d)\/(\d\d) (\d\d\:\d\d\:\d\d)/;
my $deltayy = $1;
my $deltamm = $2;
my $deltadd = $3;
my $deltatime = $4;
my @months = ('','JAN','FEB','MAR','APR','MAY',
  'JUN','JUL','AUG','SEP','OCT','NOV','DEC');
$deltamm = $months[$deltamm];
my $deltadate = "$deltadd/$deltamm/$deltayy";
# Set defaults if file is locked (an edit copy, not a working version)
if (length($rcs_locker) > 11) {
  my $lockedby = substr($rcs_locker, 9);
  $lockedby =~ s/ \$//;
  $deltadate = "01/01/01";
  $deltatime = "00:00:00";
  $modulename = "\n** TEST VERSION $deltaver ** RCS LOCKED BY $lockedby **\n$modulename";
  $deltaver = "0.0";
}
# Version number must be 4 characters
if (length($deltaver) > 4) {die "Version number ($deltaver) is too long";}
if (length($deltaver) < 4) {$deltaver .= " ";}
my $verstring = "$modulename $deltaver - $deltadate $deltatime";
##########

################################################
#
$testmeds_PRC_Code     = "tstm";  # Must be 4 characters!!
$testmeds_programmer   = "Norm Hall";
#
#
print "$verstring - written by $testmeds_programmer\n";
print "Processing Date: $sysdate\n";
#
if (length($testmeds_PRC_Code) != 4 || length($deltaver) != 4) {
  print "Improper PRC_Code ($testmeds_PRC_Code) or Version ";
  die "($deltaver)\nReport problem to programmer\n";
}
#
#
sub usage {
print <<EOF1;
\nTests a GTSPP MEDS ASCII file for control characters & format consistency
Usage: testmeds.pl inputfile [option flags]
(inputfile may be gzipped; filename.gz will be decompressed and read)
(inputfile and flags may be in any order, flags may be upper or lower case) 
(space between flag and parameter is optional for -d, -i, -o, -s)
  -d           = Dies after the first error is found (same as -d1)
                 If no -d switch, dies after 10 errors by default
  -d xxxx      = Dies after xxxx max errors are found
  -d 0         = Never dies (max errors xxxx=0)
  -h | -help   = Prints this Message (also if no input_filename is present)
  -i filename  = Input MEDS-ASCII file (alternative to bare filename)
  -o filename  = Output MEDS-ASCII to 'filename' adding new history records
                 (also sets -d0 to continue to end of file)
  -s           = Prints only the summary count of each type of error found   
  -s 1,2,5..   = Suppress tests 1, 2, 5.. (List must have no spaces!) 
  -t | -tests  = Prints a list of the tests implemented in this program
  -v           = Verbose -- Prints out interpretation of data Master records
                  and metadata portion of profile records
  -v nnnnnnnn  = Verbose printing for only the record where MKey=nnnnnnnn
  -vv nnnnnnnn = Very Verbose (or -vv) same as -v, plus prints profile data
EOF1
exit 0;
}

#
#
sub listtests {
# Numbers of tests in the list below correspond to numbers
# in comment lines in the program; look for lines like:
## nn ##
#
# NOTE:
#  21 Segment number must be numeric
#     (MEDS ASCII Format also calls for Profile_Seg to be zero-filled,
#     but this part of the test has been disabled, as few files pass
#     this test, and it should not be a problem for most programs.)

print <<EOF2;
Tests performed by this version of testmeds
  00 Test MKeys for consistency (quick test for MEDS-ASCII)
  01 Type of Newline (LF or CR+LF) must be appropriate to operating system
  02 No other ASCII control characters
  03 Cruise_ID must contain only A-Z, a-z, 0-9, or blanks
  04 Cruise_ID must not be all blanks
  05 Obs Date, Up_Date, & History Dates must be valid 1901 to present
  06 Time must be valid (24/60) & all digits
  07 One_Deg_sq must match latitude and longitude
  08 No_Prof >= 1
  09 Profile Info Group = 14 characters
  10 Surface Parameter Group = 15 characters
  11 Surface Code Group = 15 characters
  12 History Group = 42 characters
  13 History Groups must be in date order and > 1990
  14 Master Record Length must fit number & types of groups
  15 MKey must end in 00 when master record expected
  16 MKey must not end in 00 when extension record expected
  17 MKey of extension records must be sequential
  18 Obs Record must match common fields in Data Record
  19 Obs Record Profile_Type must match Prof_Type from Profile Info group
  20 Profile_Type must match among different segments of same record
  21 Segment number must be numeric
  22 Profile_Seg for segment must match segments actually found
  23 No_Depths >= 0
  24 D_P_Code must be D or P
  25 D_P_Code must match among different segments of same record
  26 Depths must be ordered properly (increasing)
  27 Data Record Length must fit number of data groups
  28 Deep_Depth must equal last depth found (to whole meters)
  29 Total_Depths must equal depths counted
EOF2
exit 0;
}
#
#
# The following tests that are performed by CHECK_AB_OCPROC.FOR are
# also implemented in this version of testmeds.  The number to the
# left is the test index ("DOC(nn)") in CHECK_AB_OCPROC.FOR, and the
# numbers in parentheses is the corresponding test number in testmeds.
#
# 3  (26) 'Profiles with reversed depth order'
# 8  (28) 'DEEP_DEPTH = deepest observation depth'
# 9  (21) 'Segment number is zero filled'
#         (testmeds tests for Numeric characters, but zero filled is 
#         not a practical test, as too many have a leading blank)
# 10 (24) 'DEPTH_PRESS indicator set to D or P'
# 11 ( 3) 'Cruise number has no null characters'
# 12 ( 5) 'Four digits in the year'
# 13 ( 5) 'Two digits in the month'
# 14 ( 5) 'Two digits in the day'
# 15 ( 6) 'Four digits in the hour, minute'
# 16 (13) 'History records occur in chronological order and date > 1990'
# 17 (18) 'Consistent common fields from station to profile records'
# 18 ( 7) 'Check ONE_DEG_SQ matches lat and long'
# 29 ( 8) 'Stations with no profiles'
# 30 (19,20,22) 'Integrity of profile types and number of segments'
# 33 ( 4) 'Check for an all blank cruise number'
#
#
# The following MEDS tests require a code database
# (These will be implemented in a separate program).
#
# 2  'STREAM_IDENTs are known'
# 7  'All parameter codes are known'
# 19 'ACT_PARM codes are known'
# 20 'ACT_CODE codes are known'
# 32 'Check SOURCE_ID is known'
#
#
# The following MEDS tests are not implemented in testmeds, as they
# are considered inappropriate for NODC format tests.
#
# 1  'Times of 0000 at successive stations'
# 4  'Observations more frequent than 1 per m'
#    (many CTD's fail this test -- tried and removed from testmeds)
# 5  'Duplicate station numbers in a cruise of delayed mode data'
# 6  'No Accession Number present for delayed mode data'
# 21 'QC flags are set after QCA'
# 22 'QC flags are set after QCB'
# 23 'DUP_FLAG is set after dups processing'
# 24 'There is a QCF and QCP parameter present'
# 25 'Check obs_date close to bulletin time'
# 26 'Qflag 5 for changed observation'
# 27 'Depth in history also in profile (for CV,CF,FB,FR)'
# 28 'QC_VERSION field set'
# 31 'Checks station numbers are non-zero'
# 34 'Quality flags not set properly'
#
#
$dieonerr = 0;
$verbose = 0;
$vverbose = 0;
$outfile = "";
$outflag = 0;
$maxerrs = "10";
$v_mkey = "";
$vv_mkey = "";
$file = "";
#
# Interpret Command Line
CMD: for (my $n = 0; $n <= $#ARGV; $n++) {
  if ($ARGV[$n] =~ /^-o$/i  && $ARGV[$n+1] !~ /^-/) {
    $outfile  = $ARGV[$n+1]; $ARGV[$n]=""; $ARGV[$n+1]=""; next CMD;}
  if ($ARGV[$n] =~ /^-i$/i  && $ARGV[$n+1] !~ /^-/) {
    $infile   = $ARGV[$n+1]; $ARGV[$n]=""; $ARGV[$n+1]=""; next CMD;}

  if ($ARGV[$n] =~ /^-d$/i  && $ARGV[$n+1] !~ /^-/) {
    $dieonerr = 1; $maxerrs = $ARGV[$n+1]; $ARGV[$n]=""; $ARGV[$n+1]=""; next CMD;}
  if ($ARGV[$n] =~ /^-s$/i  && $ARGV[$n+1] !~ /^-/) {
    $suppress = 1; $suplist = $ARGV[$n+1]; $ARGV[$n]=""; $ARGV[$n+1]=""; next CMD;}
  if ($ARGV[$n] =~ /^-vv$/i && $ARGV[$n+1] !~ /^-/) {
    $vverbose = 1; $vv_mkey = $ARGV[$n+1]; $ARGV[$n]=""; $ARGV[$n+1]=""; next CMD;}
  if ($ARGV[$n] =~ /^-v$/i  && $ARGV[$n+1] !~ /^-/) {
    $verbose  = 1; $v_mkey  = $ARGV[$n+1]; $ARGV[$n]=""; $ARGV[$n+1]=""; next CMD;}

  if ($ARGV[$n] =~ /^-o(.+)$/i)  {$outfile = $1; $ARGV[$n]=""; next CMD;}
  if ($ARGV[$n] =~ /^-i(.+)$/i)  {$infile  = $1; $ARGV[$n]=""; next CMD;}

  if ($ARGV[$n] =~ /^-d(.*)$/i)  {$dieonerr = 1; $maxerrs = $1; $ARGV[$n]=""; next CMD;}
  if ($ARGV[$n] =~ /^-s(.*)$/i)  {$suppress = 1; $suplist = $1; $ARGV[$n]=""; next CMD;}
  if ($ARGV[$n] =~ /^-vv(.*)$/i) {$vverbose = 1; $vv_mkey = $1; $ARGV[$n]=""; next CMD;}
  if ($ARGV[$n] =~ /^-v(.*)$/i)  {$verbose  = 1; $v_mkey  = $1; $ARGV[$n]=""; next CMD;}

  if ($ARGV[$n] =~ /^-t$/i)      {&listtests;}
  if ($ARGV[$n] =~ /^-tests$/i)  {&listtests;}
  if ($ARGV[$n] =~ /^-h$/i)      {&usage;}
  if ($ARGV[$n] =~ /^-help$/i)   {&usage;}
}
#
for (@ARGV) {!/^-/ && /.+/ && push(@filenames, $_);}
if (length($infile) > 0) {push(@filenames, $infile);}
if ($#filenames > 0) {print "TOO MANY FILES LISTED (" . 
  join(', ',@filenames) . ")\n"; &usage;}
if ($#filenames < 0) {print "NO INPUT FILE LISTED\n"; &usage;}
$file = @filenames[0];
for (@ARGV) {if (/^-/) {
  print "UNKNOWN COMMAND LINE SWITCH ($_)\n"; 
  &usage;}
}
#
if ($maxerrs > 0) {$dieonerr = 1;}
if ($dieonerr == 1) {
  if ($maxerrs =~ /\D/) {
    die "Bad -d Parameter ($maxerrs): Must be all digits\n";
  }
  if (length($maxerrs) == 0) {$maxerrs = 1;}
  if ($maxerrs == 0) {$dieonerr = 0;}
}
#
if ($suppress == 1) {
  if ($suplist =~ /[^\d\,]/) {
    die "Bad -s Parameter ($suplist): Must be digits and commas (,) only\n";
  }
  if (length($suplist) == 0) {$suppress = "S";}
  else {$suppress = $suplist;}
}
#
if (length($vv_mkey) > 0) {
  if (length($vv_mkey) != 8 || $vv_mkey =~ /\D/) {
    die "Bad -vv Parameter ($vv_mkey): Must be 8 digits\n";
  }
  if ($vv_mkey % 100 != 0) {
    die "Bad -vv Parameter ($vv_mkey): MKey must end with \'00\')\n";
  }
}
#
if (length($v_mkey) > 0) {
  if (length($v_mkey) != 8 || $v_mkey =~ /\D/) {
    die "Bad -v Parameter ($v_mkey): Must be 8 digits\n";
  }
  if ($vv_mkey % 100 != 0) {
    die "Bad -v Parameter ($v_mkey): MKey must end with \'00\')\n";
  }
}
#
if ($vverbose) {$verbose = 1; $v_mkey = $vv_mkey}
#
# Set up flags for suppressed tests
for ($i=1; $i<30; $i++) {$sup[$i] = 0;}
if (length($suppress) > 0 && $suppress ne "S") {
  print "Tests Inactive: ";
  foreach $i (split(",", $suppress)) {
    $sup[$i] = 1;
    print "$i ";
  }
  print "\nTests Active: ";
  for ($i=1; $i<30; $i++) {if ($sup[$i]==0) {print "$i ";}}
  print "\n";
}
else {
  if ($suppress eq "S") {print "Error Summary Only, ";}
  print "All Tests Active\n";
}
#
if (length($outfile) > 0) {
  $dieonerr = 0;
  $maxerrs = 0;
  $outflag = 1;
}
for ($i=1; $i<30; $i++) {$err[$i] = 0;}



#######
#
## 00 ##
if ($sup[0]==0) { 
# Quick Test to verify that we have a MEDS-ASCII file
#  a) Test first 8 characters of each line for acceptable MKey
#     Must be blanks or numbers, right justified
#  b) Warn if Station master records does not begin with nnnnnn00
#  c) Warn if Extension records do not belong with master record
#  d) Warn if master records are not in order
#  e) Warn if Extension records are not in order
# If passes (a) but fails (b) and/or (c):
#  f) Test for valid year, month & day -- failure is fatal
# If 5 lines, or more than half of total lines fail test (f), 
# then the file is judged not to be a MEDS-ASCII file (fatal error).
#
#  Open compressed or non-compressed files
if ((substr($file, length($file)-3,3) eq '.gz') || (-B $file) ){
  # GZIP file
  open(INFILE, "gzip -dc $file | ") || die "Cannot open file $file: $!\n";
  print "Opened GZIP compressed file: $file\n";
}
else {
  #regular ASCII file
  open(INFILE, "$file") || die "Cannot open file $file: $!\n";
  print "Opened non-compressed file: $file\n";
}

print "\nOpened file $file -- Quick test of MKeys in MEDS-ASCII format\n";
$M = 0;
$lines = 0;
$stations = 0;
$badkeys = 0;
$badrecords = 0;
$allblankkeys = 0;
$leadblankkeys = 0;
$notex = 0;
$notinorder = 0;
$notsorted = 0;
$exrecs = 0;
while (<INFILE>) {
  $lines += 1;
  $MKey = substr($_,0,8);
  $mkeyproblem = 0;
  $mkeynonnum = 0;
  if ($MKey =~ /\d\d\d\d\d\d\d\d/) {
    $mkeyproblem = 0;
  }
  elsif ($MKey =~ /        /) {
    $mkeyproblem = 1;
    $mkeynonnum = 1;
    $allblankkeys++;
  }
  elsif ($MKey =~ / *\d+$/) {
    $mkeyproblem = 1;
    $leadblankkeys++;
  }
  elsif ($MKey =~ /\D/) {
    $mkeyproblem = 1;
    $mkeynonnum = 1;
    $badkeys++;
  }
  if ($mkeyproblem == 1) {
    $Obs_Year      = substr($_,  26,  4);
    $Obs_Month     = substr($_,  30,  2);
    $Obs_Day       = substr($_,  32,  2);
    if ($Obs_Year < 1900 || $Obs_Year > 2099 ||
    $Obs_Month < 1 || $Obs_Month > 12 ||
    $Obs_Day < 1 || $Obs_Day > 31) {
      $badrecords++;
      if ($badrecords <= 10) {
        print "  MKey problem ($MKey)and bad date ($Obs_Year$Obs_Month$Obs_Day) at line $lines\n";
      }
      if ($badrecords == 11) {
        print "More than 10 bad records\n";
      }
    }
  }

  if ($mkeynonnum == 0) {
    if ($MKey % 100 == 0) {
      $stations += 1;
      $oldm = $M;
      $M = substr($MKey,0,6);
      if ($M <= $oldm) {$notsorted += 1;}
      $exrecs = 0;
    }
    else {
      $exrecs += 1;
      $MKeyex = $M . sprintf("%2.2d",$exrecs);
      if (substr($MKey,0,6) != $M) {$notex += 1;}
      elsif ($MKey != $MKeyex) {$notinorder += 1;}
    }
  }
}
close INFILE;

print "  $lines lines, $stations Stations found";
$mkeyanomalies = $allblankkeys + $leadblankkeys + $notsorted + $notex + $notinorder;
if ($badkeys == 0 && $allblankkeys == 0 &&$notex == 0 && 
  $notinorder == 0 && $notsorted == 0) {
  print ", All MKeys in order.";
}
print "\n";
if ($badrecords > 0) {
  if ($badrecords > 5 || $badrecords > $lines/2) {
    print "  THIS FILE IS MOST LIKELY NOT IN MEDS-ASCII FORMAT!\n";
  }
  $message = "line has";
  if ($badrecords > 1) {$message = "lines have";}
  print "  $badrecords $message non-standard MKey AND invalid date\n";
  print "  FATAL ERROR: Processing will be halted after testing for control characters\n\n";
  $FATAL = 1;
}
if ($allblankkeys || $leadblankkeys || $notex || $notinorder || $notsorted) {
  $err[0]++;
  print "MKey problems:\n";
  if ($allblankkeys > 0) { print "  $allblankkeys lines have all blanks in MKey\n";}
  if ($leadblankkeys > 0) { print "  $leadblankkeys lines have leading blanks in MKey\n";}
  if ($notex == 0) {
    if ($notsorted > 0) {
      print "  WARNING: $notsorted Master Record Mkeys out of sort order.\n";
    }
    if ($notinorder > 0) {
      print "  WARNING: $notinorder extension records with Mkey not in increasing numeric order.\n";
    }
  }
  if ($notex > 0) {
    print "  $notex extension records with MKey not matching Master.\n";
  }
}
} # end of test 00
#
##########
#
## 01 ##
## 02 ##
if ($sup[1]==0 || $sup[2]==0) {
  # Test file for newline and control characters ##
  #
  # Find expected newline character(s)
  open (OUT, "> TEMPTESTMEDS.TXT") || die "Can't open test output file: $!\n";
  print OUT "\n";
  close OUT;
  open (INP, "TEMPTESTMEDS.TXT") || die "Can't open test input file: $!\n";
  binmode INP;
  $expected_eol = '';
  read(INP, $expected_eol, 1024);
  close INP;
  unlink "TEMPTESTMEDS.TXT";
  $expected_eol =~ s/\012/LF/;
  $expected_eol =~ s/\015/CR/;
  $expected_eol =~ s/CRLF/CR\+LF/;
  #
  #  Open compressed or non-compressed files
  if ((substr($file, length($file)-3,3) eq '.gz') || (-B $file) ){
    # GZIP file
    open(BINFILE, "gzip -dc $file | ") || die "Cannot open file $file: $!\n";
    print "Opened GZIP compressed file: $file\n";
  }
  else {
    #regular ASCII file
    open(BINFILE, "$file") || die "Cannot open file $file: $!\n";
    print "Opened non-compressed file: $file\n";
  }

  print "\nReOpened file $file -- testing for control characters\n";
  binmode BINFILE;
  while (read(BINFILE, $buf, 1024)) {
    $bufn++;
    if ($bufn == 1) {$MKey = substr($buf,0,8);}
    $buf =~ s/\012/\*LF\*/g;
    $buf =~ s/\015\*LF\*/\*CR\*\*LF\*/g;
    $buf =~ s/\015$/\*CR\*/;
    $buf =~ /\*LF\*(\d{8,8})/;
    $buf =~ s/^\*LF\*//;
    if (length($1)==8) {$MKey = $1;}
    if ($buf =~ /([\000-\037])/) {
      $asciival = ord $1;
      $errmsg = "[02] ASCII control character $asciival at or near Mkey = $MKey";
      $asciierrcount++;
      if ($sup[2]==0) {
        &onerr;
        $err[2]++;
      }
    }
    if ($sup[1]==0) {
      if ($crlf < 1 && $buf =~ /\*CR\*\*LF\*/) {
        $crlf++;
        print "  [01] Newline is CR+LF ($expected_eol expected)\n";
        $lennewline = 2;
      }
      if ($lf < 1 && $crlf < 1 && $buf =~ /\*LF\*/) {
        $lf++;
        print "  [01] Newline is LF ($expected_eol expected)\n";
        $lennewline = 1;
      }
    }
  }
  if ($lf < 1 && $crlf < 1 && $lennewline < 1) {
    print "  [01] No Newline Marker Found\n";
    print "  FATAL ERROR\n";
    $FATAL = 1;
  }
  if ($lennewline == 2 && $expected_eol eq 'LF') {
    print "WINDOWS-style Newline (CR+LF) is not proper in a UNIX environment\n";
    print "Use a file conversion utility on the file and try again.\n";
    print "  FATAL ERROR\n";
    $FATAL = 1;
  }
  if ($lennewline == 1 && $expected_eol eq 'CR+LF') {
    print "UNIX-style Newline (LF) is not proper in a WINDOWS environment\n";
    print "Use a file conversion utility on the file and try again.\n";
    print "  FATAL ERROR\n";
    $FATAL = 1;
  }
  close BINFILE;
} # End test 01 & 02
#
if ($FATAL) {
  if ($err[2] > 0) {print "\n$err[2] ASCII control characters found\n\n";}
  die "PROGRAM TERMINATING DUE TO FATAL ERROR\n";
}
#
#######
#
#  Open compressed or non-compressed files
if ((substr($file, length($file)-3,3) eq '.gz') || (-B $file) ){
  # GZIP file
  open(INFILE, "gzip -dc $file | ") || die "Cannot open file $file: $!\n";
  print "Opened GZIP compressed file: $file\n";
}
else {
  #regular ASCII file
  open(INFILE, "$file") || die "Cannot open file $file: $!\n";
  print "Opened non-compressed file: $file\n";
}

print "\nReOpened file $file -- testing for format and consistency\n\n";
if ($asciierrcount > 0) {
  if ($asciierrcount > 1) {$s = "s"; $were = "was";}
  print "NOTE: $asciierrcount ASCII control character$s $were found.\n";
  print "  Control character errors may cause format frame shifts or\n";
  print "  truncations which will affect format testing of subsequent records.\n\n";
}
#
while (<INFILE>) {
  $rec = 0;
  $seg = 0;
  $MKey          = substr($_,   0,  8);
  if ($MKey % 100 == 0 || $mkeyanomalies > 0) {
    if ($v_mkey > 0) {
      if ($MKey == $v_mkey) { $verbose = 1;}
      else {$verbose = 0;}
    }
    if ($vv_mkey > 0) {
      if ($MKey == $vv_mkey) { $vverbose = 1;}
      else {$vverbose = 0;}
    }
#
    $extcount = 0;
    $reccount++;
    $One_Deg_sq    = substr($_,   8,  8);
    $Cruise_ID     = substr($_,  16, 10);
    $Obs_Year      = substr($_,  26,  4);
    $Obs_Month     = substr($_,  30,  2);
    $Obs_Day       = substr($_,  32,  2);
    $Obs_Time      = substr($_,  34,  4);
    $Data_Type     = substr($_,  38,  2);
    $Iumsgno       = substr($_,  40, 12);
    $Stream_Source = substr($_,  52,  1);
    $Uflag         = substr($_,  53,  1);
    $MEDS_Sta      = substr($_,  54,  8);
#
    $Latitude      = substr($_,  62,  8);
    $Longitude     = substr($_,  70,  9);
    $Q_Pos         = substr($_,  79,  1);
    $Q_Date_Time   = substr($_,  80,  1);
    $Q_Record      = substr($_,  81,  1);
    $Up_Date       = substr($_,  82,  8);
    $Bul_Time      = substr($_,  90, 12);
    $Bul_Header    = substr($_, 102,  6);
    $Source_ID     = substr($_, 108,  4);
    $Stream_Ident  = substr($_, 112,  4);
    $QC_Version    = substr($_, 116,  4);
    $Data_Avail    = substr($_, 120,  1);
    $No_Prof       = substr($_, 121,  2);
    $Nparms        = substr($_, 123,  2);
    $Nsurfc        = substr($_, 125,  2);
    $Num_Hists     = substr($_, 127,  3);
#
    if($verbose){print "\n\nMaster Record Part 1\n\'", substr($_, 0, 62), "\'\n";}
    if($verbose){print "MKey          = \'$MKey\'\n";}
    if($verbose){print "One_Deg_sq    = \'$One_Deg_sq\'\n";}
    if($verbose){print "Cruise_ID     = \'$Cruise_ID\'\n";}
## 03 ##
    if ($sup[3]==0 && $Cruise_ID =~ /([^A-Za-z0-9 ])/) {
      $errmsg = "[03] Cruise_ID contains an illegal character ($1)";
      &onerr;
      $err[3]++;
    }
## 04 ##
    if ($sup[4]==0 && $Cruise_ID !~ /\S/) {
      $errmsg = "[04] Cruise_ID contains all blanks";
      &onerr;
      $err[4]++;
    }
    if($verbose){print "Obs_Year      = \'$Obs_Year\'\n";}
    if($verbose){print "Obs_Month     = \'$Obs_Month\'\n";}
    if($verbose){print "Obs_Day       = \'$Obs_Day\'\n";}
## 05 ## 
    if ($sup[5]==0) {
      $yyyy=$Obs_Year; $mm = $Obs_Month; $dd = $Obs_Day;
      &testdate;
      if ($err > 0) {
        $errmsg = "[05] Master Record Obs Date $errmsg ($yyyy$mm$dd)"; 
        &onerr;
        $err[5]++;
      }
    }
    if($verbose){print "Obs_Time      = \'$Obs_Time\'\n";}
## 06 ##
    if ($sup[6]==0) {
      $hhmm = $Obs_Time; &testtime;
      if (err > 0) {
        $errmsg = "[06] Obs_Time $errmsg";
        &onerr;
        $err[6]++;
      }
    }
    if($verbose){print "Data_Type     = \'$Data_Type\'\n";}
    if($verbose){print "Iumsgno       = \'$Iumsgno\'\n";}
    if($verbose){print "Stream_Source = \'$Stream_Source\'\n";}
    if($verbose){print "Uflag         = \'$Uflag\'\n";}
    if($verbose){print "MEDS_Sta      = \'$MEDS_Sta\'\n";}
#
    if($verbose){print "\nMaster Record Part 2\n\'", substr($_, 62, 68), "\'\n";}
    if($verbose){print "Latitude      = \'$Latitude\'\n";}
    if($verbose){print "Longitude     = \'$Longitude\'\n";}
## 07 ##
    if ($sup[7]==0) {
      $ilon = int($Longitude + 181);
      if ($ilon > 360) {$ilon = 1;}
      $ilat = int($Latitude + 91);
      if ($ilat > 180) {$ilat = 180;}
      $onesq = $ilon * 1000 + $ilat;
      if ($onesq != $One_Deg_sq) {
        $neighbor = "";
        $One_Deg_sq =~ /(\d+)(\d\d\d)$/;
        $dlon = $1 - $ilon;
        $dlat = $2 - $ilat;
        if (($dlat <= 1 && $dlat >= -1) && 
          (($dlon <= 1 && $dlon >= -1) || $dlon == 359 || $dlon == -359))
          {$neighbor = "(neighboring square)";}
        $errmsg = "[07] One_Deg_sq does not match lat & lon:\n";
        $errmsg .= "  Calculated $onesq from lat=$Latitude, lon=$Longitude; ";
        $errmsg .= "Found $One_Deg_sq $neighbor";
        &onerr;
        $err[7]++;
      }
    }
#
    if($verbose){print "Q_Pos         = \'$Q_Pos\'\n";}
    if($verbose){print "Q_Date_Time   = \'$Q_Date_Time\'\n";}
    if($verbose){print "Q_Record      = \'$Q_Record\'\n";}
    if($verbose){print "Up_Date       = \'$Up_Date\'\n";}
## 05 ## 
    # 7/2/2003 added Up_Date test (yyyymmdd)
    if ($sup[5]==0) {
      $yyyy=substr($Up_Date, 0, 4); 
      $mm = substr($Up_Date, 4, 2); 
      $dd = substr($Up_Date, 6, 2);
      &testdate;
      if ($err > 0) {
        $errmsg = "[05] Up_Date $errmsg ($yyyy$mm$dd)"; 
        &onerr;
        $err[5]++;
      }
    }
    if($verbose){print "Bul_Time      = \'$Bul_Time\'\n";}
    if($verbose){print "Bul_Header    = \'$Bul_Header\'\n";}
    if($verbose){print "Source_ID     = \'$Source_ID\'\n";}
    if($verbose){print "Stream_Ident  = \'$Stream_Ident\'\n";}
    if($verbose){print "QC_Version    = \'$QC_Version\'\n";}
    if($verbose){print "Data_Avail    = \'$Data_Avail\'\n";}
    if($verbose){print "No_Prof       = \'$No_Prof\'\n";}
## 08 ##
    if ($sup[8]==0 && $No_Prof == 0) {
      $errmsg = "[08] Profile data missing in this station (No_Prof=0)";
      &onerr;
      $err[8]++;
    }
    if($verbose){print "Nparms        = \'$Nparms\'\n";}
    if($verbose){print "Nsurfc        = \'$Nsurfc\'\n";}
    if($verbose){print "Num_Hists     = \'$Num_Hists\'\n";}
#
    $B = 130;
    for ($n = 1; $n <= $No_Prof; $n++) {
      $Prof_Inf[$n] = substr($_, $B, 14);
      $B += 14;
      $No_Seg[$n] = substr($Prof_Inf[$n], 0, 2);
      $Prof_Type[$n] = substr($Prof_Inf[$n], 2, 4);
      $Dup_flag[$n] = substr($Prof_Inf[$n], 6, 1);
      $Digit_Code[$n] = substr($Prof_Inf[$n], 7, 1);
      $Standard[$n] = substr($Prof_Inf[$n], 8, 1);
      $Deep_Depth[$n] = substr($Prof_Inf[$n], 9, 5);
#
      if($verbose){print "\nProfile Info Group $n\n\'$Prof_Inf[$n]\'\n";}
      if($verbose){print "No_Seg     = \'$No_Seg[$n]\'\n";}
      if($verbose){print "Prof_Type  = \'$Prof_Type[$n]\'\n";}
      if($verbose){print "Dup_flag   = \'$Dup_flag[$n]\'\n";}
      if($verbose){print "Digit_Code = \'$Digit_Code[$n]\'\n";}
      if($verbose){print "Standard   = \'$Standard[$n]\'\n";}
      if($verbose){print "Deep_Depth = \'$Deep_Depth[$n]\'\n";}
## 09 ##
      if ($sup[9]==0 && length($Prof_Inf[$n]) < 14) {
        $errmsg = "[09] Profile Info Group $n is truncated";
        &onerr;
        $err[9]++;
      }
    }
#
    for ($n = 1; $n <= $Nparms; $n++) {
      $SPGp[$n] = substr($_, $B, 15);
      $B += 15;
      $Pcode = substr($SPGp[$n], 0, 4);
      $Parm  = substr($SPGp[$n], 4, 10);
      $Q_Parm = substr($SPGp[$n], 14, 1);
      if($verbose){print "\nSurface Parameter Group $n\n\'$SPGp[$n]\'\n";}
      if($verbose){print "Pcode  = \'$Pcode\'\n";}
      if($verbose){print "Parm   = \'$Parm\'\n";}
      if($verbose){print "Q_Parm = \'$Q_Parm\'\n";}
## 10 ##
      if ($sup[10]==0 && length($SPGp[$n]) < 15) {
        $errmsg = "[10] Surface Parameter Group $n is truncated";
        &onerr;
        $err[10]++;
      }
    }
#
    if ($Nparms == 0 && $verbose) {print "\nNo Surface Parameter Groups\n";}
    for ($n = 1; $n <= $Nsurfc; $n++) {
      $SCGp[$n] = substr($_, $B, 15);
      $B += 15;
      $SRFC_Code = substr($SCGp[$n], 0, 4);
      $SRFC_Parm = substr($SCGp[$n], 4, 10);
      $SRFC_Q_Parm = substr($SCGp[$n], 14, 1);
      if($verbose){print "\nSurface Code Group $n\n\'$SCGp[$n]\'\n";}
      if($verbose){print "SRFC_Code   = \'$SRFC_Code\'\n";}
      if($verbose){print "SRFC_Parm   = \'$SRFC_Parm\'\n";}
      if($verbose){print "SRFC_Q_Parm = \'$SRFC_Q_Parm\'\n";}
# 11 ##
      if ($sup[11]==0 && length($SCGp[$n]) < 15) {
        $errmsg = "[11] Surface Code Group $n is truncated";
        &onerr;
        $err[11]++;
      }
    }
#
    if ($Nsurfc == 0 && $verbose) {print "\nNo Surface Code Groups\n";}
    for ($n = 1; $n <= $Num_Hists; $n++) {
      $HGp[$n] = substr($_, $B, 42);
      $B += 42;
      $Ident_Code = substr($HGp[$n], 0, 2);
      $PRC_Code = substr($HGp[$n], 2, 4);
      $Version = substr($HGp[$n], 6, 4);
      $PRC_Date = substr($HGp[$n], 10, 8);
      $Act_Code = substr($HGp[$n], 18, 2);
      $Act_Parm = substr($HGp[$n], 20, 4);
      $Aux_ID = substr($HGp[$n], 24, 8);
      $Previous_Val = substr($HGp[$n], 32, 10);
      if($verbose){print "\nHistory Group $n\n\'$HGp[$n]\'\n";}
      if($verbose){print "Ident_Code   = \'$Ident_Code\'\n";}
      if($verbose){print "PRC_Code     = \'$PRC_Code\'\n";}
      if($verbose){print "Version      = \'$Version\'\n";}
      if($verbose){print "PRC_Date     = \'$PRC_Date\'\n";}
      if($verbose){print "Act_Code     = \'$Act_Code\'\n";}
      if($verbose){print "Act_Parm     = \'$Act_Parm\'\n";}
      if($verbose){print "Aux_ID       = \'$Aux_ID\'\n";}
      if($verbose){print "Previous_Val = \'$Previous_Val\'\n";}
## 12 ##
      if ($sup[12]==0 && length($HGp[$n]) < 42) {
        $errmsg = "[12] History Group $n is truncated";
        &onerr;
        $err[12]++;
      }
      $yyyy = substr($PRC_Date, 0, 4);
      $mm = substr($PRC_Date, 4, 2);
      $dd = substr($PRC_Date, 6, 2);
## 05 ##
      if ($sup[5]==0) {
        &testdate;
        if ($err > 0) {
          $errmsg = "[05] Date in History Gp $n $errmsg ($yyyy$mm$dd)";
          &onerr;
          $err[5]++;
        }
      }
## 13 ##
      if ($sup[13]==0 && $yyyy < 1991) {
        $errmsg = "[13] Date in History Gp $n is prior to 1991 ($yyyy)";
        &onerr;
        $err[13]++;
      }
      if ($sup[13]==0 && $n > 1 && $PRC_Date < $prev_PRC_Date) {
        $errmsg = "[13] History Gp $n not in date order";
        &onerr;
        $err[13]++;
      }
      $prev_PRC_Date = $PRC_Date;
    }
## 14 ##
    if ($sup[14]==0 && substr($_,$B) ne "\n") {
      $a = $_;
      $a =~ s/[\012\015]+$//;
      $found = length($a); 
      $errmsg = "[14] Length of Master Record (expected $B, found $found) ";
      if ($found > $B && $verbose) {
        print "\nEXTRA MATERIAL:\n";
        $extra = substr($_,$B);
        $extra =~ s/[\012\015]+$//;
        print "\'$extra\'\n";
      }
      &onerr;
      $err[14]++;
    }
  }
## 15 ##
  else {
    if ($sup[15]==0) {
      # ($MKey % 100 not equal to 0)
      $errmsg = "[15] MKey mismatch: Expected master record, found extension record";
      &onerr;
      $err[15]++;
    }
  }
#
  undef %DepPres;
  undef %Tdpq;
  undef %Tval;
  undef %Tpvq;
  undef %Sdpq;
  undef %Sval;
  undef %Spvq;
#
  $Total_Depths = 0;
  for ($rec = 1; $rec <= $No_Prof; $rec++) {
    $prev_depth = -1;
    for ($seg = 1; $seg <= $No_Seg[$rec]; $seg++) {
      $_ = <INFILE>;
      if($verbose){
        print "\nData Record $rec Segment $seg\n";
        print "\'", substr($_, 0, 63), "\'\n";
      }
      $MKey_r = substr($_, 0, 8);
      if($verbose){print "MKey_r         = \'$MKey_r\'\n";}
## 16 ##
      if ($sup[16]==0 && $mkeyanomalies == 0 && $MKey_r % 100 == 0) {
        $errmsg = "[16] MKey mismatch: Expected extension record, found master record";
        &onerr;
        $err[16]++;
      }
      else {
## 17 ##
        $extcount++;
        $MKey_r_calc = $MKey + $extcount;
        if ($sup[17]==0 && $mkeyanomalies == 0 && $MKey_r != $MKey_r_calc) {
          $MKey_r_c = sprintf ("%8.8lu", $MKey_r_calc);
          $errmsg = "[17] MKey of extension record should be $MKey_r_c";
          &onerr;
          $err[17]++;
        }
      }
#
      $One_Deg_sq_r    = substr($_,   8,  8);
      $Cruise_ID_r     = substr($_,  16, 10);
      $Obs_Year_r      = substr($_,  26,  4);
      $Obs_Month_r     = substr($_,  30,  2);
      $Obs_Day_r       = substr($_,  32,  2);
      $Obs_Time_r      = substr($_,  34,  4);
      $Data_Type_r     = substr($_,  38,  2);
      $Iumsgno_r       = substr($_,  40, 12);
#
      if($verbose){
        print "One_Deg_sq_r   = \'$One_Deg_sq_r\'\n";
        print "Cruise_ID_r    = \'$Cruise_ID_r\'\n";
        print "Obs_Year_r     = \'$Obs_Year_r\'\n";
        print "Obs_Month_r    = \'$Obs_Month_r\'\n";
        print "Obs_Day_r      = \'$Obs_Day_r\'\n";
        print "Obs_Time_r     = \'$Obs_Time_r\'\n";
        print "Data_Type_r    = \'$Data_Type_r\'\n";
        print "Iumsgno_r      = \'$Iumsgno_r\'\n";
      }
## 05 ##
      if ($sup[5]==0) {
        $yyyy=$Obs_Year_r; $mm = $Obs_Month_r; $dd = $Obs_Day_r;
        &testdate;
        if ($err > 0) {
          $errmsg = "[05] Obs Record Obs Date $errmsg ($yyyy$mm$dd)"; 
          &onerr;
          $err[5]++;
        }
      }
## 18 ##
      if ($sup[18]==0) {
        $e = "";
        if ($One_Deg_sq_r ne $One_Deg_sq) {$e = "One_Deg_sq ";}
        if ($Cruise_ID_r  ne $Cruise_ID ) {$e .= "Cruise_ID ";}
        if ($Obs_Year_r   ne $Obs_Year  ) {$e .= "Obs_Year ";}
        if ($Obs_Month_r  ne $Obs_Month ) {$e .= "Obs_Month ";}
        if ($Obs_Day_r    ne $Obs_Day   ) {$e .= "Obs_Day ";}
        if ($Obs_Time_r   ne $Obs_Time  ) {$e .= "Obs_Time ";}
        if ($Data_Type_r  ne $Data_Type ) {$e .= "Data_Type ";}
        if ($Iumsgno_r    ne $Iumsgno   ) {$e .= "Iumsgno ";}
        if (length($e) > 0){
          $e =~ s/ $//;
          $e =~ s/ /, /g;
          $errmsg = "[18] Obs Data Mismatch in Data Record:\n  ($e)";
          &onerr;
          $err[18]++;
        }
        $Profile_Type_r  = substr($_,  52,  4);
        if($verbose){print "Profile_Type_r = \'$Profile_Type_r\'\n";}
      }
## 19 ##
      if ($sup[19]==0 && $Prof_Type[$rec] != $Profile_Type_r) {
        $errmsg = "[19] Profile_Type (= $Profile_Type) differs from Prof_Type";
        $errmsg .= " (= $Prof_Type[$rec])from Profile Info group";
        &onerr;
        $err[19]++;
      }
      $Profile_Type[$rec] = $Profile_Type_r if ($seg == 1);
## 20 ##
      if ($sup[20]==0 && $seg > 1 && $Profile_Type[$rec] != $Profile_Type_r) {
        $errmsg = "[20] Profile_Type mismatch among different segments of one record";
        &onerr;
        $err[20]++;
      }
      $Profile_Seg  = substr($_, 56, 2);
      if($verbose){print "Profile_Seg    = \'$Profile_Seg\'\n";}
## 21 ##
      # zero filled version disabled: 
      # if ($sup[21]==0 && $Profile_Seg !~ /^\d\d$/) {
      #   $errmsg = "[21] Profile_Seg ('$Profile_Seg') not all numeric & zero filled";
      # ...
      if ($sup[21]==0 && $Profile_Seg !~ /^(\d| )\d$/) {
        $errmsg = "[21] Profile_Seg ('$Profile_Seg') not all numeric";
        &onerr;
        $err[21]++;
      }
## 22 ##
      if ($sup[22]==0 && $Profile_Seg != $seg) { 
        $errmsg = "[22] Profile_Seg Mismatch -- Segment $seg labeled \'$Profile_Seg\'";
        &onerr;
        $err[22]++;
      }
      $No_Depths  = substr($_, 58, 4);
      if($verbose){print "No_Depths      = \'$No_Depths\'\n";}
## 23 ##
      if ($sup[23]==0 && $No_Depths <= 0) {
        $errmsg = "[23] Illegal value for No_Depths = $No_Depths <= 0";
        &onerr;
        $err[23]++;
      }
      $D_P_Code_r = substr($_, 62, 1);
      if($verbose){print "D_P_Code_r     = \'$D_P_Code_r\'\n";}
## 24 ##
      if ($sup[24]==0 && $D_P_Code_r !~ /D|P/) {
        $errmsg = "[24] D_P_Code is $D_P_Code_r; must be D or P";
        &onerr;
        $err[24]++;
      }
      $D_P_Code[$rec] = $D_P_Code_r if ($seg == 1);
## 25 ##
      if ($sup[25]==0 && $seg > 1 && $D_P_Code[$rec] != $D_P_Code_r) {
        $errmsg = "[25] D_P_Code mismatch among different segments of one record";
        &onerr;
        $err[25]++;
      }
#
      $B = 63;
      for ($d = 1; $d <= $No_Depths; $d++) {
        $DP = "$rec $seg $d";
        $DepPres{$DP} = substr($_, $B, 6);
        $B += 6;
        $Pdpq{$DP} = substr($_, $B, 1);
        $B += 1;
        $Pval{$DP} = substr($_, $B, 9);
        $B += 9;
        $Ppvq{$DP} = substr($_, $B, 1);       
        $B += 1;
        if ($vverbose) {
          printf("%4d: ", $d);
          print "[$DepPres{$DP}] [$Pdpq{$DP}] [$Pval{$DP}] [$Ppvq{$DP}]\n";
        }
## 26 ##
        if ($sup[26]==0 && $DepPres{$DP} < $prev_depth) {
          $errmsg = "[26] Reversed Depth where Param_Gp_Num=$d\n";
          $errmsg .= "  ($prev_depth --> $DepPres{$DP})";
          &onerr;
          $err[26]++;
        }
      }
## 27 ##
      if ($sup[27]==0 && substr($_,$B) ne "\n") {
        $errmsg = "[27] Record Length Error in Data Record";
        &onerr;
        $err[27]++;
      }
      $Total_Depths += $No_Depths;
    }
## 28 ## (Changed from int != int to int-int>1 7/1/2005
    if ($sup[28]==0 && abs(int($Deep_Depth[$rec]) - int($DepPres{$DP})) > 1) {
      $errmsg = "[28] Last Depth ($DepPres{$DP}) does not equal Deep_Depth ($Deep_Depth[$rec])";
      &onerr;
      $err[28]++;
    }
  }
## 29 ##
  undef @keys;
  @keys = sort keys %DepPres;
  $Data_Count = @keys;

  if ($sup[29]==0 && $Total_Depths != $Data_Count) {
    $errmsg = "Data Count Mismatch -- ";
    $errmsg .= "[29] Total_Depths = $Total_Depths  Data_Count = $Data_Count";
    &onerr;
    $err[29]++;
  }
}
close INFILE;
$errlabel = "Errors";
if ($errcount == 1) {$errlabel = "Error";}
if ($errcount == 0) {$errcount = "No";}
$reclabel = "Records";
if ($reccount == 1) {$reclabel = "Record";}
print "Finished Testing $file\n";
print "$reccount Logical Station $reclabel, $errcount $errlabel Found\n\n";
if ($stations != $reccount) {
  print "WARNING: The number of logical stations found ($reccount) does not match\n";
  print "the number of records with appropriate MKey values for master records ($stations).\n";
  if ($mkeyanomalies > 0) {
    print "This file has MKey values that do not adhere to the MEDS-ASCII standard,\n";
    print "and so some format consistency tests could not be performed.\n";
  }
  print "This file may not be in MEDS-ASCII format, or it may have been damaged.\n";
  print "CHECK THIS ERROR REPORT CAREFULLY -- USE THIS FILE WITH CAUTION!\n\n";
}

@errdescr = ('',
  'Newline',
  'ASCII Control Chars',
  'Cruise_ID Odd Chars',
  'Cruise_ID All Blanks',
  'Invalid Date',
  'Invalid Time',
  'One_Deg_sq',
  'No_Prof',
  'Profile Info Group           <= CRITICAL ERROR!',
  'Surface Param Group Length   <= CRITICAL ERROR!',
  'Surface Code Group Length    <= CRITICAL ERROR!',
  'History Group Length         <= CRITICAL ERROR!',
  'History Date Order',
  'Master Record Length         <= CRITICAL ERROR!',
  'MKey in Master Record',
  'MKey in Extension Record',
  'Extension MKey Sequence',
  'Master & Extension Fields',
  'Prof_Type in Obs & Prof Info',
  'Profile_Type in Rec Segments',
  'Segment No. Not Numeric',
  'Profile_Seg & Segments Found',
  'No_Depths < 1',
  'D_P_Code Must Be D or P',
  'D_P_Code Diff Among Segments',
  'Depths Not Increasing',
  'Data Record Length           <= CRITICAL ERROR!',
  'Deep_Depth != Last Depth',
  'Total_Depths != Depths Found'
);
$critical = 0;
if ($errcount > 0) {
  print "    Err[ #]   COUNT  DESCRIPTION\n";
  print "    -------   -----  -----------\n";
  for ($i=1;  $i<30;  $i++) {
    if ($err[$i] > 0) {
      printf "    Err[%2.2d] = %5d  %s\n", $i, $err[$i], $errdescr[$i];
      if ($i==9 || $i==10  || $i==11  || $i==12  || $i==14  || $i==27) {
        $critical = 1;
      }
    }
  }
}
print "------------\n";
#
if (!$outflag) {exit $critical;}
if ($outflag) {
  if ($critical) {
    print "CRITICAL ERROR(S) -- No output file created\n";
    exit $critical;
  }
  #open(INFILE, $file) || die "Can't open $file: $!\n";
  #  Open compressed or non-compressed files
  if ((substr($file, length($file)-3,3) eq '.gz') || (-B $file) ){
    # GZIP file
    open(INFILE, "gzip -dc $file | ") || die "Cannot open file $file: $!\n";
    print "Opened GZIP compressed file: $file\n";
  }
  else {
    #regular ASCII file
    open(INFILE, "$file") || die "Cannot open file $file: $!\n";
    print "Opened non-compressed file: $file\n";
  }

  open(OUTFILE, ">".$outfile) || die "Can't open $outfile for output: $!\n";
  print "\nReOpened file $file for input\n";
  print "Opened file $outfile for output\n";
  print "Creating new history records... ";
  $Ident_Code   = "NO";  # => NODC           
  $PRC_Code     = $testmeds_PRC_Code;
  $Version      = $deltaver;
  $PRC_Date     = $sysdate;
  $Act_Code = "CR";   # => Create Record
  $Act_Parm = "RCRD"; # => Actions are taken against the entire record
  $Aux_ID       = "9999.999";
  $Previous_Val = "  9999.999";
  $History = $Ident_Code . $PRC_Code . $Version;
  $History .= $PRC_Date . $Act_Code . $Act_Parm;
  $History .= $Aux_ID . $Previous_Val;
  while (<INFILE>) {
    $No_Prof       = substr($_, 121,  2);
    $B = 130;
    for ($n = 1; $n <= $No_Prof; $n++) {
      $Prof_Inf[$n] = substr($_, $B, 14);
      $B += 14;
      $No_Seg[$n] = substr($Prof_Inf[$n], 0, 2);
    }
    # Add a new history record
    $Num_Hists     = substr($_, 127,  3);
    $New_Num_Hists = sprintf("%3.3s",$Num_Hists + 1);
    substr($_, 127,  3) = $New_Num_Hists;
    s/[\012\015]+$//; # instead of chomp -- works on either DOS or UNIX files
    print OUTFILE $_, $History, "\n";
    for ($rec = 1; $rec <= $No_Prof; $rec++) {
      for ($seg = 1; $seg <= $No_Seg[$rec]; $seg++) {
        $_ = <INFILE>;
        s/[\012\015]+$//;
        print OUTFILE "$_\n";
      }
    }
  }
  close INFILE;
  close OUTFILE;
  print "Done.\n";
}
# End of main program
# -------------------
#
sub onerr {
  $errcount++;
  if ($suppress ne "S") {
    if ($verbose) {print "\n*****";}
    print "\nERROR at MKey = $MKey";
    if ($rec > 0 || $seg > 0) {
      print " rec = $rec seg = $seg MKey_r = $MKey_r";
    }
    print "\n  $errmsg\n";
    if ($verbose) {print "*****\n";}
  }
  if ($dieonerr) {
    if ($maxerrs == 1) {
      print "Program Terminated at First Error, $reccount Records Tested\n";
      die "Program Terminated at First Error\n";
    }
    if ($maxerrs > 0 && $errcount >= $maxerrs) {
      print "\nToo Many Errors: $errcount Errors, $reccount Records Tested -- Program Terminated\n";
      die "Program Terminated After $errcount Errors\n";
    }
  }
}
#
sub gmttagdate {
  my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime;
  $year = sprintf("%04d", $year + 1900);
  $mon = sprintf("%02d", $mon + 1);
  $mday  = sprintf("%02d", $mday);
  return $year.$mon.$mday;
}
#
sub testdate {
  # uses $yyyy, $mm, $dd, $sysdate
  # sets $err and $errmsg
  #
  FINDERR: {
    $err = 1, last FINDERR if ($yyyy <= 1900);
    $err = 1, last FINDERR if ($sysdate < $yyyy . $mm . $dd);
    $err = 2, last FINDERR if ($mm !~ /\d\d/);
    $err = 2, last FINDERR if ($dd !~ /\d\d/);
    $err = 3, last FINDERR if ($mm < 1 || $mm > 12);
    $err = 4, last FINDERR if ($yyyy % 4 > 0 && $mm == 2 && $dd > 28);
    $err = 4, last FINDERR if ($mm == 2 && $dd > 29);
    $err = 4, last FINDERR if ($mm =~ /09|04|06|11/ && $dd > 30);
    $err = 4, last FINDERR if ($dd > 31);
    $err = 0
  }
  if ($err == 1) {$errmsg = "is outside valid range";}
  if ($err == 2) {$errmsg = "includes non-numeric characters";}
  if ($err == 3) {$errmsg = "Month is outside valid range";}
  if ($err == 4) {$errmsg = "Day is outside valid range";}
}
#
sub testtime {
  # uses $hhmm
  # Sets $err and $errmsg
  #
  $err = 0;
  $hh = substr($hhmm, 0, 2);
  $mm = substr($hhmm, 2, 2);
  if ($hh > 24) {
    $err = 1;
    $errmsg = "hour is outside valid range ($hh > 24)";
  }
  if ($mm > 60) {
    $err = 1;
    $errmsg = "minutes is outside valid range ($mm > 60)";
  }
  if ($hhmm !~ /\d\d\d\d/) {
    $err = 1;
    $errmsg = "includes non-numeric characters ($hhmm)";
  }
}
#