#!/usr/bin/perl
#
#
# Runs spectral extraction in many regions and chips
#

@gov = split (/\//,$0); pop @gov; $BINDIR = join ('/',@gov);
$getpar   = "$BINDIR/getpar";
$modhead = "modifyheader";           # from ZHTOOLS
$filtevt  = "$BINDIR/filtevt";
$extrspec = "$BINDIR/extrspec";
$calcarf = "$BINDIR/calcarf";
$calcrmf = "$BINDIR/calcrmf";
$fixdtcor = "$BINDIR/ch_fix_dtcor";
$fcopy = "$BINDIR/fitscopy";
$applygain = "$BINDIR/apply_gain";
$printkey  = "printkey";             # from ZHTOOLS
$img2evt   = "img2evt";              # from ZHTOOLS
$fstat     = "fstatistic";           # from FTOOLS

$evtmaskfilter = "$BINDIR/evtmaskfilter";
$iffits    = "iffits";               # from ZHTOOLS


# Read common PERL subs
require "$BINDIR/perlutil.pl";

# Check external packages
&check_ftools; &check_zhtools;


# Initialize internal variables ($UNDEF etc)
&ini_vars;

@PARS = &fixpars (@ARGV); # this is needed to escape arguments with parens etc
chop (
($chips,$regs,$exclreg,$outkey,$evtfile,$noarf,$noheader,$together,$specchipmap,$dobackscal,$backspec,$dobg,$dormf,$bgfile,$specbgmask,$regwcs,$fixdeadtime,$nochipname,$rmfprog) =
`$getpar chips,regs,exclreg,o,evtfile,noarf,noheader,together,specchipmap,dobackscal,backspec,dobg,dormf,bg_file,specbgmask,regwcs,fix_deadtime,nochipname,calcrmf @PARS`
);

chop (
      ($doreadout,$readout_bg_file,$bgnorm,$useoldresp,
       $shift_from_z,$gainfile,
       $doareascal, $expmap,
       $prefilter_exclreg
      ) =
      `$getpar doreadout,readout_bg_file,bgnorm,useoldresp,shift_from_z,gainfile,doareascal,expmap,prefilter_exclreg @PARS`
     );

# Fill in default values;
if ( $outkey eq $UNDEF )  {  die "please set the output rootname with -o\n"}
if ( $chips  eq $UNDEF )  {  $chips  = "all"; }
if ( $regs   eq $UNDEF )  {  die "please set regions with -regs\n"; }
if ( $evtfile eq $UNDEF ) {  die "Events file not set\n"; }
if ( $noarf  eq $UNDEF )  {  $noarf = 0; }
if ( $noheader eq $UNDEF ){  $noheader = "yes"; } else { $noheader = "no"; }
if ( $together eq $UNDEF ){  $together = 0; }
if ( $dobg  ne $UNDEF && $dobg  ne "no"){$dobg  = 1;} else { $dobg  = 0 };
if ( $dormf ne $UNDEF && $dormf ne "no"){$dormf = 1;} else { $dormf = 0 };
if ( $useoldresp ne $UNDEF && $useoldresp ne "no")
  {$useoldresp = 1;} else { $useoldresp = 0 };
if ( $rmfprog ne $UNDEF ){$calcrmf = $rmfprog;}
if ( $doareascal ne $UNDEF && $doareascal ne "no" ){$doareascal = "yes";} else {$doareascal="no";}

if ( $doreadout ne $UNDEF && $doreadout ne "no"){$doreadout = 1;} else { $doreadout = "" };

if ( $doreadout ) {
  if ( $readout_bg_file eq $UNDEF ) {
    warn "DOREADOUT = yes but readout_bg_file unset; SKIP\n";
    $doreadout = 0;
  }
}

$prefilter_exclreg = 0;
if ($prefilter_exclreg ne $UNDEF ) {
  if ($prefilter_exclreg ne "no" ) {
    if ($dobackscal eq "yes") {
      warn "DOBACKSCAL=yes and PREFILTER_EXCLREG=yes are incompatible; IGNORE prefilter\n";
      $prefilter_exclreg = 0;
    } else {
      if ( $exclreg eq $UNDEF ) {
        warn "PREFILTER_EXCLREG=yes but EXCLREG unset; SKIP\n";
        $prefilter_exclreg = 0;
      } else {
        warn "I WILL PRE-FILTER EVT FILES FOR EXCLREG\n";
        $prefilter_exclreg = 1;
      }
    }
  }
}

if ( $shift_from_z eq $UNDEF )  {
  $shift_from_z = "no";
}
else {
  if ($gainfile eq $UNDEF ) {
    die "please set gain file when using shift_from_z\n";
  }
}


# if we correct readout, a fraction of the background is included there
# so we need to reduce the background normalization
if ( $doreadout && $bgnorm ne $UNDEF ) {
  $bgnorm /= 1.0128125;
  warn "BGNORM reduced by 1.28% to compensate for readout\n";
}

print "dobg=$dobg, dormf=$dormf, dobackscal=$dobackscal, doareascal=$doareascal doreadout=$doreadout\n";

if ( $dobackscal eq "yes" ) {
    if ( $specchipmap eq $UNDEF || $specbgmask eq $UNDEF ) {
      die "You want to update BACKSCAL but did not set specchipmap or specbgmask\n";
    }
    if ( ! -e $specchipmap ) {
      die "specchipmap $specchipmap: file not found\n";
    }
    if ( ! -e $specbgmask ) {
      die "specbgmask $specbgmask: file not found\n";
    }
}

@CLEANLIST = ();
@CLEANLISTE = ();

if ( $doareascal eq "yes" ) {
  if ( $expmap eq $UNDEF ) {
    die "You want to compute AREASCAL but did not set expmap\n";
  }
  if ( ! -e $expmap ) {
    die "expmap $expmap: file not found\n";
  }

  $tmparea_all = $outkey."all_area".$$;
  if ( &runprog ($img2evt,"-o",$tmparea_all,"-i",$expmap,"subpix=4") ){
    die "img2evt failed\n";
  }
  if ( $prefilter_exclreg ) {
    print STDERR "Prefilter areascal evt file ...\n";
    if ( &runprog ($filtevt,"-o",$tmparea_all.".TMP","-exclreg",$exclreg,
                   "-evtfile",$tmparea_all) ) {
      die "pre-filter area evt with exclreg failed\n";
    }
    system ("mv",$tmparea_all.".TMP",$tmparea_all);
  }
}

if ( $dobg ) {
  if ( $bgfile eq $UNDEF ) {
    die "You want to do background but did not set bg_file\n";
  }
  if ( $specbgmask eq $UNDEF && $dobackscal eq "yes" ) {
   die "You want to update BACKSCAL but did not set specbgmask\n";
  }
  $backspec = $UNDEF;
}

$tmpevents = $outkey."_events_$$";
push @CLEANLIST,$tmpevents;
#### PREFILTER_EXCLREG STUFF
if ($prefilter_exclreg) {

  $evtfile_e = $tmpevents.".ex";
  push @CLEANLISTE,$evtfile_e;
  if ( &runprog ($filtevt,"-o",$evtfile_e,"-exclreg",$exclreg,
                "-evtfile",$evtfile) ) {
    die "pre-filter evt with exclreg failed\n";
  }
  unshift @ARGV,"-evtfile",$evtfile_e;

  if ($dobg) {
    $bgfile_e = $tmpevents.".bg.ex";
    push @CLEANLISTE,$bgfile_e;
    if ( &runprog ($filtevt,"-o",$bgfile_e,"-exclreg",$exclreg,
                   "-evtfile",$bgfile) ) {
      die "pre-filter bg with exclreg failed\n";
    }
    unshift @ARGV,"-bg_file",$bgfile_e;
    $bgfile = $bgfile_e;
  }

  if ($doreadout) {
    $readout_bg_file_e = $tmpevents.".rdt.ex";
    push @CLEANLISTE,$readout_bg_file_e;
    if ( &runprog ($filtevt,"-o",$readout_bg_file_e,"-exclreg",$exclreg,
                   "-evtfile",$readout_bg_file) ) {
      die "pre-filter rdt with exclreg failed\n";
    }
    unshift @ARGV,"-readout_bg_file",$readout_bg_file_e;
    $readout_bg_file = $readout_bg_file_e;
  }

  $exclreg=$UNDEF;
  unshift @ARGV,"-exclreg",$UNDEF;

}


# Load region file
if ( $together )
  { # then do not split by region
    %SPECREG = ();
    $SPECREG{"reg1"} = $regs;
  }
else
  { # split by region
    &load_regions ($regs);
  }

foreach $reg ( sort {$a <=> $b} keys %SPECREG ) {
  print "Extracting spectra in region ",$reg,"=",$SPECREG{$reg},"\n";
  
  # Filter events in this region
  print "   filter events...\n";
  if ( &runprog ($filtevt,"-o",$tmpevents,"-reg",$SPECREG{$reg},"-exclreg",$exclreg,@ARGV) ){
    die "filtevt failed\n";
  }

# Filter background file
  if ( $dobg ) {
    push @CLEANLIST,$tmpevents.".bg";
    print "   filter background...\n";
    if ( &runprog ($filtevt,"-o",$tmpevents.".bg","-reg",$SPECREG{$reg},"-exclreg",$exclreg,"-evtfile",$bgfile,"-filtgti","no",@ARGV) ){
      die "filtevt of background failed\n";
    }
  }

# Filter readout file
  if ( $doreadout ) {
    push @CLEANLIST,$tmpevents.".rdt";
    print "   filter readout...\n";
    if ( &runprog ($filtevt,"-o",$tmpevents.".rdt","-reg",$SPECREG{$reg},"-exclreg",$exclreg,"-evtfile",$readout_bg_file,"-filtgti","no",@ARGV) ){
      die "filtevt of readout background failed\n";
    }
  }

# Compute area if needed
  if ( $doareascal eq "yes" ) {
    $tmparea = $tmpevents.".area";
    push @CLEANLIST,$tmparea;
    if ( &runprog ($filtevt,"-o",$tmparea,"-reg",$SPECREG{$reg},"-exclreg",
		   $exclreg,"-evtfile",$tmparea_all,"filtgti=no") ){
      die "filtevt of exposure data failed\n";
    }
    if ( ! -e $tmparea ) { die "$tmparea....\n"; }
    $area = `fstatistic $tmparea+1 VALUE - | grep " sum "`;
    chop $area; @gov=split(' ',$area);
    $area = pop @gov;
  }


# Apply redshifted gain if needed
  if ( $shift_from_z ne "no" ) {
    $tmpgain = "/tmp/gain$$.fits";
    if ( &runprog($fcopy,$gainfile."[AXAF_DETGAIN][col ENERGY=ENERGY*(1+$shift_from_z); *]",$tmpgain) ) {
      die "gain shifting failed\n";
    }

    $corr_tgain_dir = "$ENV{'CH'}/CAL/tgain";
    chop (
	  @tgaindates = `ls $corr_tgain_dir | grep corrgain | grep c3.cti\.fits | grep -v \.v | sort -r `
	 );
    foreach $tgaindate ( @tgaindates ) {
      $tgaindate =~ s/c3.*//;
      $tgaindate =~ s/[^\d-]//g;
    }
    ($info1,$info2) = `$printkey $evtfile\[events\] date-obs,date-end`;
    chop $info1; chop $info2;
    ($date_start) = split (' ',$info1); $date_start =~ s/T.*//;
    ($date_end) = split (' ',$info2); $date_end =~ s/T.*//;
    $mjd_start = &sla_cldj (split('-',$date_start));
    $mjd_end   = &sla_cldj (split('-',$date_end));
    ($yy,$mm,$dd) = &sla_djcl(0.5*($mjd_start+$mjd_end));
    $mm=sprintf("%2.2d",$mm);$dd=sprintf("%2.2d",$dd);
    $date = join('-',$yy,$mm,$dd);

    $epoch=$tgaindates[0];
    foreach $tgaindate ( @tgaindates ) {
      if ( $date ge $tgaindate ) {
	$epoch = $tgaindate;
	last;
      }
    }
    $tgain="$corr_tgain_dir/corrgain$epoch";

    if ( &runprog($applygain,$tmpevents,"gain=$tmpgain","tgain=$tgain") ) {
      die "apply_gain $tmpevents failed" }
    if ( $dobg ) {
      if ( &runprog($applygain,$tmpevents.".bg","gain=$tmpgain") ) {
	die "apply_gain $tmpevents.bg failed" }
    }
    if ( $doreadout ) {
      if ( &runprog($applygain,$tmpevents.".rdt","gain=$tmpgain","tgain=$tgain") ) {
	die "apply_gain $tmpevents.rdt failed" }
    }
    unlink ($tmpgain);
  }

  if ( $together ) {
    $outfilename = $outkey;
  }
  else {
    $outfilename = $outkey."_".$reg;
  }
  foreach $chip ( split (',',$chips) ) {
    if ( $nochipname eq $UNDEF && $chip ne "all" ) {
      $chip_in_out = "_$chip";
    }
    else {
      $chip_in_out = "";
    }
    print "   extracting spectrum in chip $chip\n";
    if ( &runprog ($extrspec,
		   "-evtfile", $tmpevents,
		   "-o", $outfilename.$chip_in_out.".pha",
		   "-chip", $chip,
		   @ARGV) )
      {
	die "extrspec failed\n";
      }
    if ( -e $outfilename.$chip_in_out.".pha" ) {
      if ($fixdeadtime eq "yes" ) {
	system ($fixdtcor $outfilename.$chip_in_out.".pha");
      }
      if ( ! ( $noarf || $useoldresp ) ) {
	if ( &runprog ($calcarf,
		       "-evtfile", $tmpevents,
		       "-phafile", $outfilename.$chip_in_out.".pha",
		       "-o", $outfilename.$chip_in_out.".arf",
		       "-chip", $chip,
		       "updateheader=$noheader",
		       @ARGV) )
	  {
	    die "calcarf failed\n";
	  }
      }
      if ( $dormf && ! $useoldresp ) {
	if ( &runprog ($calcrmf,
		       "-evtfile", $tmpevents,
		       "-phafile", $outfilename.$chip_in_out.".pha",
		       "-o", $outfilename.$chip_in_out.".rmf",
		       "updateheader=$noheader",
		       @ARGV) )
	  {
	    die "calcrmf failed\n";
	  }
      }
      if ( $dobg ) {
	if ( &runprog ($extrspec,
		       "-evtfile", $tmpevents.".bg",
		       "-gtifile", $tmpevents.".bg",
		       "-gtiname", "GTI",
		       "-o", $outfilename.$chip_in_out.".bg",
		       "-chip", $chip,
		       "-keepempty","yes",
		       @ARGV) )
	  {
	    die "extrspec of bg failed\n";
	  }
	if ($fixdeadtime eq "yes" ) {
	  system ($fixdtcor $outfilename.$chip_in_out.".bg");
	}
	if ( $dobackscal eq "yes" ) {
	  if ( $regwcs ne $UNDEF ) {
	    push @CLEANLIST, "/tmp/backscal.reg.$$";
	    system ("transreg","-from",$regwcs,"-to",$specbgmask,"-reg",$SPECREG{$reg},"-out","/tmp/backscal.reg.$$");
	    if ( $exclreg ne $UNDEF ) {
	      system ("transreg","-from",$regwcs,"-to",$specbgmask,"-reg",$exclreg,"-out","/tmp/backscal.exclreg.$$");
	      $newexclreg = "/tmp/backscal.exclreg.$$"; 
	    } else {
	      $newexclreg = $UNDEF;
	    }
	    $backscal = `imexam $specbgmask sum reg=/tmp/backscal.reg.$$ exclreg=$newexclreg`;
	    unlink ("/tmp/backscal.exclreg.$$");
	    if ( $newexclreg ne $UNDEF ) {unlink ($newexclreg);}
	  } else {
	    $backscal = `imexam $specbgmask sum reg=\"$SPECREG{$reg}\" exclreg=\"$exclreg\"`;
	  }
	  $junk=$outfilename.$chip_in_out.".bg";
	  open (MODHEAD,"|$modhead infile=$junk\[spectrum\] templ=-");
	  print MODHEAD "BACKSCAL=",$backscal,"\n";
	  close (MODHEAD);
	}

	if ($doareascal eq "yes" ) {
	  $junk=$outfilename.$chip_in_out.".bg";
	  open (MODHEAD,"|$modhead infile=$junk\[spectrum\] templ=-");
	  print MODHEAD "AREASCAL=",$area,"\n";
	  close (MODHEAD);
	}

      }

 # do readout
      if ( $doreadout ) {
	if ( &runprog ($extrspec,
		       "-evtfile", $tmpevents.".rdt",
		       "-gtifile", $tmpevents.".rdt",
		       "-gtiname", "GTI",
		       "-o", $outfilename.$chip_in_out.".rdt",
		       "-chip", $chip,
		       "-keepempty","yes",
		       @ARGV) )
	  {
	    die "extrspec of readout failed\n";
	  }
	if ($fixdeadtime eq "yes" ) {
	  system ($fixdtcor $outfilename.$chip_in_out.".rdt");
	}
	if ( $dobackscal eq "yes" ) {
	  if ( $regwcs ne $UNDEF ) {
	    push @CLEANLIST, "/tmp/backscal.reg.$$";
	    system ("transreg","-from",$regwcs,"-to",$specchipmap,"-reg",$SPECREG{$reg},"-out","/tmp/backscal.reg.$$");
	    if ( $exclreg ne $UNDEF ) {
	      system ("transreg","-from",$regwcs,"-to",$specchipmap,"-reg",$exclreg,"-out","/tmp/backscal.exclreg.$$");
	      $newexclreg = "/tmp/backscal.exclreg.$$"; 
	    } else {
	      $newexclreg = $UNDEF;
	    }
	    $backscal = `imexam $specchipmap sum reg=/tmp/backscal.reg.$$ exclreg=$newexclreg`;
	    unlink ("/tmp/backscal.exclreg.$$");
	    if ( $newexclreg ne $UNDEF ) {unlink ($newexclreg);}
	  } else {
	    $backscal = `imexam $specchipmap sum reg=\"$SPECREG{$reg}\" exclreg=\"$exclreg\"`;
	  }
	  $junk=$outfilename.$chip_in_out.".rdt";
	  open (MODHEAD,"|$modhead infile=$junk\[spectrum\] templ=-");
	  print MODHEAD "BACKSCAL=",$backscal,"\n";
	  close (MODHEAD);
	}

	if ( $doareascal eq "yes" ) {
	  $junk=$outfilename.$chip_in_out.".rdt";
	  open (MODHEAD,"|$modhead infile=$junk\[spectrum\] templ=-");
	  print MODHEAD "AREASCAL=",$area,"\n";
	  close (MODHEAD);
	}

      }

# end of process
    }
    if ($dobackscal eq "yes" || $backspec ne $UNDEF || $dobg || $doreadout || $doareascal eq "yes" ){
      $junk=$outfilename.$chip_in_out.".pha";
      if ( -e $junk ) {

	open (MODHEAD,"|$modhead infile=$junk\[spectrum\] templ=-");
	if ( $dobackscal eq "yes" ) {
	  if ( $regwcs ne $UNDEF ) {
	    push @CLEANLIST, "/tmp/backscal.reg.$$";
	    system ("transreg","-from",$regwcs,"-to",$specchipmap,"-reg",$SPECREG{$reg},"-out","/tmp/backscal.reg.$$");
	    if ( $exclreg ne $UNDEF ) {
	      system ("transreg","-from",$regwcs,"-to",$specchipmap,"-reg",$exclreg,"-out","/tmp/backscal.exclreg.$$");
	      $newexclreg = "/tmp/backscal.exclreg.$$";
	    } else {
	      $newexclreg = $UNDEF;
	    }
	    print "do imexam\n";
	    print "do imexam\n";
	    $backscal = `imexam $specchipmap sum reg=/tmp/backscal.reg.$$ exclreg=$newexclreg`;
	    print "backscal = $backscal\n";
	    unlink ("/tmp/backscal.exclreg.$$");
	    if ( $newexclreg ne $UNDEF ) {unlink ($newexclreg);}
	  } else {
	    $backscal = `imexam $specchipmap sum reg=\"$SPECREG{$reg}\" exclreg=\"$exclreg\"`;
	  }
	  print "Update BACKSCAL=",$backscal,"\n";
	  print MODHEAD "BACKSCAL=",$backscal,"\n";
	}
	if ($noheader ne "no" ) {
	  if ( $backspec ne $UNDEF ) {
	    print "Update BACKFILE=",$backspec,"\n";
	    print MODHEAD "BACKFILE=",$backspec,"\n";
	  }
	  if ( $dobg ) {
	    print "Update BACKFILE=",$outfilename.$chip_in_out.".bg","\n";
	    print MODHEAD "BACKFILE=",$outfilename.$chip_in_out.".bg","\n";
	    if ($bgnorm ne $UNDEF && $dobackscal ne "yes") {
	      print "Update BACKSCAL=$bgnorm\n";
	      print MODHEAD "BACKSCAL=$bgnorm\n";
	    }
	  }
	  if ( $doreadout ) {
	    print "Update CORRFILE=",$outfilename.$chip_in_out.".rdt","\n";
	    print MODHEAD "CORRFILE=",$outfilename.$chip_in_out.".rdt","\n";
	    print "Update CORRSCAL=1\n";
	    print MODHEAD "CORRSCAL=1\n";
	  }
	  if ( $doareascal eq "yes" ) {
	    print "Update AREASCAL=$area\n";
	    print MODHEAD "AREASCAL=$area\n";
	  }
	  if ( $useoldresp ) {
	    print "Update RESPFILE=",$outfilename.$chip_in_out.".rmf","\n";
	    print MODHEAD "RESPFILE=",$outfilename.$chip_in_out.".rmf","\n";
	    print "Update ANCRFILE=",$outfilename.$chip_in_out.".arf","\n";
	    print MODHEAD "ANCRFILE=",$outfilename.$chip_in_out.".arf","\n";
	  }
	}
	close(MODHEAD);
      }
    }
  }
  unlink (@CLEANLIST);
}
unlink ($tmparea_all,@CLEANLISTE);


#####################################################################
sub load_regions {
  my ($file) = @_;
  my (@words,$regname,$regdescr,$ireg);

  my ($wcsform);
  $wcsform = "";

  open (REGFILE,$file) || die "Cannot open $file\n";
  %SPECREG = ();
  $ireg = 0;
  while (<REGFILE>) {
    if ( /^\s*\#/ ) {
#       if (/Region file format: CIAO/) {
# 	$wcsform="fk5";
#       }
      next;
    }
    if ( ! &valid_region ($_) ) {
      if ( /^image$/i ) { $wcsform = "image"; }
      elsif ( /^linear$/i ) { $wcsform = "linear"; }
      elsif ( /^(fk\d)$/i ) { $wcsform = $1; }
      elsif ( /^j2000$/i ) { $wcsform = "j2000"; }
      elsif ( /^b1950$/i ) { $wcsform = "b1950"; }
      elsif ( /^galactic$/i ) { $wcsform = "galactic"; }
      elsif ( /^ecliptic$/i ) { $wcsform = "ecliptic"; }
      elsif ( /^icrs$/i ) { $wcsform = "icrs"; }
      elsif ( /^physical$/i ) { $wcsform = "physical"; }
      elsif ( /^amplifier$/i ) { $wcsform = "amplifier"; }
      elsif ( /^detector$/i ) { $wcsform = "detector"; }
      elsif ( /^wcs$/i ) { $wcsform = "wcs"; }
      elsif ( /^(wcs[a-zA-Z])$/i ) { $wcsform = $1; }
      else {
	warn "LOAD_REGIONS: $_ is not recognized as valid region\n";
      }
      next;
    }
    s/^\s+//;
    chop;

    if ( $wcsform ) { $_ = "$wcsform;".$_; }

    @words = split /\s+/;
    if ( $#words < 0 ) {
      next;
    }
    
    $ireg++;
    if ( $#words >= 1 ) {
      $regname = pop(@words);
    }
    else {
      $regname = "reg$ireg";
    }
    $regdescr = join(' ',@words);
    $SPECREG{$regname}=$regdescr;
  }
  close(REGFILE);
  return 0;

}


#####################################################################
sub ini_vars {
  $UNDEF = "undefined";
}

############################################################################
sub sla_mod {
 my ($x,$y) = @_;
 return $x-int($x/$y)*$y;
}
sub sla_nint {
  my $x = $_[0];
  my $n = int($x);
  if ( $x > 0 ) {
    if ( $x-$n > 0.5) {
      return $n+1;
    }
    else {
      return $n;
    }
  }
  else {
    if ( $n-$x > 0.5) {
      return $n-1;
    }
    else {
      return $n;
    }
  }
}
sub sla_cldj {
  my ($IY, $IM, $ID) = @_;
  my ($DJM);

  my @MTAB = (0,31,28,31,30,31,30,31,31,30,31,30,31);

  if ($IY<-4699) {
    return -1e10;
  }

# Validate month
  if ($IM>=1&&$IM<=12) {
#     Allow for leap year
    if (sla_mod($IY,4)==0) {
      $MTAB[2]=29;
    } else {
      $MTAB[2]=28;
    }
    if (sla_mod($IY,100)==0&&sla_mod($IY,400)!=0) {
      $MTAB[2]=28;
    }

#   Validate day
    if ($ID<1||ID>$MTAB[$IM]) {
      return -3e10;
    }

    use integer;
    #   Modified Julian Date
    $DJM = (1461*($IY-(12-$IM)/10+4712))/4
      +(306*sla_mod($IM+9,12)+5)/10
	-(3*(($IY-(12-$IM)/10+4900)/100))/4
	  +$ID-2399904;
    return $DJM
  } else {
    return -2e10;
  }
}

sub sla_djcl {
  my ($DJM) = @_;
  my ($IY, $IM, $ID, $FD);
  my ($F,$D,$N4,$ND10);
  if ($DJM<=-2395522||$DJM>=1e9) {
    return (-1e10,-1,-1,-1);
  }

  #  Separate day and fraction
  $F=sla_mod(DJM,1.0);
  if ($F<0.0) { $F+=1.0;}
  $D=sla_nint($DJM-$F);

  #  Express day in Gregorian calendar
  $JD=sla_nint($D)+2400001;

  use integer;
  $N4=4*($JD+((6*((4*$JD-17918)/146097))/4+1)/2-37);
  $ND10=10*(sla_mod($N4-237,1461)/4)+5;
  $IY=$N4/1461-4712;
  $IM=sla_mod($ND10/306+2,12)+1;
  $ID=sla_mod($ND10,306)/10+1;
  $FD=$F;
  return ($IY, $IM, $ID, $FD);
}
